consult-vc.el (12992B)
1 ;;; consult-vc.el --- Consult commands for VC -*- lexical-binding: t -*- 2 3 ;;; Commentary: 4 5 ;; This package provides Consult commands enhancing `vc-annotate'. 6 ;; 7 ;; Use `consult-vc-annotate-revision' to select a revision of the file 8 ;; in the current annotate buffer and warp the buffer to the selected 9 ;; revision with `vc-annotate-warp-revision'. A suggested binding is: 10 ;; 11 ;; (keymap-set vc-annotate-mode-map "r" #'consult-vc-annotate-revision) 12 ;; 13 ;; Candidates are annotated with the commit author and date and can be 14 ;; narrowed by author. Additionally the narrowing keys 15 ;; `consult-vc-annotate-revision-narrow-key-forward' and 16 ;; `consult-vc-annotate-revision-narrow-key-backward' select the 17 ;; commits newer and older than the currently annotated revision. 18 ;; 19 ;; For Git backends the full history of the annotated file is offered. 20 ;; For other backends only the revisions visible in the annotate 21 ;; buffer are offered, without commit metadata. 22 23 ;;; Code: 24 25 (require 'consult) 26 (require 'vc-annotate) 27 (require 'cl-lib) 28 29 (declare-function vc-git--out-ok "vc-git") 30 31 (defgroup consult-vc nil 32 "Consult commands for VC." 33 :group 'consult 34 :prefix "consult-vc-") 35 36 (defcustom consult-vc-annotate-revision-narrow-key-forward ?> 37 "Narrowing key for commits newer than the annotated revision." 38 :type 'character) 39 40 (defcustom consult-vc-annotate-revision-narrow-key-backward ?< 41 "Narrowing key for commits older than the annotated revision." 42 :type 'character) 43 44 (defcustom consult-vc-annotate-revision-max-width 80 45 "Maximum display width of the candidates of `consult-vc-annotate-revision'. 46 Set to nil to disable truncation." 47 :type '(choice natnum (const nil))) 48 49 (defvar consult-vc--annotate-revision-history nil 50 "History for `consult-vc-annotate-revision'.") 51 52 (defun consult-vc--annotate-revisions () 53 "Collect the revisions occurring in the current `vc-annotate-mode' buffer. 54 Return the revisions in order of first appearance. This is used for 55 non-Git backends, see `consult-vc--annotate-revision-items-fallback'." 56 (save-excursion 57 (save-restriction 58 (widen) 59 (goto-char (point-min)) 60 (let (revs) 61 (while (not (eobp)) 62 (when-let* ((rev (car (vc-annotate-extract-revision-at-line)))) 63 (cl-pushnew rev revs :test #'equal)) 64 (forward-line 1)) 65 (nreverse revs))))) 66 67 (defun consult-vc--git-file-revisions (file) 68 "Return the revisions touching FILE as a list of (FULL SHORT), oldest first." 69 (with-temp-buffer 70 (unless (vc-git--out-ok "log" "--follow" "--format=%H%x09%h" "--" file) 71 (user-error "Cannot get log for %s" file)) 72 (goto-char (point-min)) 73 (nreverse 74 (cl-loop while (re-search-forward "^\\([0-9a-f]+\\)\t\\([0-9a-f]+\\)$" nil t) 75 collect (list (match-string 1) (match-string 2)))))) 76 77 (defun consult-vc--git-revision-info (revs) 78 "Return a hash table mapping each revision of REVS to (DATE AUTHOR SUBJECT). 79 REVS is a list of full Git commit hashes. The metadata is fetched in a 80 single `git log' call; revisions missing from the batch result are 81 fetched individually. Failures are ignored and the corresponding 82 entries are absent from the table." 83 (let (entries) 84 (with-temp-buffer 85 (when (apply #'vc-git--out-ok "log" "--no-walk" "--date=short" 86 "--format=%H%x09%ad%x09%an%x09%s" revs) 87 (goto-char (point-min)) 88 (while (re-search-forward 89 "^\\([0-9a-f]+\\)\t\\([^\t]*\\)\t\\([^\t]*\\)\t\\(.*\\)$" nil t) 90 (push (list (match-string 1) (match-string 2) 91 (match-string 3) (match-string 4)) 92 entries)))) 93 (let ((result (make-hash-table :test #'equal))) 94 ;; Map each rev to its info, matching against the full hashes 95 ;; returned by `git log' by prefix, such that abbreviated 96 ;; revisions are also supported. 97 (dolist (rev revs) 98 (when-let* ((entry (cl-find rev entries :key #'car 99 :test #'string-prefix-p))) 100 (puthash rev (cdr entry) result))) 101 ;; Fallback for revisions missing from the batch result: fetch 102 ;; them one by one, ignoring failures. 103 (dolist (rev revs) 104 (unless (gethash rev result) 105 (with-temp-buffer 106 (when (vc-git--out-ok "show" "--no-patch" "--date=short" 107 "--format=%ad%x09%an%x09%s" rev) 108 (goto-char (point-min)) 109 (when (re-search-forward "^\\([^\t]*\\)\t\\([^\t]*\\)\t\\(.*\\)$" nil t) 110 (puthash rev (list (match-string 1) (match-string 2) 111 (match-string 3)) 112 result)))))) 113 result))) 114 115 (defun consult-vc--git-annotate-revision-items (file) 116 "Return revision items for FILE. 117 118 An item is a list (REV SHORT DATE AUTHOR SUBJECT IDX). REV is the full 119 revision used for warping, SHORT the abbreviated revision used for 120 display, DATE the commit date as a zero-padded ISO string, AUTHOR and 121 SUBJECT the commit metadata and IDX the position in the chronologically 122 sorted item list. 123 124 The items are sorted by commit date, oldest revision first." 125 (pcase-let* ((default-directory (file-name-directory file)) 126 (revs (consult-vc--git-file-revisions file)) 127 (info (consult-vc--git-revision-info (mapcar #'car revs))) 128 (items (sort 129 (cl-loop for (full short) in revs 130 for (date author subject) = (gethash full info) 131 collect (list full short date author subject nil)) 132 (lambda (a b) (string< (or (nth 2 a) "") 133 (or (nth 2 b) "")))))) 134 (cl-loop for item in items 135 for idx from 0 136 do (setf (nth 5 item) idx)) 137 items)) 138 139 (defun consult-vc--annotate-revision-items-fallback () 140 "Return revision items extracted from the annotate buffer. 141 This is used for non-Git backends without full history information." 142 (cl-loop for rev in (consult-vc--annotate-revisions) 143 for idx from 0 144 collect (list rev rev nil nil nil idx))) 145 146 (defun consult-vc--annotate-revision-candidates (items) 147 "Return candidate strings for revision ITEMS. 148 Each candidate is propertized with `consult-vc-rev', 149 `consult-vc-author', `consult-vc-date' and `consult-vc-idx'. The 150 visible part is truncated to `consult-vc-annotate-revision-max-width'." 151 (mapcar 152 (pcase-lambda (`(,rev ,short ,date ,author ,subject ,idx)) 153 (let ((visible (concat (propertize short 'face 'consult-key) 154 (and subject " ") (or subject "")))) 155 (propertize 156 (concat 157 (if (and consult-vc-annotate-revision-max-width 158 (> (consult--display-width visible) 159 consult-vc-annotate-revision-max-width)) 160 (truncate-string-to-width 161 visible consult-vc-annotate-revision-max-width nil nil "…") 162 visible) 163 (and (or date author subject) 164 (propertize (concat "\t" (or date "") " " (or author "") 165 " " (or subject "")) 166 'invisible t))) 167 'consult-vc-rev rev 168 'consult-vc-author author 169 'consult-vc-date date 170 'consult-vc-idx idx))) 171 items)) 172 173 (defun consult-vc--annotate-revision-annotate (cand) 174 "Annotate revision candidate CAND with author and date." 175 (consult--annotate-align 176 cand 177 (let ((author (get-text-property 0 'consult-vc-author cand)) 178 (date (get-text-property 0 'consult-vc-date cand))) 179 (concat 180 (and author (propertize author 'face 'completions-annotations)) 181 (and author date " ") 182 (and date (propertize date 'face 'completions-annotations)))))) 183 184 (defun consult-vc--annotate-revision-narrow (candidates anchor-idx) 185 "Return narrowing configuration for revision CANDIDATES. 186 ANCHOR-IDX is the index of the annotated revision, see `consult-vc-idx'. 187 Authors are assigned keys in order of their number of commits in the 188 history of the annotated file. If ANCHOR-IDX is non-nil, two additional 189 narrowing keys select the commits newer and older than the annotated 190 revision, see `consult-vc-annotate-revision-narrow-key-forward' and 191 `consult-vc-annotate-revision-narrow-key-backward'." 192 (let ((counts (make-hash-table :test #'equal))) 193 (dolist (cand candidates) 194 (when-let* ((author (get-text-property 0 'consult-vc-author cand))) 195 (cl-incf (gethash author counts 0)))) 196 (let* ((authors nil) 197 (authors-alist 198 (progn 199 (maphash (lambda (author n) (push (cons author n) authors)) counts) 200 (cl-loop for (author . _) 201 in (sort authors 202 (lambda (a b) 203 (or (> (cdr a) (cdr b)) 204 (and (= (cdr a) (cdr b)) 205 (string< (car a) (car b)))))) 206 for i across "123456789abcdefghijklmnopqrstuvwxyz" 207 collect (cons i author))))) 208 (list :keys (append (mapcar (lambda (x) (cons (car x) (cdr x))) authors-alist) 209 (and anchor-idx 210 (list (cons consult-vc-annotate-revision-narrow-key-forward "Newer") 211 (cons consult-vc-annotate-revision-narrow-key-backward "Older")))) 212 :predicate 213 (lambda (cand) 214 (let ((key consult--narrow)) 215 (cond ((cdr (assq key authors-alist)) 216 (equal (get-text-property 0 'consult-vc-author cand) 217 (cdr (assq key authors-alist)))) 218 ((eq key consult-vc-annotate-revision-narrow-key-forward) 219 (> (get-text-property 0 'consult-vc-idx cand) anchor-idx)) 220 ((eq key consult-vc-annotate-revision-narrow-key-backward) 221 (< (get-text-property 0 'consult-vc-idx cand) anchor-idx))))))))) 222 223 ;;;; Commands 224 225 ;;;###autoload 226 (defun consult-vc-annotate-revision () 227 "Select a revision of the file in the current `vc-annotate-mode' buffer. 228 229 The annotate buffer is warped to the selected revision with 230 `vc-annotate-warp-revision', preserving the current line. 231 232 Candidates are annotated with the commit author and date and can be 233 narrowed by author. Additionally the narrowing keys 234 `consult-vc-annotate-revision-narrow-key-forward' and 235 `consult-vc-annotate-revision-narrow-key-backward' select the commits 236 newer and older than the currently annotated revision. 237 238 For Git backends the full history of the annotated file is offered. 239 For other backends only the revisions visible in the annotate buffer 240 are offered, without commit metadata." 241 (interactive) 242 (unless (derived-mode-p 'vc-annotate-mode) 243 (user-error "Not in a vc-annotate buffer")) 244 (consult--forbid-minibuffer) 245 (pcase-let* ((`(,backend (,file)) vc-buffer-overriding-fileset) 246 (items (consult--slow-operation "Collecting revisions..." 247 (if (eq backend 'Git) 248 (consult-vc--git-annotate-revision-items file) 249 (consult-vc--annotate-revision-items-fallback)))) 250 (anchor vc-buffer-revision) 251 ;; Match the anchor by prefix for Git, where revisions 252 ;; may be abbreviated; use exact match for other 253 ;; backends. 254 (anchor-idx (and anchor 255 (cl-position anchor items 256 :key #'car 257 :test (if (eq backend 'Git) 258 #'string-prefix-p 259 #'equal))))) 260 ;; Sort by commit date, most recent revision first. The index is 261 ;; chronological, such that descending order is strictly 262 ;; chronological, also for commits with equal dates. 263 (setq items (sort items (lambda (a b) (> (nth 5 a) (nth 5 b))))) 264 (when anchor-idx 265 (setq items (cl-remove-if (lambda (item) (= (nth 5 item) anchor-idx)) 266 items))) 267 (let* ((candidates (consult-vc--annotate-revision-candidates items)) 268 (selected (consult--read 269 candidates 270 :prompt "Annotate revision: " 271 :category 'consult-vc-revision 272 :history 'consult-vc--annotate-revision-history 273 :require-match t 274 :sort nil 275 :annotate #'consult-vc--annotate-revision-annotate 276 :narrow (consult-vc--annotate-revision-narrow candidates anchor-idx) 277 :lookup #'consult--lookup-member))) 278 (vc-annotate-warp-revision 279 (get-text-property 0 'consult-vc-rev selected))))) 280 281 (provide 'consult-vc) 282 ;;; consult-vc.el ends here