treelib

;;; treelib.el --- TODO -*- lexical-binding: t -*-

;;; Commentary:

;;; Code:

(defsubst treelib-current-button ()
  "Get the button in the current line, if any."
  (if (get-text-property (point-at-bol) 'button)
      (button-at (point-at-bol))
    (let ((p (next-single-property-change (point-at-bol) 'button nil (point-at-eol))))
      (when (and (get-char-property p 'button))
        (copy-marker p t)))))

(defsubst treelib-as-button (obj &rest more-properties)
  "TODO OBJ."
  (declare (indent 1))
  (apply #'propertize obj 'button '(t) 'category 'default-button more-properties))

(defsubst treelib-as-icon (obj &rest more-properties)
  "TODO OBJ."
  (declare (indent 1))
  (apply #'propertize obj 'icon t more-properties))

(defsubst treelib--next-non-child-button (btn)
  "Return the next button after BTN that is not a child of BTN."
  (declare (side-effect-free t))
  (when btn
    (let ((depth (button-get btn :depth))
          (next (next-button (button-end btn) t)))
      (while (and next (< depth (button-get next :depth)))
        (setq next (next-button (button-end next) t)))
      next)))

(defmacro treelib-with-writable-buffer (&rest body)
  "Temporarily turn off read-ony mode to execute BODY."
  (declare (debug (form body)))
  `(let (buffer-read-only)
     ,@body))

(defun treelib-change-icon (new-icon)
  "TODO NEW-ICON."
  (save-excursion
    (let* ((icon-start (next-single-property-change (point-at-bol) 'icon nil (point-at-eol)))
           (icon-end (next-single-property-change icon-start 'icon nil (point-at-eol))))
      (goto-char icon-start)
      (delete-char (- icon-end icon-start))
      (insert (propertize new-icon 'icon t)))))

(cl-defmacro treelib-create-buttons
    (&key nodes depth extra-vars node-action node-name (indent-string " "))
  ""
  `(let* ((depth ,depth)
          (prefix (concat "\n" (s-repeat depth ,indent-string)))
          (,node-name (cl-first ,nodes))
          (strings)
          ,@extra-vars)
     (when ,node-name
       (dolist (,node-name ,nodes)
         (--each ,node-action
           (push it strings))))
     (nreverse strings)))

(cl-defmacro treelib--button-open
    (&key button new-state new-icon open-action post-open-action immediate-insert)
  ""
  `(save-excursion
     (treelib-with-writable-buffer
      (button-put ,button :state ,new-state)
      (beginning-of-line)
      ,@(when new-icon
          `((treelib-change-icon ,new-icon)))
      ,@(if immediate-insert
            `((progn
                (end-of-line)
                (insert (apply #'concat ,open-action))))
          `(,open-action))
      ,post-open-action)))

(cl-defmacro treelib--button-close
    (&key button new-state new-icon post-close-action)
  "Close node given by BTN, use NEW-ICON and set state of BTN to NEW-STATE."
  `(save-excursion
     (treelib-with-writable-buffer
      ,@(when new-icon
          `((treelib-change-icon ,new-icon)))
      (end-of-line)
      (forward-button 1)
      (beginning-of-line)
      (let* ((pos-start (point))
             (next (treelib--next-non-child-button ,button));;TODO
             (pos-end (if next (-> next (button-start) (previous-button) (button-end) (1+)) (point-max))))
        (button-put ,button :state ,new-state)
        (delete-region pos-start pos-end)
        (delete-trailing-whitespace))
      ,post-close-action)))

(provide 'treelib)

;;; treelib.el ends here

treelib-showcase

(require 'button)
(require 'treelib)
(require 'dash)

(defvar showcase-closed-buffer-list-icon
  (treelib-as-icon "+ " 'face 'font-lock-builtin-face))

(defvar showcase-open-buffer-list-icon
  (treelib-as-icon "- " 'face 'font-lock-builtin-face))

(defvar showcase-buffer-button-icon
  (treelib-as-icon "• " 'face 'font-lock-builtin-face))

(defsubst showcase-get-buffers ()
  (->> (buffer-list)
       (--reject (eq ?\ (aref (buffer-name it) 0)))
       (--group-by (with-current-buffer it major-mode))))

(defun showcase-create-main-button ()
  (insert (treelib-as-button "Buffers"
            'face 'font-lock-keyword-face
            :depth 0
            :state 'main-button-closed)))

(defun showcase-create-major-mode-button (lst prefix depth)
  (let ((mode (car lst))
        (buffers (cdr lst)))
    (list
     prefix
     showcase-closed-buffer-list-icon
     (treelib-as-button (symbol-name mode)
       'face 'font-lock-type-face
       :state 'buffers-mode-closed
       :depth depth
       :buffers buffers))))

(defun showcase-create-buffer-button (buffer prefix depth)
  (list
   prefix
   showcase-buffer-button-icon
   (treelib-as-button (buffer-name buffer)
     'face 'font-lock-function-name-face
     :depth depth
     :buffer buffer
     :state 'buffer)))

(defun showcase-expand-buffers (btn)
  (let ((buffers-alist (showcase-get-buffers)))
    (treelib--button-open
     :button btn
     :new-state 'buffers-open
     :immediate-insert t
     :open-action
     (treelib-create-buttons
      :nodes buffers-alist
      :depth 1
      :node-name mode->buffers
      :node-action
      (showcase-create-major-mode-button mode->buffers prefix depth)))))

(defun showcase-close-buffers (btn)
  (treelib--button-close
   :button btn
   :new-state 'main-button-closed))

(defun showcase-expand-mode-buffers (btn)
  (treelib--button-open
   :button btn
   :new-state 'buffers-mode-open
   :new-icon showcase-open-buffer-list-icon
   :immediate-insert t
   :open-action
   (treelib-create-buttons
    :nodes (button-get btn :buffers)
    :node-name buffer
    :depth (1+ (button-get btn :depth))
    :node-action
    (showcase-create-buffer-button buffer prefix depth))))

(defun showcase-close-mode-buffers (btn)
  (treelib--button-close
   :button btn
   :new-icon showcase-closed-buffer-list-icon
   :new-state 'buffers-mode-closed))

(defun showcase-pop-to-buffer (btn)
  (pop-to-buffer (button-get btn :buffer)))

(defun showcase-push-button ()
  (interactive)
  (when-let (btn (treelib-current-button))
    (pcase (button-get btn :state)
      (`main-button-closed
       (showcase-expand-buffers btn))
      (`buffers-open
       (showcase-close-buffers btn))
      (`buffers-mode-closed
       (showcase-expand-mode-buffers btn))
      (`buffers-mode-open
       (showcase-close-mode-buffers btn))
      (`buffer
       (showcase-pop-to-buffer btn)))))

(setq treelib-showcase-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map [tab] #'showcase-push-button)
    map))

(define-derived-mode treelib-showcase-mode special-mode "Treelib Showcase")

(defun treelib-showcase ()
  (interactive)
  (--if-let (get-buffer "Treelib Showcase")
      (kill-buffer it))
  (pop-to-buffer (get-buffer-create "Treelib Showcase"))
  (treelib-showcase-mode)
  (treelib-with-writable-buffer
   (showcase-create-main-button)))