mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-18 434b46beff1c5ec01cbefd5273d89971a82d6bab
commit | author | age
5cb5f7 1 ;;; diff-hl-dired.el --- Highlight changed files in Dired -*- lexical-binding: t -*-
C 2
3 ;; Copyright (C) 2012-2017  Free Software Foundation, Inc.
4
5 ;; This file is part of GNU Emacs.
6
7 ;; GNU Emacs is free software: you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation, either version 3 of the License, or
10 ;; (at your option) any later version.
11
12 ;; GNU Emacs is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 ;; GNU General Public License for more details.
16
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
19
20 ;;; Commentary:
21
22 ;; To enable in all Dired buffers, add this to your init file:
23 ;;
24 ;; (add-hook 'dired-mode-hook 'diff-hl-dired-mode)
25 ;;
26 ;; or
27 ;;
28 ;; (add-hook 'dired-mode-hook 'diff-hl-dired-mode-unless-remote)
29 ;;
30 ;; to do it only in local Dired buffers.
31
32 ;;; Code:
33
34 (require 'diff-hl)
35 (require 'dired)
36 (require 'vc-hooks)
37
38 (defvar diff-hl-dired-process-buffer nil)
39
40 (defgroup diff-hl-dired nil
41   "VC diff highlighting on the side of a Dired window."
42   :group 'diff-hl)
43
44 (defface diff-hl-dired-insert
45   '((default :inherit diff-hl-insert))
46   "Face used to highlight added files.")
47
48 (defface diff-hl-dired-delete
49   '((default :inherit diff-hl-delete))
50   "Face used to highlight directories with deleted files.")
51
52 (defface diff-hl-dired-change
53   '((default :inherit diff-hl-change))
54   "Face used to highlight changed files.")
55
56 (defface diff-hl-dired-unknown
57   '((default :inherit dired-ignored))
58   "Face used to highlight unregistered files.")
59
60 (defface diff-hl-dired-ignored
61   '((default :inherit dired-ignored))
62   "Face used to highlight unregistered files.")
63
64 (defcustom diff-hl-dired-extra-indicators t
65   "Non-nil to indicate ignored files."
66   :type 'boolean)
67
68 (defcustom diff-hl-dired-ignored-backends '(RCS)
69   "VC backends to ignore.
70 The directories registered to one of these backends won't have
71 status indicators."
72   :type `(repeat (choice ,@(mapcar
73                             (lambda (name)
74                               `(const :tag ,(symbol-name name) ,name))
75                             vc-handled-backends))))
76
77 ;;;###autoload
78 (define-minor-mode diff-hl-dired-mode
79   "Toggle VC diff highlighting on the side of a Dired window."
80   :lighter ""
81   (if diff-hl-dired-mode
82       (progn
83         (diff-hl-maybe-define-bitmaps)
84         (set (make-local-variable 'diff-hl-dired-process-buffer) nil)
85         (add-hook 'dired-after-readin-hook 'diff-hl-dired-update nil t))
86     (remove-hook 'dired-after-readin-hook 'diff-hl-dired-update t)
87     (diff-hl-dired-clear)))
88
89 (defun diff-hl-dired-update ()
90   "Highlight the Dired buffer."
91   (let ((backend (ignore-errors (vc-responsible-backend default-directory)))
92         (def-dir default-directory)
93         (buffer (current-buffer))
94         dirs-alist files-alist)
95     (when (and backend (not (memq backend diff-hl-dired-ignored-backends)))
96       (diff-hl-dired-clear)
97       (if (buffer-live-p diff-hl-dired-process-buffer)
98           (let ((proc (get-buffer-process diff-hl-dired-process-buffer)))
99             (when proc (kill-process proc)))
100         (setq diff-hl-dired-process-buffer
101               (generate-new-buffer " *diff-hl-dired* tmp status")))
102       (with-current-buffer diff-hl-dired-process-buffer
103         (setq default-directory (expand-file-name def-dir))
104         (erase-buffer)
105         (diff-hl-dired-status-files
106          backend def-dir
107          (when diff-hl-dired-extra-indicators
108            (cl-loop for file in (directory-files def-dir)
109                     unless (member file '("." ".." ".hg"))
110                     collect file))
111          (lambda (entries &optional more-to-come)
112            (when (buffer-live-p buffer)
113              (with-current-buffer buffer
114                (dolist (entry entries)
115                  (cl-destructuring-bind (file state &rest r) entry
116                    ;; Work around http://debbugs.gnu.org/18605
117                    (setq file (replace-regexp-in-string "\\` " "" file))
118                    (let ((type (plist-get
119                                 '(edited change added insert removed delete
120                                   unregistered unknown ignored ignored)
121                                 state)))
122                      (if (string-match "\\`\\([^/]+\\)/" file)
123                          (let* ((dir (match-string 1 file))
124                                 (value (cdr (assoc dir dirs-alist))))
125                            (unless (eq value type)
126                              (cond
127                               ((eq state 'up-to-date))
128                               ((null value)
129                                (push (cons dir type) dirs-alist))
130                               ((not (eq type 'ignored))
131                                (setcdr (assoc dir dirs-alist) 'change)))))
132                        (push (cons file type) files-alist)))))
133                (unless more-to-come
134                  (diff-hl-dired-highlight-items
135                   (append dirs-alist files-alist))))
136              (unless more-to-come
137                (kill-buffer diff-hl-dired-process-buffer))))
138          )))))
139
140 (defun diff-hl-dired-status-files (backend dir files update-function)
141    "Using version control BACKEND, return list of (FILE STATE EXTRA) entries
142 for DIR containing FILES. Call UPDATE-FUNCTION as entries are added."
143   (if (version< "25" emacs-version)
144       (vc-call-backend backend 'dir-status-files dir files update-function)
145     (vc-call-backend backend 'dir-status-files dir files nil update-function)))
146
147 (when (version< emacs-version "24.4.51.5")
148   ;; Work around http://debbugs.gnu.org/19386
149   (defadvice vc-git-dir-status-goto-stage (around
150                                             diff-hl-dired-skip-up-to-date
151                                             (stage files update-function)
152                                             activate)
153     (when (eq stage 'ls-files-up-to-date)
154       (setq stage 'diff-index))
155     ad-do-it))
156
157 (defun diff-hl-dired-highlight-items (alist)
158   "Highlight ALIST containing (FILE . TYPE) elements."
159   (dolist (pair alist)
160     (let ((file (car pair))
161           (type (cdr pair)))
162       (save-excursion
163         (goto-char (point-min))
164         (when (and type (dired-goto-file-1
165                          file (expand-file-name file) nil))
166           (let* ((diff-hl-fringe-bmp-function 'diff-hl-fringe-bmp-from-type)
167                  (diff-hl-fringe-face-function 'diff-hl-dired-face-from-type)
168                  (o (diff-hl-add-highlighting type 'single)))
169             (overlay-put o 'modification-hooks '(diff-hl-overlay-modified))
170             ))))))
171
172 (defun diff-hl-dired-face-from-type (type _pos)
173   (intern (format "diff-hl-dired-%s" type)))
174
175 (defalias 'diff-hl-dired-clear 'diff-hl-remove-overlays)
176
177 ;;;###autoload
178 (defun diff-hl-dired-mode-unless-remote ()
179   (unless (file-remote-p default-directory)
180     (diff-hl-dired-mode)))
181
182 (provide 'diff-hl-dired)
183
184 ;;; diff-hl-dired.el ends here