Skip to content

Commit fc8eb63

Browse files
rynffollrynffoll
committed
diff-hl-dired: Handle nested file paths
- Support multi-level nested paths in VC status (e.g. a/b/c.txt) - Debounce concurrent VC process calls with pending flag - Move diff-hl-dired-clear to diff-hl-dired-highlight-items to avoid flicker - Pass basename and full path to dired-goto-file-1 for nested entries
1 parent e79aa49 commit fc8eb63

1 file changed

Lines changed: 75 additions & 47 deletions

File tree

‎diff-hl-dired.el‎

Lines changed: 75 additions & 47 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,9 @@
3737

3838
(defvar diff-hl-dired-process-buffer nil)
3939

40+
(defvar diff-hl-dired--pending nil
41+
"Non-nil if a `diff-hl-dired-update' is pending due to concurrent VC process.")
42+
4043
(defgroup diff-hl-dired nil
4144
"VC diff highlighting on the side of a Dired window."
4245
:group 'diff-hl)
@@ -59,7 +62,7 @@
5962

6063
(defface diff-hl-dired-ignored
6164
'((default :inherit dired-ignored))
62-
"Face used to highlight unregistered files.")
65+
"Face used to highlight ignored files.")
6366

6467
(defcustom diff-hl-dired-extra-indicators t
6568
"Non-nil to indicate ignored files."
@@ -86,6 +89,7 @@ status indicators."
8689
(progn
8790
(diff-hl-maybe-define-bitmaps)
8891
(set (make-local-variable 'diff-hl-dired-process-buffer) nil)
92+
(set (make-local-variable 'diff-hl-dired--pending) nil)
8993
(add-hook 'dired-after-readin-hook 'diff-hl-dired-update nil t))
9094
(remove-hook 'dired-after-readin-hook 'diff-hl-dired-update t)
9195
(diff-hl-dired-clear)))
@@ -95,66 +99,90 @@ status indicators."
9599
(let ((backend (ignore-errors (vc-responsible-backend default-directory)))
96100
(def-dir default-directory)
97101
(buffer (current-buffer))
102+
(state-to-type '( edited change
103+
added insert
104+
removed delete
105+
unregistered unknown
106+
ignored ignored))
98107
dirs-alist files-alist)
99108
(when (and backend (not (memq backend diff-hl-dired-ignored-backends)))
100-
(diff-hl-dired-clear)
101-
(if (buffer-live-p diff-hl-dired-process-buffer)
102-
(let ((proc (get-buffer-process diff-hl-dired-process-buffer)))
103-
(when proc (kill-process proc)))
104-
(setq diff-hl-dired-process-buffer
105-
(generate-new-buffer " *diff-hl-dired* tmp status")))
106-
(with-current-buffer diff-hl-dired-process-buffer
107-
(setq default-directory (expand-file-name def-dir))
108-
(erase-buffer)
109-
(diff-hl-dired-status-files
110-
backend def-dir
111-
(when diff-hl-dired-extra-indicators
112-
(cl-loop for file in (directory-files def-dir)
113-
unless (member file '("." ".." ".hg"))
114-
collect file))
115-
(lambda (entries &optional more-to-come)
116-
(when (buffer-live-p buffer)
117-
(with-current-buffer buffer
118-
(dolist (entry entries)
119-
(cl-destructuring-bind (file state &rest r) entry
120-
;; Work around http://debbugs.gnu.org/18605
121-
(setq file (replace-regexp-in-string "\\` " "" file))
122-
(let ((type (plist-get
123-
'( edited change added insert removed delete
124-
unregistered unknown ignored ignored)
125-
state)))
126-
(if (string-match "\\`\\([^/]+\\)/" file)
127-
(let* ((dir (match-string 1 file))
128-
(value (cdr (assoc dir dirs-alist))))
129-
(unless (eq value type)
130-
(cond
131-
((eq state 'up-to-date))
132-
((null value)
133-
(push (cons dir type) dirs-alist))
134-
((not (eq type 'ignored))
135-
(setcdr (assoc dir dirs-alist) 'change)))))
136-
(push (cons file type) files-alist)))))
137-
(unless more-to-come
138-
(diff-hl-dired-highlight-items
139-
(append dirs-alist files-alist))))
140-
(unless more-to-come
141-
(kill-buffer diff-hl-dired-process-buffer))))
142-
)))))
109+
;; queue update if VC process running
110+
;; pending flag debounces: N calls -> 1 retry
111+
;; e.g., open N subtrees while VC runs -> 1 retry after completion
112+
(if (and (buffer-live-p diff-hl-dired-process-buffer)
113+
(get-buffer-process diff-hl-dired-process-buffer)
114+
(process-live-p (get-buffer-process diff-hl-dired-process-buffer)))
115+
(setq diff-hl-dired--pending t) ;; queued, early return
116+
(setq diff-hl-dired--pending nil)
117+
(unless (buffer-live-p diff-hl-dired-process-buffer)
118+
(setq diff-hl-dired-process-buffer
119+
(generate-new-buffer " *diff-hl-dired* tmp status")))
120+
(with-current-buffer diff-hl-dired-process-buffer
121+
(setq default-directory (expand-file-name def-dir))
122+
(erase-buffer)
123+
(let ((files
124+
(when diff-hl-dired-extra-indicators
125+
(cl-loop for file in (directory-files def-dir)
126+
unless (member file '("." ".." ".hg"))
127+
collect file)))
128+
(update-fn
129+
(lambda (entries &optional more-to-come)
130+
(when (buffer-live-p buffer)
131+
(with-current-buffer buffer
132+
(dolist (entry entries)
133+
(cl-destructuring-bind (file state &rest r) entry
134+
;; Work around http://debbugs.gnu.org/18605
135+
(setq file (replace-regexp-in-string "\\` " "" file))
136+
(let ((type (plist-get state-to-type state))
137+
(dirs (cl-loop with pos = 0
138+
while (string-match "/" file pos)
139+
do (setq pos (match-end 0))
140+
collect (substring file 0 (1- pos)))))
141+
(dolist (dir dirs)
142+
(let ((value (cdr (assoc dir dirs-alist))))
143+
(cond
144+
((eq value type)) ;; skip
145+
((eq state 'up-to-date)) ;; skip
146+
((null value)
147+
(push (cons dir type) dirs-alist))
148+
((not (eq type 'ignored))
149+
(setcdr (assoc dir dirs-alist) 'change)))))
150+
(push (cons file type) files-alist)
151+
)))
152+
(unless more-to-come
153+
(diff-hl-dired-highlight-items
154+
(append dirs-alist files-alist))
155+
(when diff-hl-dired--pending
156+
(run-at-time 0 nil
157+
(lambda ()
158+
(when (buffer-live-p buffer)
159+
(with-current-buffer buffer
160+
(setq diff-hl-dired--pending nil)
161+
(diff-hl-dired-update))))))))
162+
(unless more-to-come
163+
(kill-buffer diff-hl-dired-process-buffer))))))
164+
(diff-hl-dired-status-files backend def-dir files update-fn)))
165+
))))
143166

144167
(defun diff-hl-dired-status-files (backend dir files update-function)
145168
"Using version control BACKEND, return list of (FILE STATE EXTRA) entries
146169
for DIR containing FILES. Call UPDATE-FUNCTION as entries are added."
147-
(vc-call-backend backend 'dir-status-files dir files update-function))
170+
(vc-call-backend backend 'dir-status-files
171+
dir files update-function))
148172

149173
(defun diff-hl-dired-highlight-items (alist)
150174
"Highlight ALIST containing (FILE . TYPE) elements."
175+
;; clear overlays right before drawing to avoid flicker
176+
(diff-hl-dired-clear)
151177
(dolist (pair alist)
152178
(let ((file (car pair))
153179
(type (cdr pair)))
154180
(save-excursion
155181
(goto-char (point-min))
156-
(when (and type (dired-goto-file-1
157-
file (expand-file-name file) nil))
182+
(when (and type
183+
(dired-goto-file-1
184+
(file-name-nondirectory file) ;; basename
185+
(expand-file-name file) nil))
158186
(let* ((diff-hl-fringe-bmp-function diff-hl-dired-fringe-bmp-function)
159187
(diff-hl-fringe-face-function 'diff-hl-dired-face-from-type)
160188
(o (diff-hl-add-highlighting type 'single)))

0 commit comments

Comments
 (0)