code.delx.au - gnu-emacs-elpa/blob - diff-hl.el

   1 ;;; diff-hl.el --- Highlight uncommitted changes -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2012-2015  Free Software Foundation, Inc.
   4
   5 ;; Author:   Dmitry Gutov <dgutov@yandex.ru>
   6 ;; URL:      https://github.com/dgutov/diff-hl
   7 ;; Keywords: vc, diff
   8 ;; Version:  1.7.1
   9 ;; Package-Requires: ((cl-lib "0.2"))
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;; `diff-hl-mode' highlights uncommitted changes on the side of the
  29 ;; window (using the fringe, by default), allows you to jump between
  30 ;; the hunks and revert them selectively.
  31
  32 ;; Provided commands:
  33 ;;
  34 ;; `diff-hl-diff-goto-hunk'  C-x v =
  35 ;; `diff-hl-revert-hunk'     C-x v n
  36 ;; `diff-hl-previous-hunk'   C-x v [
  37 ;; `diff-hl-next-hunk'       C-x v ]
  38 ;;
  39 ;; The mode takes advantage of `smartrep' if it is installed.
  40
  41 ;; Add either of the following to your init file.
  42 ;;
  43 ;; To use it in all buffers:
  44 ;;
  45 ;; (global-diff-hl-mode)
  46 ;;
  47 ;; Only in `prog-mode' buffers, with `vc-dir' integration:
  48 ;;
  49 ;; (add-hook 'prog-mode-hook 'turn-on-diff-hl-mode)
  50 ;; (add-hook 'vc-dir-mode-hook 'turn-on-diff-hl-mode)
  51
  52 ;;; Code:
  53
  54 (require 'fringe)
  55 (require 'diff-mode)
  56 (require 'vc)
  57 (require 'vc-dir)
  58 (eval-when-compile
  59   (require 'cl-lib)
  60   (require 'vc-git)
  61   (require 'vc-hg)
  62   (require 'face-remap)
  63   (declare-function smartrep-define-key 'smartrep))
  64
  65 (defgroup diff-hl nil
  66   "VC diff highlighting on the side of a window"
  67   :group 'vc)
  68
  69 (defface diff-hl-insert
  70   '((default :inherit diff-added)
  71     (((class color)) :foreground "green4"))
  72   "Face used to highlight inserted lines."
  73   :group 'diff-hl)
  74
  75 (defface diff-hl-delete
  76   '((default :inherit diff-removed)
  77     (((class color)) :foreground "red3"))
  78   "Face used to highlight deleted lines."
  79   :group 'diff-hl)
  80
  81 (defface diff-hl-change
  82   '((default :foreground "blue3")
  83     (((class color) (min-colors 88) (background light))
  84      :background "#ddddff")
  85     (((class color) (min-colors 88) (background dark))
  86      :background "#333355"))
  87   "Face used to highlight changed lines."
  88   :group 'diff-hl)
  89
  90 (defcustom diff-hl-command-prefix (kbd "C-x v")
  91   "The prefix for all `diff-hl' commands."
  92   :group 'diff-hl
  93   :type 'string)
  94
  95 (defcustom diff-hl-draw-borders t
  96   "Non-nil to draw borders around fringe indicators."
  97   :group 'diff-hl
  98   :type 'boolean)
  99
 100 (defcustom diff-hl-highlight-function 'diff-hl-highlight-on-fringe
 101   "Function to highlight the current line. Its arguments are
 102   overlay, change type and position within a hunk."
 103   :group 'diff-hl
 104   :type 'function)
 105
 106 (defcustom diff-hl-fringe-bmp-function 'diff-hl-fringe-bmp-from-pos
 107   "Function to choose the fringe bitmap for a given change type
 108   and position within a hunk.  Should accept two arguments."
 109   :group 'diff-hl
 110   :type '(choice (const diff-hl-fringe-bmp-from-pos)
 111                  (const diff-hl-fringe-bmp-from-type)
 112                  function))
 113
 114 (defcustom diff-hl-fringe-face-function 'diff-hl-fringe-face-from-type
 115   "Function to choose the fringe face for a given change type
 116   and position within a hunk.  Should accept two arguments."
 117   :group 'diff-hl
 118   :type 'function)
 119
 120 (defcustom diff-hl-side 'left
 121   "Which side to use for indicators."
 122   :type '(choice (const left)
 123                  (const right))
 124   :set (lambda (var value)
 125          (let ((on (bound-and-true-p global-diff-hl-mode)))
 126            (when on (global-diff-hl-mode -1))
 127            (set-default var value)
 128            (when on (global-diff-hl-mode 1)))))
 129
 130 (defvar diff-hl-reference-revision nil
 131   "Revision to diff against.  nil means the most recent one.")
 132
 133 (defun diff-hl-define-bitmaps ()
 134   (let* ((scale (if (and (boundp 'text-scale-mode-amount)
 135                          (numberp text-scale-mode-amount))
 136                     (expt text-scale-mode-step text-scale-mode-amount)
 137                   1))
 138          (spacing (or (and (display-graphic-p) (default-value 'line-spacing)) 0))
 139          (h (+ (ceiling (* (frame-char-height) scale))
 140                (if (floatp spacing)
 141                    (truncate (* (frame-char-height) spacing))
 142                  spacing)))
 143          (w (frame-parameter nil (intern (format "%s-fringe" diff-hl-side))))
 144          (middle (make-vector h (expt 2 (1- w))))
 145          (ones (1- (expt 2 w)))
 146          (top (copy-sequence middle))
 147          (bottom (copy-sequence middle))
 148          (single (copy-sequence middle)))
 149     (aset top 0 ones)
 150     (aset bottom (1- h) ones)
 151     (aset single 0 ones)
 152     (aset single (1- h) ones)
 153     (define-fringe-bitmap 'diff-hl-bmp-top top h w 'top)
 154     (define-fringe-bitmap 'diff-hl-bmp-middle middle h w 'center)
 155     (define-fringe-bitmap 'diff-hl-bmp-bottom bottom h w 'bottom)
 156     (define-fringe-bitmap 'diff-hl-bmp-single single h w 'top)
 157     (define-fringe-bitmap 'diff-hl-bmp-i [3 3 0 3 3 3 3 3 3 3] nil 2 'center)
 158     (let* ((w2 (* (/ w 2) 2))
 159            ;; When fringes are disabled, it's easier to fix up the width,
 160            ;; instead of doing nothing (#20).
 161            (w2 (if (zerop w2) 2 w2))
 162            (delete-row (- (expt 2 (1- w2)) 2))
 163            (middle-pos (1- (/ w2 2)))
 164            (middle-bit (expt 2 middle-pos))
 165            (insert-bmp (make-vector w2 (* 3 middle-bit))))
 166       (define-fringe-bitmap 'diff-hl-bmp-delete (make-vector 2 delete-row) w2 w2)
 167       (aset insert-bmp 0 0)
 168       (aset insert-bmp middle-pos delete-row)
 169       (aset insert-bmp (1+ middle-pos) delete-row)
 170       (aset insert-bmp (1- w2) 0)
 171       (define-fringe-bitmap 'diff-hl-bmp-insert insert-bmp w2 w2)
 172       )))
 173
 174 (defun diff-hl-maybe-define-bitmaps ()
 175   (when (window-system) ;; No fringes in the console.
 176     (unless (fringe-bitmap-p 'diff-hl-bmp-empty)
 177       (diff-hl-define-bitmaps)
 178       (define-fringe-bitmap 'diff-hl-bmp-empty [0] 1 1 'center))))
 179
 180 (defvar diff-hl-spec-cache (make-hash-table :test 'equal))
 181
 182 (defun diff-hl-fringe-spec (type pos side)
 183   (let* ((key (list type pos side
 184                     diff-hl-fringe-face-function
 185                     diff-hl-fringe-bmp-function))
 186          (val (gethash key diff-hl-spec-cache)))
 187     (unless val
 188       (let* ((face-sym (funcall diff-hl-fringe-face-function type pos))
 189              (bmp-sym (funcall diff-hl-fringe-bmp-function type pos)))
 190         (setq val (propertize " " 'display `((,(intern (format "%s-fringe" side))
 191                                               ,bmp-sym ,face-sym))))
 192         (puthash key val diff-hl-spec-cache)))
 193     val))
 194
 195 (defun diff-hl-fringe-face-from-type (type _pos)
 196   (intern (format "diff-hl-%s" type)))
 197
 198 (defun diff-hl-fringe-bmp-from-pos (_type pos)
 199   (intern (format "diff-hl-bmp-%s" pos)))
 200
 201 (defun diff-hl-fringe-bmp-from-type (type _pos)
 202   (cl-case type
 203     (unknown 'question-mark)
 204     (change 'exclamation-mark)
 205     (ignored 'diff-hl-bmp-i)
 206     (t (intern (format "diff-hl-bmp-%s" type)))))
 207
 208 (defvar vc-svn-diff-switches)
 209
 210 (defmacro diff-hl-with-diff-switches (body)
 211   `(let ((vc-git-diff-switches nil)
 212          (vc-hg-diff-switches nil)
 213          (vc-svn-diff-switches nil)
 214          (vc-diff-switches '("-U0"))
 215          (vc-disable-async-diff t))
 216      ,body))
 217
 218 (defun diff-hl-changes ()
 219   (let* ((file buffer-file-name)
 220          (backend (vc-backend file)))
 221     (when backend
 222       (let ((state (vc-state file backend)))
 223         (cond
 224          ((or (eq state 'edited)
 225               (and (eq state 'up-to-date)
 226                    ;; VC state is stale in after-revert-hook.
 227                    (or revert-buffer-in-progress-p
 228                        ;; Diffing against an older revision.
 229                        diff-hl-reference-revision)))
 230           (let* ((buf-name " *diff-hl* ")
 231                  diff-auto-refine-mode
 232                  res)
 233             (diff-hl-with-diff-switches
 234              (vc-call-backend backend 'diff (list file)
 235                               diff-hl-reference-revision nil
 236                               buf-name))
 237             (with-current-buffer buf-name
 238               (goto-char (point-min))
 239               (unless (eobp)
 240                 (ignore-errors
 241                   (diff-beginning-of-hunk t))
 242                 (while (looking-at diff-hunk-header-re-unified)
 243                   (let ((line (string-to-number (match-string 3)))
 244                         (len (let ((m (match-string 4)))
 245                                (if m (string-to-number m) 1)))
 246                         (beg (point)))
 247                     (diff-end-of-hunk)
 248                     (let* ((inserts (diff-count-matches "^\\+" beg (point)))
 249                            (deletes (diff-count-matches "^-" beg (point)))
 250                            (type (cond ((zerop deletes) 'insert)
 251                                        ((zerop inserts) 'delete)
 252                                        (t 'change))))
 253                       (when (eq type 'delete)
 254                         (setq len 1)
 255                         (cl-incf line))
 256                       (push (list line len type) res))))))
 257             (nreverse res)))
 258          ((eq state 'added)
 259           `((1 ,(line-number-at-pos (point-max)) insert)))
 260          ((eq state 'removed)
 261           `((1 ,(line-number-at-pos (point-max)) delete))))))))
 262
 263 (defun diff-hl-update ()
 264   (let ((changes (diff-hl-changes))
 265         (current-line 1))
 266     (diff-hl-remove-overlays)
 267     (save-excursion
 268       (save-restriction
 269         (widen)
 270         (goto-char (point-min))
 271         (dolist (c changes)
 272           (cl-destructuring-bind (line len type) c
 273             (forward-line (- line current-line))
 274             (setq current-line line)
 275             (let ((hunk-beg (point)))
 276               (while (cl-plusp len)
 277                 (diff-hl-add-highlighting
 278                   type
 279                  (cond
 280                   ((not diff-hl-draw-borders) 'empty)
 281                   ((and (= len 1) (= line current-line)) 'single)
 282                   ((= len 1) 'bottom)
 283                   ((= line current-line) 'top)
 284                   (t 'middle)))
 285                 (forward-line 1)
 286                 (cl-incf current-line)
 287                 (cl-decf len))
 288               (let ((h (make-overlay hunk-beg (point)))
 289                     (hook '(diff-hl-overlay-modified)))
 290                 (overlay-put h 'diff-hl t)
 291                 (overlay-put h 'diff-hl-hunk t)
 292                 (overlay-put h 'modification-hooks hook)
 293                 (overlay-put h 'insert-in-front-hooks hook)
 294                 (overlay-put h 'insert-behind-hooks hook)))))))))
 295
 296 (defun diff-hl-add-highlighting (type shape)
 297   (let ((o (make-overlay (point) (point))))
 298     (overlay-put o 'diff-hl t)
 299     (funcall diff-hl-highlight-function o type shape)
 300     o))
 301
 302 (defun diff-hl-highlight-on-fringe (ovl type shape)
 303   (overlay-put ovl 'before-string (diff-hl-fringe-spec type shape
 304                                                        diff-hl-side)))
 305
 306 (defun diff-hl-remove-overlays (&optional beg end)
 307   (save-restriction
 308     (widen)
 309     (dolist (o (overlays-in (or beg (point-min)) (or end (point-max))))
 310       (when (overlay-get o 'diff-hl) (delete-overlay o)))))
 311
 312 (defun diff-hl-overlay-modified (ov after-p _beg _end &optional _length)
 313   "Delete the hunk overlay and all our line overlays inside it."
 314   (unless after-p
 315     (when (overlay-buffer ov)
 316       (diff-hl-remove-overlays (overlay-start ov) (overlay-end ov))
 317       (delete-overlay ov))))
 318
 319 (defvar diff-hl-timer nil)
 320
 321 (defun diff-hl-edit (_beg _end _len)
 322   "DTRT when we've `undo'-ne the buffer into unmodified state."
 323   (when undo-in-progress
 324     (when diff-hl-timer
 325       (cancel-timer diff-hl-timer))
 326     (setq diff-hl-timer
 327           (run-with-idle-timer 0.01 nil #'diff-hl-after-undo (current-buffer)))))
 328
 329 (defun diff-hl-after-undo (buffer)
 330   (with-current-buffer buffer
 331     (unless (buffer-modified-p)
 332       (diff-hl-update))))
 333
 334 (defun diff-hl-diff-goto-hunk ()
 335   "Run VC diff command and go to the line corresponding to the current."
 336   (interactive)
 337   (vc-buffer-sync)
 338   (let* ((line (line-number-at-pos))
 339          (buffer (current-buffer)))
 340     (vc-diff-internal t (vc-deduce-fileset) diff-hl-reference-revision nil t)
 341     (vc-exec-after `(if (< (line-number-at-pos (point-max)) 3)
 342                         (with-current-buffer ,buffer (diff-hl-remove-overlays))
 343                       (diff-hl-diff-skip-to ,line)
 344                       (setq vc-sentinel-movepoint (point))))))
 345
 346 (defun diff-hl-diff-skip-to (line)
 347   "In `diff-mode', skip to the hunk and line corresponding to LINE
 348 in the source file, or the last line of the hunk above it."
 349   (diff-hunk-next)
 350   (let (found)
 351     (while (and (looking-at diff-hunk-header-re-unified) (not found))
 352       (let ((hunk-line (string-to-number (match-string 3)))
 353             (len (let ((m (match-string 4)))
 354                    (if m (string-to-number m) 1))))
 355         (if (> line (+ hunk-line len))
 356             (diff-hunk-next)
 357           (setq found t)
 358           (if (< line hunk-line)
 359               ;; Retreat to the previous hunk.
 360               (forward-line -1)
 361             (let ((to-go (1+ (- line hunk-line))))
 362               (while (cl-plusp to-go)
 363                 (forward-line 1)
 364                 (unless (looking-at "^-")
 365                   (cl-decf to-go))))))))))
 366
 367 (defun diff-hl-revert-hunk ()
 368   "Revert the diff hunk with changes at or above the point."
 369   (interactive)
 370   (vc-buffer-sync)
 371   (let ((diff-buffer (generate-new-buffer-name "*diff-hl*"))
 372         (buffer (current-buffer))
 373         (line (save-excursion
 374                 (unless (diff-hl-hunk-overlay-at (point))
 375                   (diff-hl-previous-hunk))
 376                 (line-number-at-pos)))
 377         (fileset (vc-deduce-fileset)))
 378     (unwind-protect
 379         (progn
 380           (vc-diff-internal nil fileset diff-hl-reference-revision nil
 381                             nil diff-buffer)
 382           (vc-exec-after
 383            `(let (beg-line end-line)
 384               (when (eobp)
 385                 (with-current-buffer ,buffer (diff-hl-remove-overlays))
 386                 (error "Buffer is up-to-date"))
 387               (diff-hl-diff-skip-to ,line)
 388               (save-excursion
 389                 (while (looking-at "[-+]") (forward-line 1))
 390                 (setq end-line (line-number-at-pos (point)))
 391                 (unless (eobp) (diff-split-hunk)))
 392               (unless (looking-at "[-+]") (forward-line -1))
 393               (while (looking-at "[-+]") (forward-line -1))
 394               (setq beg-line (line-number-at-pos (point)))
 395               (unless (looking-at "@")
 396                 (forward-line 1)
 397                 (diff-split-hunk))
 398               (let ((wbh (window-body-height)))
 399                 (if (>= wbh (- end-line beg-line))
 400                     (recenter (/ (+ wbh (- beg-line end-line) 2) 2))
 401                   (recenter 1)))
 402               (unless (yes-or-no-p (format "Revert current hunk in %s?"
 403                                            ,(cl-caadr fileset)))
 404                 (error "Revert canceled"))
 405               (let ((diff-advance-after-apply-hunk nil))
 406                 (diff-apply-hunk t))
 407               (with-current-buffer ,buffer
 408                 (save-buffer))
 409               (message "Hunk reverted"))))
 410       (quit-windows-on diff-buffer))))
 411
 412 (defun diff-hl-hunk-overlay-at (pos)
 413   (cl-loop for o in (overlays-in pos (1+ pos))
 414            when (overlay-get o 'diff-hl-hunk)
 415            return o))
 416
 417 (defun diff-hl-next-hunk (&optional backward)
 418   "Go to the beginning of the next hunk in the current buffer."
 419   (interactive)
 420   (let ((pos (save-excursion
 421                (catch 'found
 422                  (while (not (if backward (bobp) (eobp)))
 423                    (goto-char (if backward
 424                                   (previous-overlay-change (point))
 425                                 (next-overlay-change (point))))
 426                    (let ((o (diff-hl-hunk-overlay-at (point))))
 427                      (when (and o (= (overlay-start o) (point)))
 428                        (throw 'found (overlay-start o)))))))))
 429     (if pos
 430         (goto-char pos)
 431       (error "No further hunks found"))))
 432
 433 (defun diff-hl-previous-hunk ()
 434   "Go to the beginning of the previous hunk in the current buffer."
 435   (interactive)
 436   (diff-hl-next-hunk t))
 437
 438 (define-prefix-command 'diff-hl-command-map)
 439
 440 (let ((map diff-hl-command-map))
 441   (define-key map "n" 'diff-hl-revert-hunk)
 442   (define-key map "[" 'diff-hl-previous-hunk)
 443   (define-key map "]" 'diff-hl-next-hunk)
 444   map)
 445
 446 ;;;###autoload
 447 (define-minor-mode diff-hl-mode
 448   "Toggle VC diff highlighting."
 449   :lighter "" :keymap `(([remap vc-diff] . diff-hl-diff-goto-hunk)
 450                         (,diff-hl-command-prefix . diff-hl-command-map))
 451   (if diff-hl-mode
 452       (progn
 453         (diff-hl-maybe-define-bitmaps)
 454         (add-hook 'after-save-hook 'diff-hl-update nil t)
 455         (add-hook 'after-change-functions 'diff-hl-edit nil t)
 456         (add-hook (if vc-mode
 457                       ;; Defer until the end of this hook, so that its
 458                       ;; elements can modify the update behavior.
 459                       'diff-hl-mode-on-hook
 460                     ;; If we're only opening the file now,
 461                     ;; `vc-find-file-hook' likely hasn't run yet, so
 462                     ;; let's wait until the state information is
 463                     ;; saved, in order not to fetch it twice.
 464                     'find-file-hook)
 465                   'diff-hl-update t t)
 466         (add-hook 'vc-checkin-hook 'diff-hl-update nil t)
 467         (add-hook 'after-revert-hook 'diff-hl-update nil t)
 468         ;; Magit does call `auto-revert-handler', but it usually
 469         ;; doesn't do much, because `buffer-stale--default-function'
 470         ;; doesn't care about changed VC state.
 471         ;; https://github.com/magit/magit/issues/603
 472         (add-hook 'magit-revert-buffer-hook 'diff-hl-update nil t)
 473         ;; Magit 2+ doesn't do the above and calls this instead,
 474         ;; but only when it doesn't call `revert-buffer':
 475         (add-hook 'magit-not-reverted-hook 'diff-hl-update nil t)
 476         (add-hook 'auto-revert-mode-hook 'diff-hl-update nil t)
 477         (add-hook 'text-scale-mode-hook 'diff-hl-define-bitmaps nil t))
 478     (remove-hook 'after-save-hook 'diff-hl-update t)
 479     (remove-hook 'after-change-functions 'diff-hl-edit t)
 480     (remove-hook 'find-file-hook 'diff-hl-update t)
 481     (remove-hook 'vc-checkin-hook 'diff-hl-update t)
 482     (remove-hook 'after-revert-hook 'diff-hl-update t)
 483     (remove-hook 'magit-revert-buffer-hook 'diff-hl-update t)
 484     (remove-hook 'magit-not-reverted-hook 'diff-hl-update t)
 485     (remove-hook 'auto-revert-mode-hook 'diff-hl-update t)
 486     (remove-hook 'text-scale-mode-hook 'diff-hl-define-bitmaps t)
 487     (diff-hl-remove-overlays)))
 488
 489 (when (require 'smartrep nil t)
 490   (let (smart-keys)
 491     (cl-labels ((scan (map)
 492                       (map-keymap
 493                        (lambda (event binding)
 494                          (if (consp binding)
 495                              (scan binding)
 496                            (when (characterp event)
 497                              (push (cons (string event) binding) smart-keys))))
 498                        map)))
 499       (scan diff-hl-command-map)
 500       (smartrep-define-key diff-hl-mode-map diff-hl-command-prefix smart-keys))))
 501
 502 (defun diff-hl-dir-update ()
 503   (dolist (pair (if (vc-dir-marked-files)
 504                     (vc-dir-marked-only-files-and-states)
 505                   (vc-dir-child-files-and-states)))
 506     (when (eq 'up-to-date (cdr pair))
 507       (let ((buffer (find-buffer-visiting (car pair))))
 508         (when buffer
 509           (with-current-buffer buffer
 510             (diff-hl-remove-overlays)))))))
 511
 512 (define-minor-mode diff-hl-dir-mode
 513   "Toggle `diff-hl-mode' integration in a `vc-dir-mode' buffer."
 514   :lighter ""
 515   (if diff-hl-dir-mode
 516       (add-hook 'vc-checkin-hook 'diff-hl-dir-update t t)
 517     (remove-hook 'vc-checkin-hook 'diff-hl-dir-update t)))
 518
 519 ;;;###autoload
 520 (defun turn-on-diff-hl-mode ()
 521   "Turn on `diff-hl-mode' or `diff-hl-dir-mode' in a buffer if appropriate."
 522   (cond
 523    (buffer-file-name
 524     (diff-hl-mode 1))
 525    ((eq major-mode 'vc-dir-mode)
 526     (diff-hl-dir-mode 1))))
 527
 528 ;;;###autoload
 529 (define-globalized-minor-mode global-diff-hl-mode diff-hl-mode
 530   turn-on-diff-hl-mode :after-hook (diff-hl-global-mode-change))
 531
 532 (defun diff-hl-global-mode-change ()
 533   (unless global-diff-hl-mode
 534     (dolist (buf (buffer-list))
 535       (with-current-buffer buf
 536         (when diff-hl-dir-mode
 537           (diff-hl-dir-mode -1))))))
 538
 539 (provide 'diff-hl)
 540
 541 ;;; diff-hl.el ends here