feat: skip intermediate directories if collapse is enabled

dirvish-tramp.el

@@ -73,9 +73,10 @@ FN is the original `dired-noselect' closure."
              (f-dirp (string-prefix-p "d" priv))
              (f-type (or f-truename f-dirp)))
         (puthash (secure-hash 'md5 (expand-file-name f-name entry))
-                 `(:builtin ,(list f-type lnum user group nil
-                                   f-mtime nil size priv nil inode)
-                            :type ,(cons (if f-dirp 'dir 'file) f-truename))
+                 (dirvish--ht
+                  :builtin (list f-type lnum user group nil
+                                 f-mtime nil size priv nil inode)
+                  :type (cons (if f-dirp 'dir 'file) f-truename))
                  dirvish--dir-data)))))
 
 (defun dirvish-tramp-dir-data-proc-s (proc _exit)

dirvish.el

@@ -338,7 +338,7 @@ opening and customized handling of specific file types."
 (defvar dirvish--sessions (make-hash-table :test #'equal))
 (defvar dirvish--available-attrs '())
 (defvar dirvish--available-preview-dispatchers '())
-(defvar-local dirvish--props '())
+(defvar-local dirvish--props nil)
 (defvar-local dirvish--dir-data nil)
 
 ;;;; Helpers
@@ -347,11 +347,10 @@ opening and customized handling of specific file types."
   "Retrieve PROP from `dirvish--props'.
 Set the PROP with BODY if given."
   (declare (indent defun))
-  `(let* ((pair (assq ,prop dirvish--props)) (val (cdr pair)))
-     ,(if body `(prog1 (setq val ,@body)
-                  (if pair (setcdr (assq ,prop dirvish--props) val)
-                    (push (cons ,prop val) dirvish--props)))
-        `val)))
+  `(progn
+     (unless dirvish--props (setq dirvish--props (dirvish--ht)))
+     ,(if body `(puthash ,prop (progn ,@body) dirvish--props)
+        `(gethash ,prop dirvish--props))))
 
 (defun dirvish--run-with-delay (action &optional record fun debounce throttle)
   "Run function FUN accroding to ACTION with delay.
@@ -391,9 +390,16 @@ RECORD defaults to `:default' record in `dirvish--timers'."
   "Return Dirvish session attached to current buffer, if there is any."
   (gethash (dirvish-prop :dv) dirvish--sessions))
 
-(defun dirvish--ht ()
-  "Return a new hash-table with `equal' as its test function."
-  (make-hash-table :test #'equal))
+(defmacro dirvish--ht (&rest kvs)
+  "Return a new hash-table with `equal' as its test function.
+KVS is list of key value pair that will be inserted to the hash table.
+
+\(fn [KEY VAL]...)"
+  (declare (indent defun))
+  `(let ((h (make-hash-table :test 'equal)))
+     ,@(cl-loop for (k v) on kvs by #'cddr
+                collect `(puthash ,k ,v h))
+     h))
 
 (defun dirvish--timestamp ()
   "Return current timestamp string with \"%D|%T\" format."
@@ -458,7 +464,7 @@ Set process's SENTINEL and PUTS accordingly."
          (print-length nil) (print-level nil)
          (cmd (if (stringp (car form)) form
                 (list dirvish-emacs-bin
-                      "-Q" "-batch" "--eval" (prin1-to-string form))))
+                      "-Q" "--batch" "--eval" (prin1-to-string form))))
          (proc (make-process :name "dirvish" :connection-type nil :buffer buf
                              :command cmd :sentinel sentinel :noquery t)))
     (while-let ((k (pop puts)) (v (pop puts))) (process-put proc k v))))
@@ -866,10 +872,12 @@ When the attribute does not exist, set it with BODY."
   (declare (indent defun))
   `(let* ((md5 (secure-hash 'md5 ,file))
           (hash (gethash md5 dirvish--dir-data))
-          (cached (plist-get hash ,attribute))
-          (attr (or cached ,@body)))
+          (cached (when hash (gethash ,attribute hash)))
+          (attr (or cached (progn ,@body))))
      (unless cached
-       (puthash md5 (append hash (list ,attribute attr)) dirvish--dir-data))
+       (setq hash (or hash (dirvish--ht)))
+       (puthash ,attribute attr hash)
+       (puthash md5 hash dirvish--dir-data))
      attr))
 
 (defun dirvish--attrs-expand (attrs)
@@ -1234,15 +1242,19 @@ LEVEL is the depth of current window."
 INHIBIT-SETUP is passed to `dirvish-data-for-dir'."
   (dirvish--make-proc
    `(prin1
-     (let ((hs (make-hash-table)) (bk ',(dirvish-prop :vc-backend)))
+     (let ((hs (make-hash-table :test 'equal)) (bk ',(dirvish-prop :vc-backend)))
        (if ,(and (not (dirvish-prop :sudo)) (dirvish-prop :remote)) (setq bk 0)
          (dolist (f (ignore-errors ; `dir' can be problematic due to its encoding
                       (directory-files ,(file-local-name dir) t nil t 20000)))
            (let* ((attrs (ignore-errors (file-attributes f))) (tp (nth 0 attrs)))
              (cond ((eq t tp) (setq tp '(dir . nil)))
                    (tp (setq tp `(,(if (file-directory-p tp) 'dir 'file) . ,tp)))
                    (t (setq tp '(file . nil))))
-             (puthash (secure-hash 'md5 f) `(:builtin ,attrs :type ,tp) hs)))
+             (puthash (secure-hash 'md5 f)
+                      (let ((h (make-hash-table :test 'equal)))
+                        (puthash :builtin attrs h)
+                        (puthash :type tp h) h)
+                      hs)))
          (setq bk (or bk (vc-responsible-backend ,(file-local-name dir) t))))
        (cons bk hs)))
    (lambda (p _)

extensions/dirvish-collapse.el

@@ -34,9 +34,9 @@
   "Separator string for `collapse' attribute."
   :group 'dirvish :type 'string)
 
-(defun dirvish-collapse--cache (f-name)
-  "Cache collapse state for file F-NAME."
-  (dirvish-attribute-cache f-name :collapse
+(defun dirvish-collapse--cache-list (f-name)
+  "Cache collapse list for file F-NAME."
+  (dirvish-attribute-cache f-name :collapse-list
     (let ((path f-name) should-collapse files dirp)
       (while (and (setq dirp (file-directory-p path))
                   (setq files (ignore-errors (directory-files path)))
@@ -53,11 +53,26 @@
        (should-collapse
         (let* ((path (substring path (1+ (length f-name))))
                (segs (split-string path "/"))
-               (head (format "%s%s%s" dirvish-collapse-separator
-                             (mapconcat #'concat (butlast segs)
+               (head (butlast segs))
+               (tail (cons (car (last segs)) dirp)))
+          (cons head tail)))
+       (t (cons nil nil))))))
+
+(defun dirvish-collapse--cache (f-name)
+  "Cache collapse state for file F-NAME."
+  (dirvish-attribute-cache f-name :collapse
+    (let* ((list (dirvish-collapse--cache-list f-name))
+           (head-list (car list)))
+      (if (or (eq head-list 'empty)
+              (eq head-list nil))
+          list
+        (let* ((head (format "%s%s%s" dirvish-collapse-separator
+                             (mapconcat #'concat head-list
                                         dirvish-collapse-separator)
                              dirvish-collapse-separator))
-               (tail (car (last segs)))
+               (tail-list (cdr list))
+               (tail (car tail-list))
+               (dirp (cdr tail-list))
                (tail-face (if dirp 'dirvish-collapse-dir-face
                             'dirvish-collapse-file-face)))
           (and (equal head (format "%s%s" dirvish-collapse-separator
@@ -66,8 +81,7 @@
           (add-face-text-property
            0 (length head) 'dirvish-collapse-dir-face nil head)
           (add-face-text-property 0 (length tail) tail-face nil tail)
-          (cons head tail)))
-       (t (cons nil nil))))))
+          (cons head tail))))))
 
 (dirvish-define-attribute collapse
   "Collapse unique nested paths."

extensions/dirvish-subtree.el

@@ -53,6 +53,12 @@ The value is a cons of \\='(HEIGHT . V-ADJUST) that used as values of
 `nerd-icons'."
   :type '(cons float float) :group 'dirvish)
 
+(defcustom dirvish-subtree-skip-intermediate-folders t
+  "Skip intermediate folders when `collapse' attribute is enabled.
+Add `collapse' to `dirvish-attributes' and/or `dirvish-side-attributes' for
+this option to apply."
+  :type 'boolean :group 'dirvish)
+
 (defvar dirvish-subtree--state-icons nil)
 (defcustom dirvish-subtree-state-style 'chevron
   "Icon/string used for directory expanded state.
@@ -119,6 +125,24 @@ window as its sole argument."
 
 (defvar-local dirvish-subtree--overlays nil "Subtree overlays in this buffer.")
 
+(defun dirvish-subtree--skip-dir (dir)
+  "Skip intermediary directories from parent DIR."
+  (when (and dirvish-subtree-skip-intermediate-folders
+             (assoc 'collapse (dirvish-prop :attrs)))
+    (require 'dirvish-collapse)
+    (let* ((collapse-cache (dirvish-collapse--cache-list dir))
+           (collapse-dirs (car collapse-cache)))
+      (unless (or (eq collapse-dirs 'empty)
+                  (eq collapse-dirs nil))
+        (let* ((collapse-tail-list (cdr collapse-cache))
+               (collapse-tail (car collapse-tail-list))
+               (collapse-dirp (cdr collapse-tail-list)))
+          (when collapse-dirp
+            (setq collapse-dirs (append collapse-dirs (list collapse-tail))))
+          (when (length> collapse-dirs 0)
+            (setq dir (concat dir "/" (mapconcat #'identity collapse-dirs "/"))))))))
+  dir)
+
 (cl-loop
  for (sym ad how) in '((dired-current-directory dirvish-curr-dir-a :around)
                        (dired-subdir-index dirvish-subdir-index-a :around)
@@ -132,7 +156,7 @@ window as its sole argument."
   "Advice for FN `dired-current-directory'.
 LOCALP is the arg for `dired-current-directory', which see."
   (if-let* ((parent (dirvish-subtree--parent))
-            (dir (concat (overlay-get parent 'dired-subtree-name) "/")))
+            (dir (concat (dirvish-subtree--skip-dir (overlay-get parent 'dired-subtree-name)) "/")))
       (if localp (dired-make-relative dir default-directory) dir)
     (funcall fn localp)))
 
@@ -199,6 +223,7 @@ creation even the entry is in nested subtree nodes."
 
 (defun dirvish-subtree--readin (dir)
   "Readin DIR as a subtree node."
+  (setq dir (dirvish-subtree--skip-dir dir))
   (let ((flags (or dirvish-subtree-listing-switches dired-actual-switches))
         (omit-p (bound-and-true-p dired-omit-mode))
         str)
@@ -220,7 +245,7 @@ creation even the entry is in nested subtree nodes."
                      (substring s (next-single-property-change
                                    0 'dired-filename s))))
                   (split-string str "\n"))
-                             "\n")
+                 "\n")
               str)))))))
 
 (defun dirvish-subtree--insert ()
@@ -318,14 +343,16 @@ See `dirvish-subtree-file-viewer' for details"
                                                (dired-current-directory))))))
   (let* ((file (dired-get-filename nil t))
          (dir (dired-current-directory))
-         (f-dir (and file (file-directory-p file) (file-name-as-directory file))))
+         (f-dir (and file
+                     (file-directory-p file)
+                     (file-name-as-directory (dirvish-subtree--skip-dir file)))))
     (cond ((equal file target) target)
           ;; distinguish directories with same prefix, e.g .git/ and .github/
           ((and file (string-prefix-p (or f-dir file) target))
            (unless (dirvish-subtree--expanded-p) (dirvish-subtree--insert))
            (let ((depth (1+ (dirvish-subtree--depth)))
                  (next (car (split-string
-                             (substring target (1+ (length file))) "/"))))
+                             (substring target (length f-dir)) "/"))))
              (when (dirvish-subtree--move-to-file next depth)
                (dirvish-subtree-expand-to target))))
           ((string-prefix-p dir target)

extensions/dirvish-vc.el

@@ -120,7 +120,10 @@ It is called when `:vc-backend' is included in DIRVISH-PROPs while
                           (format "git log -1 --pretty=%%s %s"
                                   (shell-quote-argument file))))))
            (puthash (secure-hash 'md5 file)
-                    `(:vc-state ,state :git-msg ,msg) hs)))
+                    (let ((h (make-hash-table :test 'equal)))
+                      (puthash :vc-state state h)
+                      (puthash :git-msg msg h) h)
+                    hs)))
        (cons info hs)))
    (lambda (p _)
      (pcase-let ((`(,buf . ,inhibit-setup) (process-get p 'meta))
@@ -131,8 +134,8 @@ It is called when `:vc-backend' is included in DIRVISH-PROPs while
            (maphash
             (lambda (k v)
               (let ((orig (gethash k dirvish--dir-data)))
-                (setf (plist-get orig :vc-state) (plist-get v :vc-state))
-                (setf (plist-get orig :git-msg) (plist-get v :git-msg))
+                (puthash :vc-state (gethash :vc-state v) orig)
+                (puthash :git-msg (gethash :git-msg v) orig)
                 (puthash k orig dirvish--dir-data)))
             data)
            (dirvish-prop :vc-info info)