288 lines
10 KiB
EmacsLisp
288 lines
10 KiB
EmacsLisp
;;; treemacs.el --- A tree style file viewer package -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2024 Alexander Miller
|
|
|
|
;; This program is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Basically this: https://github.com/Alexander-Miller/treemacs/issues/143.
|
|
|
|
;;; Code:
|
|
|
|
(require 'ht)
|
|
(require 'dash)
|
|
(require 's)
|
|
|
|
(eval-when-compile
|
|
(require 'cl-lib)
|
|
(require 'inline)
|
|
(require 'treemacs-macros))
|
|
|
|
(eval-when-compile
|
|
(cl-declaim (optimize (speed 3) (safety 0))))
|
|
|
|
(defvar-local treemacs-dom nil)
|
|
|
|
(cl-defstruct (treemacs-dom-node
|
|
(:conc-name treemacs-dom-node->)
|
|
(:constructor treemacs-dom-node->create!))
|
|
key
|
|
parent
|
|
children
|
|
reentry-nodes
|
|
position
|
|
refresh-flag
|
|
collapse-keys)
|
|
|
|
;; needed because simple declare-function for pos slot in core-utils wont properly expand via setf
|
|
(define-inline treemacs-dom-node->set-position! (self value)
|
|
"Set `position' field of SELF to VALUE.
|
|
|
|
SELF: Dom Node Struct
|
|
VALUE: Marker"
|
|
(inline-letevals (self value)
|
|
(inline-quote
|
|
(setf (treemacs-dom-node->position ,self) ,value))))
|
|
|
|
(defun treemacs--reset-dom ()
|
|
"Reset the dom."
|
|
(setf treemacs-dom (make-hash-table :size 1000 :test 'equal)))
|
|
|
|
(define-inline treemacs-find-in-dom (key)
|
|
"Get node with KEY, if any.
|
|
|
|
KEY: Node Path"
|
|
(declare (side-effect-free t))
|
|
(inline-letevals (key)
|
|
(inline-quote
|
|
(ht-get treemacs-dom ,key))))
|
|
|
|
(define-inline treemacs-dom-node->insert-into-dom! (self)
|
|
"Insert SELF into the dom.
|
|
|
|
SELF: Dom Node Struct"
|
|
(inline-letevals (self)
|
|
(inline-quote
|
|
(ht-set! treemacs-dom (treemacs-dom-node->key ,self) ,self))))
|
|
|
|
(define-inline treemacs-dom-node->add-child! (self child)
|
|
"Add CHILD to to the children of SELF."
|
|
(inline-letevals (self child)
|
|
(inline-quote
|
|
(setf (treemacs-dom-node->children ,self)
|
|
(cons ,child (treemacs-dom-node->children ,self))))))
|
|
|
|
(define-inline treemacs-dom-node->remove-from-dom! (self)
|
|
"Remove SELF from the dom.
|
|
|
|
SELF: Dom Node Struct"
|
|
(inline-letevals (self)
|
|
(inline-quote
|
|
(progn
|
|
(ht-remove! treemacs-dom (treemacs-dom-node->key ,self))
|
|
(let ((parent (treemacs-dom-node->parent ,self)))
|
|
(setf (treemacs-dom-node->children parent)
|
|
(delete ,self (treemacs-dom-node->children parent))))
|
|
(dolist (key (treemacs-dom-node->collapse-keys ,self))
|
|
(ht-remove! treemacs-dom key))))))
|
|
|
|
(define-inline treemacs-dom-node->remove-collapse-keys! (self keys)
|
|
"Remove the given collapse KEYS from both SELF and the dom."
|
|
(inline-letevals (self keys)
|
|
(inline-quote
|
|
(progn
|
|
(dolist (key ,keys)
|
|
(ht-remove! treemacs-dom key))
|
|
(setf (treemacs-dom-node->collapse-keys ,self)
|
|
(--reject (member it ,keys) (treemacs-dom-node->collapse-keys ,self)))))))
|
|
|
|
(define-inline treemacs-dom-node->all-parents (self)
|
|
"Get all parent nodes of SELF.
|
|
List will be sorted top to bottom.
|
|
|
|
SELF: Dom Node Struct"
|
|
(declare (side-effect-free t))
|
|
(inline-letevals (self)
|
|
(inline-quote
|
|
(let ((parent (treemacs-dom-node->parent ,self))
|
|
(ret))
|
|
(while parent
|
|
(push parent ret)
|
|
(setf parent (treemacs-dom-node->parent parent)))
|
|
ret))))
|
|
|
|
(define-inline treemacs-on-expand (key pos)
|
|
"Re-arrange the dom when node at KEY with POS is expanded.
|
|
|
|
KEY: Node Path
|
|
POS: Marker"
|
|
(inline-letevals (key pos)
|
|
(inline-quote
|
|
(-if-let (dom-node (treemacs-find-in-dom ,key))
|
|
(progn
|
|
(setf (treemacs-dom-node->position dom-node) ,pos)
|
|
(dolist (collapse-key (treemacs-dom-node->collapse-keys dom-node))
|
|
(setf (treemacs-dom-node->position (treemacs-find-in-dom collapse-key)) ,pos))
|
|
(-when-let (parent-dom-node (treemacs-dom-node->parent dom-node))
|
|
(setf (treemacs-dom-node->reentry-nodes parent-dom-node)
|
|
(cons dom-node (treemacs-dom-node->reentry-nodes parent-dom-node)))))
|
|
;; expansion of root
|
|
(setf dom-node (treemacs-dom-node->create! :key ,key :position ,pos))
|
|
(treemacs-dom-node->insert-into-dom! dom-node)))))
|
|
|
|
(define-inline treemacs-on-collapse (key &optional purge)
|
|
"Re-arrange the dom when node at KEY was collapsed.
|
|
Will remove NODE's parent/child link and invalidate the position and refresh
|
|
data of NODE and all its children. When PURGE is non-nil will instead remove
|
|
NODE and its children from the dom.
|
|
|
|
KEY: Node Path
|
|
Purge: Boolean"
|
|
(inline-letevals (key purge)
|
|
(inline-quote
|
|
(let* ((dom-node (treemacs-find-in-dom ,key))
|
|
(children (treemacs-dom-node->children dom-node)))
|
|
(-when-let (parent-dom-node (treemacs-dom-node->parent dom-node))
|
|
(setf (treemacs-dom-node->reentry-nodes parent-dom-node)
|
|
(delete dom-node (treemacs-dom-node->reentry-nodes parent-dom-node))))
|
|
(cond
|
|
(,purge
|
|
(treemacs--on-purged-collapse dom-node))
|
|
(children
|
|
(treemacs--on-collapse-of-node-with-children dom-node))
|
|
(t
|
|
(treemacs--on-collapse-of-node-without-children dom-node)))))))
|
|
|
|
(define-inline treemacs--on-purged-collapse (dom-node)
|
|
"Run when a DOM-NODE is collapsed with a purge (prefix) argument.
|
|
Will remove all the children of DOM-NODE from the dom.
|
|
|
|
DOM-NODE: Dom Node Struct"
|
|
(inline-letevals (dom-node)
|
|
(inline-quote
|
|
(progn
|
|
(treemacs-walk-dom-exclusive ,dom-node
|
|
(lambda (it) (treemacs-dom-node->remove-from-dom! it)))
|
|
(setf (treemacs-dom-node->children ,dom-node) nil
|
|
(treemacs-dom-node->reentry-nodes ,dom-node) nil)))))
|
|
|
|
(define-inline treemacs--on-collapse-of-node-without-children (dom-node)
|
|
"Run when a DOM-NODE without any children is collapsed.
|
|
Will remove DOm-NODE from its parent's reentry list.
|
|
|
|
DOM-NODE: Dom Node Struct"
|
|
(inline-letevals (dom-node)
|
|
(inline-quote
|
|
(let ((parent-dom-node (treemacs-dom-node->parent ,dom-node)))
|
|
(when parent-dom-node
|
|
(setf (treemacs-dom-node->reentry-nodes parent-dom-node)
|
|
(delete ,dom-node (treemacs-dom-node->reentry-nodes parent-dom-node))))))))
|
|
|
|
(define-inline treemacs--on-collapse-of-node-with-children (dom-node)
|
|
"Run when a DOM-NODE with children is collapsed.
|
|
Will remove all entries below the one collapsed from the dom.
|
|
|
|
DOM-NODE: Dom Node Struct"
|
|
(inline-letevals (dom-node)
|
|
(inline-quote
|
|
(progn
|
|
(treemacs-walk-dom-exclusive ,dom-node
|
|
(lambda (it)
|
|
(treemacs-dom-node->remove-from-dom! it)
|
|
(setf (treemacs-dom-node->children it) nil)))
|
|
(setf (treemacs-dom-node->children ,dom-node) nil)))))
|
|
|
|
(defun treemacs--on-rename (old-name new-name dont-rename-initial)
|
|
"Renames dom entries after a file was renamed from OLD-NAME to NEW-NAME.
|
|
Renames the initial dom entry (the one backing the file that was actually
|
|
renamed) only if DONT-RENAME-INITIAL is nil in case the entry is required for
|
|
filewatch-mode to work.
|
|
|
|
OLD-NAME: File Path | Tag Path
|
|
NEW-NAME: File Path | Tag Path
|
|
DONT-RENAME-INITIAL: Boolean"
|
|
(-when-let (dom-node (treemacs-find-in-dom old-name))
|
|
(-let [migrate-keys
|
|
(lambda (it)
|
|
(let* ((old-key (treemacs-dom-node->key it))
|
|
(new-key (cond
|
|
((stringp old-key)
|
|
(s-replace old-name new-name old-key))
|
|
((and (consp old-key) (stringp (car old-key)))
|
|
(cons (s-replace old-name new-name (car old-key)) (cdr old-key))))))
|
|
(when new-key
|
|
(ht-remove! treemacs-dom old-key)
|
|
(ht-set! treemacs-dom new-key it)
|
|
(setf (treemacs-dom-node->key it) new-key))))]
|
|
;; when filewatch is enabled the acutally renamed file needs to keep
|
|
;; its dom entry until refresh actually runs so it can be deleted properly
|
|
(if dont-rename-initial
|
|
(progn
|
|
(treemacs-walk-reentry-dom-exclusive dom-node migrate-keys)
|
|
(treemacs-walk-dom-exclusive dom-node migrate-keys))
|
|
(treemacs-walk-dom dom-node migrate-keys)
|
|
(treemacs-walk-reentry-dom dom-node migrate-keys)))))
|
|
|
|
(defun treemacs-walk-dom (node fn)
|
|
"Recursively walk the dom starting at NODE.
|
|
Calls FN on every node encountered in a depth-first pattern, starting with the
|
|
deepest. This assures that FN may destructively modify the dom, at least on
|
|
levels the one currently visiting.
|
|
|
|
NODE: Dom Node Struct
|
|
FN: (Dom Node) -> Any"
|
|
(declare (indent 1))
|
|
(-let [children (treemacs-dom-node->children node)]
|
|
(funcall fn node)
|
|
(dolist (it children)
|
|
(treemacs-walk-dom it fn))))
|
|
|
|
(defun treemacs-walk-dom-exclusive (node fn)
|
|
"Same as `treemacs-walk-dom', but start NODE will not be passed to FN.
|
|
|
|
NODE: Dom Node Struct
|
|
FN: (Dom Node) -> Any"
|
|
(declare (indent 1))
|
|
(dolist (it (treemacs-dom-node->children node))
|
|
(treemacs-walk-dom it fn)))
|
|
|
|
(defun treemacs-walk-reentry-dom (node fn)
|
|
"Recursively walk the dom starting at NODE.
|
|
Unlike `treemacs-walk-dom' only expanded nodes are selected.
|
|
|
|
Calls FN on every node encountered in a depth-first pattern, starting with the
|
|
deepest. This assures that FN may destructively modify the dom, at least on
|
|
levels the one currently visiting.
|
|
|
|
NODE: Dom Node Struct
|
|
FN: (Dom Node) -> Any"
|
|
(declare (indent 1))
|
|
(funcall fn node)
|
|
(dolist (it (treemacs-dom-node->reentry-nodes node))
|
|
(treemacs-walk-reentry-dom it fn)))
|
|
|
|
(defun treemacs-walk-reentry-dom-exclusive (node fn)
|
|
"Same as `treemacs-walk-reentry-dom', but start NODE will not be passed to FN.
|
|
|
|
NODE: Dom Node Struct
|
|
FN: (Dom Node) -> Any"
|
|
(declare (indent 1))
|
|
(dolist (it (treemacs-dom-node->reentry-nodes node))
|
|
(treemacs-walk-reentry-dom it fn)))
|
|
|
|
(provide 'treemacs-dom)
|
|
|
|
;;; treemacs-dom.el ends here
|