commit 517dca2e29dfd0b666e7b1ef190d1c46ec12e039
Author: andsy10 <andsy1016@gmail.com>
Date: Tue, 22 Sep 2026 17:57:42 +0800
Initial commit
Diffstat:
| A | consult-vc.el | | | 282 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
1 file changed, 282 insertions(+), 0 deletions(-)
diff --git a/consult-vc.el b/consult-vc.el
@@ -0,0 +1,282 @@
+;;; consult-vc.el --- Consult commands for VC -*- lexical-binding: t -*-
+
+;;; Commentary:
+
+;; This package provides Consult commands enhancing `vc-annotate'.
+;;
+;; Use `consult-vc-annotate-revision' to select a revision of the file
+;; in the current annotate buffer and warp the buffer to the selected
+;; revision with `vc-annotate-warp-revision'. A suggested binding is:
+;;
+;; (keymap-set vc-annotate-mode-map "r" #'consult-vc-annotate-revision)
+;;
+;; Candidates are annotated with the commit author and date and can be
+;; narrowed by author. Additionally the narrowing keys
+;; `consult-vc-annotate-revision-narrow-key-forward' and
+;; `consult-vc-annotate-revision-narrow-key-backward' select the
+;; commits newer and older than the currently annotated revision.
+;;
+;; For Git backends the full history of the annotated file is offered.
+;; For other backends only the revisions visible in the annotate
+;; buffer are offered, without commit metadata.
+
+;;; Code:
+
+(require 'consult)
+(require 'vc-annotate)
+(require 'cl-lib)
+
+(declare-function vc-git--out-ok "vc-git")
+
+(defgroup consult-vc nil
+ "Consult commands for VC."
+ :group 'consult
+ :prefix "consult-vc-")
+
+(defcustom consult-vc-annotate-revision-narrow-key-forward ?>
+ "Narrowing key for commits newer than the annotated revision."
+ :type 'character)
+
+(defcustom consult-vc-annotate-revision-narrow-key-backward ?<
+ "Narrowing key for commits older than the annotated revision."
+ :type 'character)
+
+(defcustom consult-vc-annotate-revision-max-width 80
+ "Maximum display width of the candidates of `consult-vc-annotate-revision'.
+Set to nil to disable truncation."
+ :type '(choice natnum (const nil)))
+
+(defvar consult-vc--annotate-revision-history nil
+ "History for `consult-vc-annotate-revision'.")
+
+(defun consult-vc--annotate-revisions ()
+ "Collect the revisions occurring in the current `vc-annotate-mode' buffer.
+Return the revisions in order of first appearance. This is used for
+non-Git backends, see `consult-vc--annotate-revision-items-fallback'."
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (let (revs)
+ (while (not (eobp))
+ (when-let* ((rev (car (vc-annotate-extract-revision-at-line))))
+ (cl-pushnew rev revs :test #'equal))
+ (forward-line 1))
+ (nreverse revs)))))
+
+(defun consult-vc--git-file-revisions (file)
+ "Return the revisions touching FILE as a list of (FULL SHORT), oldest first."
+ (with-temp-buffer
+ (unless (vc-git--out-ok "log" "--follow" "--format=%H%x09%h" "--" file)
+ (user-error "Cannot get log for %s" file))
+ (goto-char (point-min))
+ (nreverse
+ (cl-loop while (re-search-forward "^\\([0-9a-f]+\\)\t\\([0-9a-f]+\\)$" nil t)
+ collect (list (match-string 1) (match-string 2))))))
+
+(defun consult-vc--git-revision-info (revs)
+ "Return a hash table mapping each revision of REVS to (DATE AUTHOR SUBJECT).
+REVS is a list of full Git commit hashes. The metadata is fetched in a
+single `git log' call; revisions missing from the batch result are
+fetched individually. Failures are ignored and the corresponding
+entries are absent from the table."
+ (let (entries)
+ (with-temp-buffer
+ (when (apply #'vc-git--out-ok "log" "--no-walk" "--date=short"
+ "--format=%H%x09%ad%x09%an%x09%s" revs)
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^\\([0-9a-f]+\\)\t\\([^\t]*\\)\t\\([^\t]*\\)\t\\(.*\\)$" nil t)
+ (push (list (match-string 1) (match-string 2)
+ (match-string 3) (match-string 4))
+ entries))))
+ (let ((result (make-hash-table :test #'equal)))
+ ;; Map each rev to its info, matching against the full hashes
+ ;; returned by `git log' by prefix, such that abbreviated
+ ;; revisions are also supported.
+ (dolist (rev revs)
+ (when-let* ((entry (cl-find rev entries :key #'car
+ :test #'string-prefix-p)))
+ (puthash rev (cdr entry) result)))
+ ;; Fallback for revisions missing from the batch result: fetch
+ ;; them one by one, ignoring failures.
+ (dolist (rev revs)
+ (unless (gethash rev result)
+ (with-temp-buffer
+ (when (vc-git--out-ok "show" "--no-patch" "--date=short"
+ "--format=%ad%x09%an%x09%s" rev)
+ (goto-char (point-min))
+ (when (re-search-forward "^\\([^\t]*\\)\t\\([^\t]*\\)\t\\(.*\\)$" nil t)
+ (puthash rev (list (match-string 1) (match-string 2)
+ (match-string 3))
+ result))))))
+ result)))
+
+(defun consult-vc--git-annotate-revision-items (file)
+ "Return revision items for FILE.
+
+An item is a list (REV SHORT DATE AUTHOR SUBJECT IDX). REV is the full
+revision used for warping, SHORT the abbreviated revision used for
+display, DATE the commit date as a zero-padded ISO string, AUTHOR and
+SUBJECT the commit metadata and IDX the position in the chronologically
+sorted item list.
+
+The items are sorted by commit date, oldest revision first."
+ (pcase-let* ((default-directory (file-name-directory file))
+ (revs (consult-vc--git-file-revisions file))
+ (info (consult-vc--git-revision-info (mapcar #'car revs)))
+ (items (sort
+ (cl-loop for (full short) in revs
+ for (date author subject) = (gethash full info)
+ collect (list full short date author subject nil))
+ (lambda (a b) (string< (or (nth 2 a) "")
+ (or (nth 2 b) ""))))))
+ (cl-loop for item in items
+ for idx from 0
+ do (setf (nth 5 item) idx))
+ items))
+
+(defun consult-vc--annotate-revision-items-fallback ()
+ "Return revision items extracted from the annotate buffer.
+This is used for non-Git backends without full history information."
+ (cl-loop for rev in (consult-vc--annotate-revisions)
+ for idx from 0
+ collect (list rev rev nil nil nil idx)))
+
+(defun consult-vc--annotate-revision-candidates (items)
+ "Return candidate strings for revision ITEMS.
+Each candidate is propertized with `consult-vc-rev',
+`consult-vc-author', `consult-vc-date' and `consult-vc-idx'. The
+visible part is truncated to `consult-vc-annotate-revision-max-width'."
+ (mapcar
+ (pcase-lambda (`(,rev ,short ,date ,author ,subject ,idx))
+ (let ((visible (concat (propertize short 'face 'consult-key)
+ (and subject " ") (or subject ""))))
+ (propertize
+ (concat
+ (if (and consult-vc-annotate-revision-max-width
+ (> (consult--display-width visible)
+ consult-vc-annotate-revision-max-width))
+ (truncate-string-to-width
+ visible consult-vc-annotate-revision-max-width nil nil "…")
+ visible)
+ (and (or date author subject)
+ (propertize (concat "\t" (or date "") " " (or author "")
+ " " (or subject ""))
+ 'invisible t)))
+ 'consult-vc-rev rev
+ 'consult-vc-author author
+ 'consult-vc-date date
+ 'consult-vc-idx idx)))
+ items))
+
+(defun consult-vc--annotate-revision-annotate (cand)
+ "Annotate revision candidate CAND with author and date."
+ (consult--annotate-align
+ cand
+ (let ((author (get-text-property 0 'consult-vc-author cand))
+ (date (get-text-property 0 'consult-vc-date cand)))
+ (concat
+ (and author (propertize author 'face 'completions-annotations))
+ (and author date " ")
+ (and date (propertize date 'face 'completions-annotations))))))
+
+(defun consult-vc--annotate-revision-narrow (candidates anchor-idx)
+ "Return narrowing configuration for revision CANDIDATES.
+ANCHOR-IDX is the index of the annotated revision, see `consult-vc-idx'.
+Authors are assigned keys in order of their number of commits in the
+history of the annotated file. If ANCHOR-IDX is non-nil, two additional
+narrowing keys select the commits newer and older than the annotated
+revision, see `consult-vc-annotate-revision-narrow-key-forward' and
+`consult-vc-annotate-revision-narrow-key-backward'."
+ (let ((counts (make-hash-table :test #'equal)))
+ (dolist (cand candidates)
+ (when-let* ((author (get-text-property 0 'consult-vc-author cand)))
+ (cl-incf (gethash author counts 0))))
+ (let* ((authors nil)
+ (authors-alist
+ (progn
+ (maphash (lambda (author n) (push (cons author n) authors)) counts)
+ (cl-loop for (author . _)
+ in (sort authors
+ (lambda (a b)
+ (or (> (cdr a) (cdr b))
+ (and (= (cdr a) (cdr b))
+ (string< (car a) (car b))))))
+ for i across "123456789abcdefghijklmnopqrstuvwxyz"
+ collect (cons i author)))))
+ (list :keys (append (mapcar (lambda (x) (cons (car x) (cdr x))) authors-alist)
+ (and anchor-idx
+ (list (cons consult-vc-annotate-revision-narrow-key-forward "Newer")
+ (cons consult-vc-annotate-revision-narrow-key-backward "Older"))))
+ :predicate
+ (lambda (cand)
+ (let ((key consult--narrow))
+ (cond ((cdr (assq key authors-alist))
+ (equal (get-text-property 0 'consult-vc-author cand)
+ (cdr (assq key authors-alist))))
+ ((eq key consult-vc-annotate-revision-narrow-key-forward)
+ (> (get-text-property 0 'consult-vc-idx cand) anchor-idx))
+ ((eq key consult-vc-annotate-revision-narrow-key-backward)
+ (< (get-text-property 0 'consult-vc-idx cand) anchor-idx)))))))))
+
+;;;; Commands
+
+;;;###autoload
+(defun consult-vc-annotate-revision ()
+ "Select a revision of the file in the current `vc-annotate-mode' buffer.
+
+The annotate buffer is warped to the selected revision with
+`vc-annotate-warp-revision', preserving the current line.
+
+Candidates are annotated with the commit author and date and can be
+narrowed by author. Additionally the narrowing keys
+`consult-vc-annotate-revision-narrow-key-forward' and
+`consult-vc-annotate-revision-narrow-key-backward' select the commits
+newer and older than the currently annotated revision.
+
+For Git backends the full history of the annotated file is offered.
+For other backends only the revisions visible in the annotate buffer
+are offered, without commit metadata."
+ (interactive)
+ (unless (derived-mode-p 'vc-annotate-mode)
+ (user-error "Not in a vc-annotate buffer"))
+ (consult--forbid-minibuffer)
+ (pcase-let* ((`(,backend (,file)) vc-buffer-overriding-fileset)
+ (items (consult--slow-operation "Collecting revisions..."
+ (if (eq backend 'Git)
+ (consult-vc--git-annotate-revision-items file)
+ (consult-vc--annotate-revision-items-fallback))))
+ (anchor vc-buffer-revision)
+ ;; Match the anchor by prefix for Git, where revisions
+ ;; may be abbreviated; use exact match for other
+ ;; backends.
+ (anchor-idx (and anchor
+ (cl-position anchor items
+ :key #'car
+ :test (if (eq backend 'Git)
+ #'string-prefix-p
+ #'equal)))))
+ ;; Sort by commit date, most recent revision first. The index is
+ ;; chronological, such that descending order is strictly
+ ;; chronological, also for commits with equal dates.
+ (setq items (sort items (lambda (a b) (> (nth 5 a) (nth 5 b)))))
+ (when anchor-idx
+ (setq items (cl-remove-if (lambda (item) (= (nth 5 item) anchor-idx))
+ items)))
+ (let* ((candidates (consult-vc--annotate-revision-candidates items))
+ (selected (consult--read
+ candidates
+ :prompt "Annotate revision: "
+ :category 'consult-vc-revision
+ :history 'consult-vc--annotate-revision-history
+ :require-match t
+ :sort nil
+ :annotate #'consult-vc--annotate-revision-annotate
+ :narrow (consult-vc--annotate-revision-narrow candidates anchor-idx)
+ :lookup #'consult--lookup-member)))
+ (vc-annotate-warp-revision
+ (get-text-property 0 'consult-vc-rev selected)))))
+
+(provide 'consult-vc)
+;;; consult-vc.el ends here
