241 lines
8.9 KiB
EmacsLisp
241 lines
8.9 KiB
EmacsLisp
;;; diff-hl-dired.el --- Highlight changed files in Dired -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2012-2017, 2023-2026 Free Software Foundation, Inc.
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs 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.
|
|
|
|
;; GNU Emacs 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 GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; To enable in all Dired buffers, add this to your init file:
|
|
;;
|
|
;; (add-hook 'dired-mode-hook 'diff-hl-dired-mode)
|
|
;;
|
|
;; or
|
|
;;
|
|
;; (add-hook 'dired-mode-hook 'diff-hl-dired-mode-unless-remote)
|
|
;;
|
|
;; to do it only in local Dired buffers.
|
|
|
|
;;; Code:
|
|
|
|
(require 'diff-hl)
|
|
(require 'dired)
|
|
(require 'vc-hooks)
|
|
|
|
(defvar diff-hl-dired-process-buffer nil)
|
|
|
|
(defgroup diff-hl-dired nil
|
|
"VC diff highlighting on the side of a Dired window."
|
|
:group 'diff-hl)
|
|
|
|
(defface diff-hl-dired-insert
|
|
'((default :inherit diff-hl-insert))
|
|
"Face used to highlight added files.")
|
|
|
|
(defface diff-hl-dired-delete
|
|
'((default :inherit diff-hl-delete))
|
|
"Face used to highlight directories with deleted files.")
|
|
|
|
(defface diff-hl-dired-change
|
|
'((default :inherit diff-hl-change))
|
|
"Face used to highlight changed files.")
|
|
|
|
(defface diff-hl-dired-unknown
|
|
'((default :inherit dired-ignored))
|
|
"Face used to highlight unregistered files.")
|
|
|
|
(defface diff-hl-dired-ignored
|
|
'((default :inherit dired-ignored))
|
|
"Face used to highlight unregistered files.")
|
|
|
|
(defcustom diff-hl-dired-extra-indicators t
|
|
"Non-nil to indicate ignored files."
|
|
:type 'boolean)
|
|
|
|
(defcustom diff-hl-dired-ignored-backends '(RCS)
|
|
"VC backends to ignore.
|
|
The directories registered to one of these backends won't have
|
|
status indicators."
|
|
:type `(repeat (choice ,@(mapcar
|
|
(lambda (name)
|
|
`(const :tag ,(symbol-name name) ,name))
|
|
vc-handled-backends))))
|
|
|
|
(defcustom diff-hl-dired-fringe-bmp-function 'diff-hl-fringe-bmp-from-type
|
|
"Function to determine fringe bitmap from change type and position."
|
|
:type 'function)
|
|
|
|
;;;###autoload
|
|
(define-minor-mode diff-hl-dired-mode
|
|
"Toggle VC diff highlighting on the side of a Dired window."
|
|
:lighter ""
|
|
(if diff-hl-dired-mode
|
|
(progn
|
|
(diff-hl-maybe-define-bitmaps)
|
|
(set (make-local-variable 'diff-hl-dired-process-buffer) nil)
|
|
(add-hook 'dired-after-readin-hook 'diff-hl-dired-update 10 t))
|
|
(remove-hook 'dired-after-readin-hook 'diff-hl-dired-update t)
|
|
(diff-hl-dired-clear)))
|
|
|
|
(defun diff-hl-dired-update ()
|
|
"Highlight the Dired buffer."
|
|
(let ((backend (ignore-errors (vc-responsible-backend default-directory)))
|
|
(def-dir default-directory)
|
|
(buffer (current-buffer))
|
|
dirs-alist files-alist)
|
|
(when (and backend (not (memq backend diff-hl-dired-ignored-backends)))
|
|
(if (buffer-live-p diff-hl-dired-process-buffer)
|
|
(let ((proc (get-buffer-process diff-hl-dired-process-buffer)))
|
|
(when proc (kill-process proc)))
|
|
(setq diff-hl-dired-process-buffer
|
|
(generate-new-buffer " *diff-hl-dired* tmp status")))
|
|
(with-current-buffer diff-hl-dired-process-buffer
|
|
(setq default-directory (expand-file-name def-dir))
|
|
(erase-buffer)
|
|
(diff-hl-dired-status-files
|
|
backend def-dir
|
|
(when diff-hl-dired-extra-indicators
|
|
(with-current-buffer buffer
|
|
(diff-hl-dired-nondirectory-files)))
|
|
(lambda (entries &optional more-to-come)
|
|
(when (buffer-live-p buffer)
|
|
(with-current-buffer buffer
|
|
(dolist (entry entries)
|
|
(cl-destructuring-bind (file state &rest r) entry
|
|
(unless (eq state 'up-to-date)
|
|
(let ((type (plist-get '( edited change added insert removed delete
|
|
unregistered unknown ignored ignored)
|
|
state))
|
|
(dirs (cl-loop with pos = 0
|
|
while (string-match "/" file pos)
|
|
do (setq pos (match-end 0))
|
|
collect (substring file 0 (1- pos)))))
|
|
(dolist (dir dirs)
|
|
(let ((value (cdr (assoc dir dirs-alist))))
|
|
(unless (eq value type)
|
|
(cond
|
|
((null value)
|
|
(push (cons dir type) dirs-alist))
|
|
((not (eq type 'ignored))
|
|
(setcdr (assoc dir dirs-alist) 'change))))))
|
|
(push (cons file type) files-alist)))))
|
|
(unless more-to-come
|
|
(diff-hl-dired-highlight-items
|
|
(append dirs-alist files-alist))))
|
|
(unless more-to-come
|
|
(kill-buffer diff-hl-dired-process-buffer))))
|
|
)))))
|
|
|
|
(defun diff-hl-dired-status-files (backend dir files update-function)
|
|
"Using VC BACKEND, fetch list of (FILE STATE EXTRA) entries for DIR.
|
|
Call UPDATE-FUNCTION as entries are added."
|
|
(vc-call-backend
|
|
backend 'dir-status-files
|
|
dir nil
|
|
(lambda (entries &optional more-to-come)
|
|
(if (or more-to-come
|
|
(not diff-hl-dired-extra-indicators))
|
|
(funcall update-function entries more-to-come)
|
|
(diff-hl-dir-status-ignored-files
|
|
backend
|
|
dir
|
|
files
|
|
(lambda (ignored-entries &optional more-to-come)
|
|
(funcall update-function ignored-entries t)
|
|
(unless more-to-come
|
|
(funcall update-function entries nil))))
|
|
))))
|
|
|
|
(defun diff-hl-dired-nondirectory-files ()
|
|
(cl-mapcan
|
|
(lambda (entry)
|
|
(let* ((dir (file-relative-name (car entry)))
|
|
(all (file-name-all-completions "" dir))
|
|
res)
|
|
(dolist (file all)
|
|
(unless (directory-name-p file)
|
|
(push
|
|
(if (equal dir "./")
|
|
file
|
|
(concat dir file))
|
|
res)))
|
|
res))
|
|
dired-subdir-alist))
|
|
|
|
(declare-function vc-git-dir-status-goto-stage "vc-git")
|
|
(declare-function make-vc-git-dir-status-state "vc-git")
|
|
(declare-function vc-hg-command "vc-hg")
|
|
(declare-function vc-hg--program-version "vc-hg")
|
|
(declare-function vc-hg-after-dir-status "vc-hg")
|
|
|
|
(defun diff-hl-dir-status-ignored-files (backend dir files update-function)
|
|
(cond
|
|
((eq backend 'Git)
|
|
(vc-git-dir-status-goto-stage
|
|
(make-vc-git-dir-status-state :stage 'ls-files-ignored
|
|
:files files
|
|
:update-function update-function)))
|
|
((eq backend 'Hg)
|
|
(let ((default-directory dir))
|
|
(erase-buffer)
|
|
(apply #'vc-hg-command (current-buffer) 'async files
|
|
"status" "-i"
|
|
(if (version<= "4.2" (vc-hg--program-version))
|
|
'("--config" "commands.status.relative=1")
|
|
'("re:" "-I" "."))))
|
|
(static-if (fboundp 'vc-run-delayed-success)
|
|
(vc-run-delayed-success 0
|
|
(vc-hg-after-dir-status update-function))
|
|
(vc-run-delayed
|
|
(vc-hg-after-dir-status update-function))))
|
|
;; No specialized solution for "list only ignored state", list all.
|
|
;; If the backend doesn't use several process calls (like Git), the
|
|
;; difference should be trivial.
|
|
(t
|
|
(vc-call-backend backend 'dir-status-files dir files
|
|
update-function))))
|
|
|
|
(defun diff-hl-dired-highlight-items (alist)
|
|
"Highlight ALIST containing (FILE . TYPE) elements."
|
|
(diff-hl-dired-clear) ;; clear overlays right before drawing to avoid flicker
|
|
(dolist (pair alist)
|
|
(let ((file (car pair))
|
|
(type (cdr pair)))
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(when (and type (dired-goto-file-1
|
|
(file-name-nondirectory file) (expand-file-name file) nil))
|
|
(let* ((diff-hl-fringe-bmp-function diff-hl-dired-fringe-bmp-function)
|
|
(diff-hl-fringe-face-function 'diff-hl-dired-face-from-type)
|
|
(o (diff-hl-add-highlighting type 'single)))
|
|
(overlay-put o 'modification-hooks '(diff-hl-overlay-modified))
|
|
(overlay-put o 'diff-hl-dired-type type)
|
|
))))))
|
|
|
|
(defun diff-hl-dired-face-from-type (type _pos)
|
|
(intern (format "diff-hl-dired-%s" type)))
|
|
|
|
(defalias 'diff-hl-dired-clear 'diff-hl-remove-overlays)
|
|
|
|
;;;###autoload
|
|
(defun diff-hl-dired-mode-unless-remote ()
|
|
(unless (file-remote-p default-directory)
|
|
(diff-hl-dired-mode)))
|
|
|
|
(provide 'diff-hl-dired)
|
|
|
|
;;; diff-hl-dired.el ends here
|