add lisp packages

lisp/treemacs/treemacs-dom.el

@@ -0,0 +1,281 @@
+;;; treemacs.el --- A tree style file viewer package -*- lexical-binding: t -*-
+
+;; Copyright (C) 2020 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))
+
+(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))
+       (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)
+  "Rearrange 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)
+  "Rearragne 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 of DOM-NODE's children 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 acutally
+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))
+  (dolist (it (treemacs-dom-node->children node))
+    (treemacs-walk-dom it fn))
+  (funcall fn node))
+
+(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))
+  (dolist (it (treemacs-dom-node->reentry-nodes node))
+    (treemacs-walk-reentry-dom it fn))
+  (funcall fn node))
+
+(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