marginalia.el (53531B)
1 ;;; marginalia.el --- Enrich existing commands with completion annotations -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2021, 2022 Free Software Foundation, Inc. 4 5 ;; Author: Omar Antolín Camarena <omar@matem.unam.mx>, Daniel Mendler <mail@daniel-mendler.de> 6 ;; Maintainer: Omar Antolín Camarena <omar@matem.unam.mx>, Daniel Mendler <mail@daniel-mendler.de> 7 ;; Created: 2020 8 ;; Version: 1.0 9 ;; Package-Requires: ((emacs "27.1")) 10 ;; Homepage: https://github.com/minad/marginalia 11 12 ;; This file is part of GNU Emacs. 13 14 ;; This program is free software: you can redistribute it and/or modify 15 ;; it under the terms of the GNU General Public License as published by 16 ;; the Free Software Foundation, either version 3 of the License, or 17 ;; (at your option) any later version. 18 19 ;; This program is distributed in the hope that it will be useful, 20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 22 ;; GNU General Public License for more details. 23 24 ;; You should have received a copy of the GNU General Public License 25 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 26 27 ;;; Commentary: 28 29 ;; Enrich existing commands with completion annotations 30 31 ;;; Code: 32 33 (eval-when-compile 34 (require 'subr-x) 35 (require 'cl-lib)) 36 37 ;;;; Customization 38 39 (defgroup marginalia nil 40 "Enrich existing commands with completion annotations." 41 :group 'convenience 42 :group 'minibuffer 43 :prefix "marginalia-") 44 45 (defcustom marginalia-field-width 80 46 "Maximum truncation width of annotation fields. 47 48 This value is adjusted depending on the `window-width'." 49 :type 'integer) 50 51 (defcustom marginalia-separator " " 52 "Annotation field separator." 53 :type 'string) 54 55 (defcustom marginalia-align 'left 56 "Alignment of the annotations." 57 :type '(choice (const :tag "Left" left) 58 (const :tag "Center" center) 59 (const :tag "Right" right))) 60 61 (defcustom marginalia-align-offset 0 62 "Additional offset added to the alignment." 63 :type 'integer) 64 65 (defcustom marginalia-max-relative-age (* 60 60 24 14) 66 "Maximum relative age in seconds displayed by the file annotator. 67 68 Set to `most-positive-fixnum' to always use a relative age, or 0 to never show 69 a relative age." 70 :type 'integer) 71 72 (defcustom marginalia-annotator-registry 73 (mapcar 74 (lambda (x) (append x '(builtin none))) 75 '((command marginalia-annotate-command marginalia-annotate-binding) 76 (embark-keybinding marginalia-annotate-embark-keybinding) 77 (customize-group marginalia-annotate-customize-group) 78 (variable marginalia-annotate-variable) 79 (function marginalia-annotate-function) 80 (face marginalia-annotate-face) 81 (color marginalia-annotate-color) 82 (unicode-name marginalia-annotate-char) 83 (minor-mode marginalia-annotate-minor-mode) 84 (symbol marginalia-annotate-symbol) 85 (environment-variable marginalia-annotate-environment-variable) 86 (input-method marginalia-annotate-input-method) 87 (coding-system marginalia-annotate-coding-system) 88 (charset marginalia-annotate-charset) 89 (package marginalia-annotate-package) 90 (imenu marginalia-annotate-imenu) 91 (bookmark marginalia-annotate-bookmark) 92 (file marginalia-annotate-file) 93 (project-file marginalia-annotate-project-file) 94 (buffer marginalia-annotate-buffer) 95 (library marginalia-annotate-library) 96 (tab marginalia-annotate-tab) 97 (multi-category marginalia-annotate-multi-category))) 98 "Annotator function registry. 99 Associates completion categories with annotation functions. 100 Each annotation function must return a string, 101 which is appended to the completion candidate." 102 :type '(alist :key-type symbol :value-type (repeat symbol))) 103 104 (defcustom marginalia-classifiers 105 '(marginalia-classify-by-command-name 106 marginalia-classify-original-category 107 marginalia-classify-by-prompt 108 marginalia-classify-symbol) 109 "List of functions to determine current completion category. 110 Each function should take no arguments and return a symbol 111 indicating the category, or nil to indicate it could not 112 determine it." 113 :type 'hook) 114 115 (defcustom marginalia-prompt-categories 116 '(("\\<customize group\\>" . customize-group) 117 ("\\<M-x\\>" . command) 118 ("\\<package\\>" . package) 119 ("\\<bookmark\\>" . bookmark) 120 ("\\<color\\>" . color) 121 ("\\<face\\>" . face) 122 ("\\<environment variable\\>" . environment-variable) 123 ("\\<function\\|hook to remove\\>" . function) 124 ("\\<variable\\>" . variable) 125 ("\\<input method\\>" . input-method) 126 ("\\<charset\\>" . charset) 127 ("\\<coding system\\>" . coding-system) 128 ("\\<minor mode\\>" . minor-mode) 129 ("\\<kill-ring\\>" . kill-ring) 130 ("\\<tab by name\\>" . tab) 131 ("\\<[Ll]ibrary\\>" . library)) 132 "Associates regexps to match against minibuffer prompts with categories." 133 :type '(alist :key-type regexp :value-type symbol)) 134 135 (defcustom marginalia-censor-variables 136 '("pass\\|auth-source-netrc-cache\\|auth-source-.*-nonce") 137 "The values of variables matching any of these regular expressions is not shown." 138 :type '(repeat (choice symbol regexp))) 139 140 (defcustom marginalia-command-categories 141 '((imenu . imenu) 142 (recentf-open . file)) 143 "Associate commands with a completion category." 144 :type '(alist :key-type symbol :value-type symbol)) 145 146 (defgroup marginalia-faces nil 147 "Faces used by `marginalia-mode'." 148 :group 'marginalia 149 :group 'faces) 150 151 (defface marginalia-key 152 '((t :inherit font-lock-keyword-face)) 153 "Face used to highlight keys.") 154 155 (defface marginalia-type 156 '((t :inherit marginalia-key)) 157 "Face used to highlight types.") 158 159 (defface marginalia-char 160 '((t :inherit marginalia-key)) 161 "Face used to highlight character annotations.") 162 163 (defface marginalia-lighter 164 '((t :inherit marginalia-size)) 165 "Face used to highlight minor mode lighters.") 166 167 (defface marginalia-on 168 '((t :inherit success)) 169 "Face used to signal enabled modes.") 170 171 (defface marginalia-off 172 '((t :inherit error)) 173 "Face used to signal disabled modes.") 174 175 (defface marginalia-documentation 176 '((t :inherit completions-annotations)) 177 "Face used to highlight documentation strings.") 178 179 (defface marginalia-value 180 '((t :inherit marginalia-key)) 181 "Face used to highlight general variable values.") 182 183 (defface marginalia-null 184 '((t :inherit font-lock-comment-face)) 185 "Face used to highlight null or unbound variable values.") 186 187 (defface marginalia-true 188 '((t :inherit font-lock-builtin-face)) 189 "Face used to highlight true variable values.") 190 191 (defface marginalia-function 192 '((t :inherit font-lock-function-name-face)) 193 "Face used to highlight function symbols.") 194 195 (defface marginalia-symbol 196 '((t :inherit font-lock-type-face)) 197 "Face used to highlight general symbols.") 198 199 (defface marginalia-list 200 '((t :inherit font-lock-constant-face)) 201 "Face used to highlight list expressions.") 202 203 (defface marginalia-mode 204 '((t :inherit marginalia-key)) 205 "Face used to highlight buffer major modes.") 206 207 (defface marginalia-date 208 '((t :inherit marginalia-key)) 209 "Face used to highlight dates.") 210 211 (defface marginalia-version 212 '((t :inherit marginalia-number)) 213 "Face used to highlight package versions.") 214 215 (defface marginalia-archive 216 '((t :inherit warning)) 217 "Face used to highlight package archives.") 218 219 (defface marginalia-installed 220 '((t :inherit success)) 221 "Face used to highlight the status of packages.") 222 223 (defface marginalia-size 224 '((t :inherit marginalia-number)) 225 "Face used to highlight sizes.") 226 227 (defface marginalia-number 228 '((t :inherit font-lock-constant-face)) 229 "Face used to highlight numeric values.") 230 231 (defface marginalia-string 232 '((t :inherit font-lock-string-face)) 233 "Face used to highlight string values.") 234 235 (defface marginalia-modified 236 '((t :inherit font-lock-negation-char-face)) 237 "Face used to highlight buffer modification indicators.") 238 239 (defface marginalia-file-name 240 '((t :inherit marginalia-documentation)) 241 "Face used to highlight file names.") 242 243 (defface marginalia-file-owner 244 '((t :inherit font-lock-preprocessor-face)) 245 "Face used to highlight file owner and group names.") 246 247 (defface marginalia-file-priv-no 248 '((t :inherit shadow)) 249 "Face used to highlight the no file privilege attribute.") 250 251 (defface marginalia-file-priv-dir 252 '((t :inherit font-lock-keyword-face)) 253 "Face used to highlight the dir file privilege attribute.") 254 255 (defface marginalia-file-priv-link 256 '((t :inherit font-lock-keyword-face)) 257 "Face used to highlight the link file privilege attribute.") 258 259 (defface marginalia-file-priv-read 260 '((t :inherit font-lock-type-face)) 261 "Face used to highlight the read file privilege attribute.") 262 263 (defface marginalia-file-priv-write 264 '((t :inherit font-lock-builtin-face)) 265 "Face used to highlight the write file privilege attribute.") 266 267 (defface marginalia-file-priv-exec 268 '((t :inherit font-lock-function-name-face)) 269 "Face used to highlight the exec file privilege attribute.") 270 271 (defface marginalia-file-priv-other 272 '((t :inherit font-lock-constant-face)) 273 "Face used to highlight some other file privilege attribute.") 274 275 (defface marginalia-file-priv-rare 276 '((t :inherit font-lock-variable-name-face)) 277 "Face used to highlight a rare file privilege attribute.") 278 279 ;;;; Pre-declarations for external packages 280 281 (declare-function bookmark-get-handler "bookmark") 282 (declare-function bookmark-get-filename "bookmark") 283 (declare-function bookmark-get-front-context-string "bookmark") 284 285 (defvar package--builtins) 286 (defvar package-archive-contents) 287 (declare-function package--from-builtin "package") 288 (declare-function package-desc-archive "package") 289 (declare-function package-desc-status "package") 290 (declare-function package-desc-summary "package") 291 (declare-function package-desc-version "package") 292 (declare-function package-version-join "package") 293 (declare-function project-current "project") 294 295 (declare-function color-rgb-to-hex "color") 296 (declare-function color-rgb-to-hsl "color") 297 (declare-function color-hsl-to-rgb "color") 298 299 ;;;; Marginalia mode 300 301 (defvar marginalia--bookmark-type-transforms 302 (let ((words (regexp-opt '("handle" "handler" "jump" "bookmark")))) 303 `((,(format "-+%s-+" words) . "-") 304 (,(format "\\`%s-+" words) . "") 305 (,(format "-%s\\'" words) . "") 306 ("\\`default\\'" . "File") 307 (".*" . ,#'capitalize))) 308 "List of bookmark type transformers. 309 Relying on this mechanism is discouraged in favor of the 310 `bookmark-handler-type' property.") 311 312 (defvar marginalia--candw-step 10 313 "Round candidate width.") 314 315 (defvar-local marginalia--candw-max 20 316 "Maximum width of candidates.") 317 318 (defvar marginalia--fontified-file-modes nil 319 "List of fontified file modes.") 320 321 (defvar-local marginalia--cache nil 322 "The cache, pair of list and hashtable.") 323 324 (defvar marginalia--cache-size 100 325 "Size of the cache, set to 0 to disable the cache. 326 Disabling the cache is useful on non-incremental UIs like default completion or 327 for performance profiling of the annotators.") 328 329 (defvar-local marginalia--command nil 330 "Last command symbol saved in order to allow annotations.") 331 332 (defvar-local marginalia--base-position 0 333 "Last completion base position saved to get full file paths.") 334 335 (defvar marginalia--metadata nil 336 "Completion metadata from the current completion.") 337 338 (defvar marginalia--ellipsis nil) 339 (defun marginalia--ellipsis () 340 "Return ellipsis." 341 (or marginalia--ellipsis 342 ;; Emacs 28 offers the function `truncate-string-ellipsis'. 343 ;; Unfortunately we cannot use it here due to backward 344 ;; compatibility. Replicate it instead. 345 (setq marginalia--ellipsis 346 (cond 347 ((bound-and-true-p truncate-string-ellipsis)) 348 ((char-displayable-p ?…) "…") 349 ("..."))))) 350 351 (defun marginalia--truncate (str width) 352 "Truncate string STR to WIDTH." 353 (when (floatp width) (setq width (round (* width marginalia-field-width)))) 354 (when-let (pos (string-match-p "\n" str)) 355 (setq str (substring str 0 pos))) 356 (let* ((face (and (not (equal str "")) (get-text-property (1- (length str)) 'face str))) 357 (ell (if face (propertize (marginalia--ellipsis) 'face face) (marginalia--ellipsis)))) 358 (if (< width 0) 359 (nreverse (truncate-string-to-width (reverse str) (- width) 0 ?\s ell)) 360 (truncate-string-to-width str width 0 ?\s ell)))) 361 362 (cl-defmacro marginalia--field (field &key truncate face width) 363 "Format FIELD as a string according to some options. 364 TRUNCATE is the truncation width. 365 WIDTH is the field width. 366 FACE is the name of the face, with which the field should be propertized." 367 (setq field `(or ,field "")) 368 (when width (setq field `(format ,(format "%%%ds" (- width)) ,field))) 369 (when truncate (setq field `(marginalia--truncate ,field ,truncate))) 370 (when face (setq field `(propertize ,field 'face ,face))) 371 field) 372 373 (defmacro marginalia--fields (&rest fields) 374 "Format annotation FIELDS as a string with separators in between." 375 `(concat 376 #(" " 0 1 (marginalia--align t)) 377 ,@(mapcan (lambda (field) 378 (list 'marginalia-separator `(marginalia--field ,@field))) 379 fields))) 380 381 (defun marginalia--documentation (str) 382 "Format documentation string STR." 383 (when str 384 (marginalia--fields 385 (str :truncate 1.0 :face 'marginalia-documentation)))) 386 387 (defun marginalia-annotate-binding (cand) 388 "Annotate command CAND with keybinding." 389 (when-let* ((sym (intern-soft cand)) 390 (key (and (commandp sym) (where-is-internal sym nil 'first-only)))) 391 (format #(" (%s)" 1 5 (face marginalia-key)) (key-description key)))) 392 393 (defun marginalia--annotator (cat) 394 "Return annotation function for category CAT." 395 (pcase (car (alist-get cat marginalia-annotator-registry)) 396 ('none #'ignore) 397 ('builtin nil) 398 (fun fun))) 399 400 (defun marginalia-annotate-multi-category (cand) 401 "Annotate multi-category CAND with the buffer class." 402 (if-let* ((multi (get-text-property 0 'multi-category cand)) 403 (annotate (marginalia--annotator (car multi)))) 404 ;; Use the Marginalia annotator corresponding to the multi category. 405 (funcall annotate (cdr multi)) 406 ;; Apply the original annotation function on the original candidate, if there is one. 407 ;; NOTE: Use `alist-get' instead of `completion-metadata-get' to bypass our 408 ;; `marginalia--completion-metadata-get' advice! 409 (when-let (annotate (alist-get 'annotation-function marginalia--metadata)) 410 (funcall annotate cand)))) 411 412 (defconst marginalia--advice-regexp 413 (rx bos 414 (1+ (seq (? "This function has ") 415 (or ":before" ":after" ":around" ":override" 416 ":before-while" ":before-until" ":after-while" 417 ":after-until" ":filter-args" ":filter-return") 418 " advice: " (0+ nonl) "\n")) 419 "\n") 420 "Regexp to match lines about advice in function documentation strings.") 421 422 ;; Taken from advice--make-docstring, is this robust? 423 (defun marginalia--advised (fun) 424 "Return t if function FUN is advised." 425 (let ((flist (indirect-function fun))) 426 (advice--p (if (eq 'macro (car-safe flist)) (cdr flist) flist)))) 427 428 (defun marginalia--symbol-class (s) 429 "Return symbol class characters for symbol S. 430 431 This function is an extension of `help--symbol-class'. It returns 432 more fine-grained and more detailled symbol information. 433 434 Function: 435 f function 436 c command 437 C interactive-only command 438 m macro 439 M special-form 440 g cl-generic 441 p pure 442 s side-effect-free 443 @ autoloaded 444 ! advised 445 - obsolete 446 & alias 447 448 Variable: 449 u custom (U modified compared to global value) 450 v variable 451 l local (L modified compared to default value) 452 - obsolete 453 & alias 454 455 Other: 456 a face 457 t cl-type" 458 (format 459 "%-6s" 460 (concat 461 (when (fboundp s) 462 (concat 463 (cond 464 ((get s 'pure) "p") 465 ((get s 'side-effect-free) "s")) 466 (cond 467 ((commandp s) (if (get s 'interactive-only) "C" "c")) 468 ((cl-generic-p s) "g") 469 ((macrop (symbol-function s)) "m") 470 ((special-form-p (symbol-function s)) "M") 471 (t "f")) 472 (and (autoloadp (symbol-function s)) "@") 473 (and (marginalia--advised s) "!") 474 (and (symbolp (symbol-function s)) "&") 475 (and (get s 'byte-obsolete-info) "-"))) 476 (when (boundp s) 477 (concat 478 (when (local-variable-if-set-p s) 479 (if (ignore-errors 480 (not (equal (symbol-value s) 481 (default-value s)))) 482 "L" "l")) 483 (if (custom-variable-p s) 484 (if (ignore-errors 485 (not (equal 486 (symbol-value s) 487 (eval (car (get s 'standard-value)))))) 488 "U" "u") 489 "v") 490 (ignore-errors (and (not (eq (indirect-variable s) s)) "&")) 491 (and (get s 'byte-obsolete-variable) "-"))) 492 (and (facep s) "a") 493 (and (fboundp 'cl-find-class) (cl-find-class s) "t")))) 494 495 (defun marginalia--function-doc (sym) 496 "Documentation string of function SYM." 497 (when-let (str (ignore-errors (documentation sym))) 498 (save-match-data 499 (if (string-match marginalia--advice-regexp str) 500 (substring str (match-end 0)) 501 str)))) 502 503 ;; Derived from elisp-get-fnsym-args-string 504 (defun marginalia--function-args (sym) 505 "Return function arguments for SYM." 506 (let ((tmp)) 507 (elisp-function-argstring 508 (cond 509 ((listp (setq tmp (gethash (indirect-function sym) 510 advertised-signature-table t))) 511 tmp) 512 ((setq tmp (help-split-fundoc 513 (ignore-errors (documentation sym t)) 514 sym)) 515 (substitute-command-keys (car tmp))) 516 ((setq tmp (help-function-arglist sym)) 517 (and 518 (if (and (stringp tmp) 519 (string-match-p "Arg list not available" tmp)) 520 ;; A shorter text fits better into the 521 ;; limited Marginalia space. 522 "[autoload]" 523 tmp))))))) 524 525 (defun marginalia-annotate-symbol (cand) 526 "Annotate symbol CAND with its documentation string." 527 (when-let (sym (intern-soft cand)) 528 (concat 529 (marginalia-annotate-binding cand) 530 (marginalia--fields 531 ((marginalia--symbol-class sym) :face 'marginalia-type) 532 ((cond 533 ((fboundp sym) (marginalia--function-doc sym)) 534 ((facep sym) (documentation-property sym 'face-documentation)) 535 (t (documentation-property sym 'variable-documentation))) 536 :truncate 1.0 :face 'marginalia-documentation))))) 537 538 (defun marginalia-annotate-command (cand) 539 "Annotate command CAND with its documentation string. 540 Similar to `marginalia-annotate-symbol', but does not show symbol class." 541 (when-let (sym (intern-soft cand)) 542 (concat 543 (marginalia-annotate-binding cand) 544 (marginalia--documentation (marginalia--function-doc sym))))) 545 546 (defun marginalia-annotate-embark-keybinding (cand) 547 "Annotate Embark keybinding CAND with its documentation string. 548 Similar to `marginalia-annotate-command', but does not show the 549 keybinding since CAND includes it." 550 (when-let (cmd (get-text-property 0 'embark-command cand)) 551 (marginalia--documentation (marginalia--function-doc cmd)))) 552 553 (defun marginalia-annotate-imenu (cand) 554 "Annotate imenu CAND with its documentation string." 555 (when (derived-mode-p 'emacs-lisp-mode) 556 ;; Strip until the last whitespace in order to support flat imenu 557 (marginalia-annotate-symbol (replace-regexp-in-string "^.* " "" cand)))) 558 559 (defun marginalia-annotate-function (cand) 560 "Annotate function CAND with its documentation string." 561 (when-let (sym (intern-soft cand)) 562 (when (fboundp sym) 563 (concat 564 (marginalia-annotate-binding cand) 565 (marginalia--fields 566 ((marginalia--symbol-class sym) :face 'marginalia-type) 567 ((marginalia--function-args sym) :face 'marginalia-value 568 :truncate 0.5) 569 ((marginalia--function-doc sym) :truncate 1.0 570 :face 'marginalia-documentation)))))) 571 572 (defun marginalia--variable-value (sym) 573 "Return the variable value of SYM as string." 574 (cond 575 ((not (boundp sym)) 576 (propertize "#<unbound>" 'face 'marginalia-null)) 577 ((and marginalia-censor-variables 578 (let ((name (symbol-name sym))) 579 (cl-loop for r in marginalia-censor-variables 580 thereis (if (symbolp r) 581 (eq r sym) 582 (string-match-p r name))))) 583 (propertize "*****" 'face 'marginalia-null)) 584 (t (let ((val (symbol-value sym))) 585 (pcase val 586 ('nil (propertize "nil" 'face 'marginalia-null)) 587 ('t (propertize "t" 'face 'marginalia-true)) 588 ((pred keymapp) (propertize "#<keymap>" 'face 'marginalia-value)) 589 ((pred bool-vector-p) (propertize "#<bool-vector>" 'face 'marginalia-value)) 590 ((pred hash-table-p) (propertize "#<hash-table>" 'face 'marginalia-value)) 591 ((pred syntax-table-p) (propertize "#<syntax-table>" 'face 'marginalia-value)) 592 ;; Emacs bug#53988: abbrev-table-p throws an error 593 ((guard (ignore-errors (abbrev-table-p val))) (propertize "#<abbrev-table>" 'face 'marginalia-value)) 594 ((pred char-table-p) (propertize "#<char-table>" 'face 'marginalia-value)) 595 ((pred byte-code-function-p) (propertize "#<byte-code-function>" 'face 'marginalia-function)) 596 ((and (pred functionp) (pred symbolp)) 597 ;; NOTE: We are not consistent here, values are generally printed unquoted. But we 598 ;; make an exception for function symbols to visually distinguish them from symbols. 599 ;; I am not entirely happy with this, but we should not add quotation to every type. 600 (format (propertize "#'%s" 'face 'marginalia-function) val)) 601 ((pred recordp) (format (propertize "#<record %s>" 'face 'marginalia-value) (type-of val))) 602 ((pred symbolp) (propertize (symbol-name val) 'face 'marginalia-symbol)) 603 ((pred numberp) (propertize (number-to-string val) 'face 'marginalia-number)) 604 (_ (let ((print-escape-newlines t) 605 (print-escape-control-characters t) 606 ;;(print-escape-multibyte t) 607 (print-level 3) 608 (print-length marginalia-field-width)) 609 (propertize 610 (replace-regexp-in-string 611 ;; `print-escape-control-characters' does not escape Unicode control characters. 612 "[\x0-\x1F\x7f-\x9f\x061c\x200e\x200f\x202a-\x202e\x2066-\x2069]" 613 (lambda (x) (format "\\x%x" (string-to-char x))) 614 (prin1-to-string 615 (if (stringp val) 616 ;; Get rid of string properties to save some of the precious space 617 (substring-no-properties 618 val 0 619 (min (length val) marginalia-field-width)) 620 val)) 621 'fixedcase 'literal) 622 'face 623 (cond 624 ((listp val) 'marginalia-list) 625 ((stringp val) 'marginalia-string) 626 (t 'marginalia-value)))))))))) 627 628 (defun marginalia-annotate-variable (cand) 629 "Annotate variable CAND with its documentation string." 630 (when-let (sym (intern-soft cand)) 631 (marginalia--fields 632 ((marginalia--symbol-class sym) :face 'marginalia-type) 633 ((marginalia--variable-value sym) :truncate 0.5) 634 ((documentation-property sym 'variable-documentation) 635 :truncate 1.0 :face 'marginalia-documentation)))) 636 637 (defun marginalia-annotate-environment-variable (cand) 638 "Annotate environment variable CAND with its current value." 639 (when-let (val (getenv cand)) 640 (marginalia--fields 641 (val :truncate 1.0 :face 'marginalia-value)))) 642 643 (defun marginalia-annotate-face (cand) 644 "Annotate face CAND with its documentation string and face example." 645 (when-let (sym (intern-soft cand)) 646 (marginalia--fields 647 ("abcdefghijklmNOPQRSTUVWXYZ" :face sym) 648 ((documentation-property sym 'face-documentation) 649 :truncate 1.0 :face 'marginalia-documentation)))) 650 651 (defun marginalia-annotate-color (cand) 652 "Annotate face CAND with its documentation string and face example." 653 (when-let (rgb (color-name-to-rgb cand)) 654 (pcase-let* ((`(,r ,g ,b) rgb) 655 (`(,h ,s ,l) (apply #'color-rgb-to-hsl rgb)) 656 (cr (color-rgb-to-hex r 0 0)) 657 (cg (color-rgb-to-hex 0 g 0)) 658 (cb (color-rgb-to-hex 0 0 b)) 659 (ch (apply #'color-rgb-to-hex (color-hsl-to-rgb h 1 0.5))) 660 (cs (apply #'color-rgb-to-hex (color-hsl-to-rgb h s 0.5))) 661 (cl (apply #'color-rgb-to-hex (color-hsl-to-rgb 0 0 l)))) 662 (marginalia--fields 663 (" " :face `(:background ,(apply #'color-rgb-to-hex rgb))) 664 ((format "%s%s%s %s" 665 (propertize "r" 'face `(:background ,cr :foreground ,(readable-foreground-color cr))) 666 (propertize "g" 'face `(:background ,cg :foreground ,(readable-foreground-color cg))) 667 (propertize "b" 'face `(:background ,cb :foreground ,(readable-foreground-color cb))) 668 (color-rgb-to-hex r g b 2))) 669 ((format "%s%s%s %3s° %3s%% %3s%%" 670 (propertize "h" 'face `(:background ,ch :foreground ,(readable-foreground-color ch))) 671 (propertize "s" 'face `(:background ,cs :foreground ,(readable-foreground-color cs))) 672 (propertize "l" 'face `(:background ,cl :foreground ,(readable-foreground-color cl))) 673 (round (* 360 h)) 674 (round (* 100 s)) 675 (round (* 100 l)))))))) 676 677 (defun marginalia-annotate-char (cand) 678 "Annotate character CAND with its general character category and character code." 679 (when-let (char (char-from-name cand t)) 680 (concat 681 (format #(" (%c)" 1 5 (face marginalia-char)) char) 682 (marginalia--fields 683 ((format "%06X" char) :face 'marginalia-number) 684 ((char-code-property-description 685 'general-category 686 (get-char-code-property char 'general-category)) 687 :width 30 :face 'marginalia-documentation))))) 688 689 (defun marginalia-annotate-minor-mode (cand) 690 "Annotate minor-mode CAND with status and documentation string." 691 (let* ((sym (intern-soft cand)) 692 (mode (if (and sym (boundp sym)) 693 sym 694 (lookup-minor-mode-from-indicator cand))) 695 (lighter (cdr (assq mode minor-mode-alist))) 696 (lighter-str (and lighter (string-trim (format-mode-line (cons t lighter)))))) 697 (marginalia--fields 698 ((if (and (boundp mode) (symbol-value mode)) 699 (propertize "On" 'face 'marginalia-on) 700 (propertize "Off" 'face 'marginalia-off)) :width 3) 701 ((if (local-variable-if-set-p mode) "Local" "Global") :width 6 :face 'marginalia-type) 702 (lighter-str :width 20 :face 'marginalia-lighter) 703 ((marginalia--function-doc mode) 704 :truncate 1.0 :face 'marginalia-documentation)))) 705 706 (defun marginalia-annotate-package (cand) 707 "Annotate package CAND with its description summary." 708 (when-let* ((pkg-alist (bound-and-true-p package-alist)) 709 (name (replace-regexp-in-string "-[0-9\\.-]+\\'" "" cand)) 710 (pkg (intern-soft name)) 711 (desc (or (unless (equal name cand) 712 (cl-loop with version = (substring cand (1+ (length name))) 713 for d in (alist-get pkg pkg-alist) 714 if (equal (package-version-join (package-desc-version d)) version) 715 return d)) 716 ;; taken from `describe-package-1' 717 (car (alist-get pkg pkg-alist)) 718 (if-let (built-in (assq pkg package--builtins)) 719 (package--from-builtin built-in) 720 (car (alist-get pkg package-archive-contents)))))) 721 (marginalia--fields 722 ((package-version-join (package-desc-version desc)) :truncate 16 :face 'marginalia-version) 723 ((cond 724 ((package-desc-archive desc) (propertize (package-desc-archive desc) 'face 'marginalia-archive)) 725 (t (propertize (or (package-desc-status desc) "orphan") 'face 'marginalia-installed))) :truncate 12) 726 ((package-desc-summary desc) :truncate 1.0 :face 'marginalia-documentation)))) 727 728 (defun marginalia--bookmark-type (bm) 729 "Return bookmark type string of BM. 730 The string is transformed according to `marginalia--bookmark-type-transforms'." 731 (let ((handler (or (bookmark-get-handler bm) 'bookmark-default-handler))) 732 (and 733 ;; Some libraries use lambda handlers instead of symbols. For 734 ;; example the function `xwidget-webkit-bookmark-make-record' is 735 ;; affected. I consider this bad style since then the lambda is 736 ;; persisted. 737 (symbolp handler) 738 (or (get handler 'bookmark-handler-type) 739 (let ((str (symbol-name handler))) 740 (dolist (transformer marginalia--bookmark-type-transforms str) 741 (when (string-match-p (car transformer) str) 742 (setq str 743 (if (stringp (cdr transformer)) 744 (replace-regexp-in-string (car transformer) (cdr transformer) str) 745 (funcall (cdr transformer) str)))))))))) 746 747 (defun marginalia-annotate-bookmark (cand) 748 "Annotate bookmark CAND with its file name and front context string." 749 (when-let ((bm (assoc cand (bound-and-true-p bookmark-alist)))) 750 (let ((front (bookmark-get-front-context-string bm))) 751 (marginalia--fields 752 ((marginalia--bookmark-type bm) :width 10 :face 'marginalia-type) 753 ((bookmark-get-filename bm) 754 :truncate -0.5 :face 'marginalia-file-name) 755 ((unless (or (not front) (string= front "")) 756 (concat (string-trim 757 (replace-regexp-in-string 758 "[ \t]+" " " 759 (replace-regexp-in-string "\n" "\\\\n" front))) 760 (marginalia--ellipsis))) 761 :truncate -0.3 :face 'marginalia-documentation))))) 762 763 (defun marginalia-annotate-customize-group (cand) 764 "Annotate customization group CAND with its documentation string." 765 (marginalia--documentation (documentation-property (intern cand) 'group-documentation))) 766 767 (defun marginalia-annotate-input-method (cand) 768 "Annotate input method CAND with its description." 769 (marginalia--documentation (nth 4 (assoc cand input-method-alist)))) 770 771 (defun marginalia-annotate-charset (cand) 772 "Annotate charset CAND with its description." 773 (marginalia--documentation (charset-description (intern cand)))) 774 775 (defun marginalia-annotate-coding-system (cand) 776 "Annotate coding system CAND with its description." 777 (marginalia--documentation (coding-system-doc-string (intern cand)))) 778 779 (defun marginalia--buffer-status (buffer) 780 "Return the status of BUFFER as a string." 781 (format-mode-line '((:propertize "%1*%1+%1@" face marginalia-modified) 782 marginalia-separator 783 (7 (:propertize "%I" face marginalia-size)) 784 marginalia-separator 785 ;; InactiveMinibuffer has 18 letters, but there are longer names. 786 ;; For example Org-Agenda produces very long mode names. 787 ;; Therefore we have to truncate. 788 (20 (-20 (:propertize mode-name face marginalia-mode)))) 789 nil nil buffer)) 790 791 (defun marginalia--buffer-file (buffer) 792 "Return the file or process name of BUFFER." 793 (if-let (proc (get-buffer-process buffer)) 794 (format "(%s %s) %s" 795 proc (process-status proc) 796 (abbreviate-file-name (buffer-local-value 'default-directory buffer))) 797 (abbreviate-file-name 798 (or (cond 799 ;; see ibuffer-buffer-file-name 800 ((buffer-file-name buffer)) 801 ((when-let (dir (and (local-variable-p 'dired-directory buffer) 802 (buffer-local-value 'dired-directory buffer))) 803 (expand-file-name (if (stringp dir) dir (car dir)) 804 (buffer-local-value 'default-directory buffer)))) 805 ((local-variable-p 'list-buffers-directory buffer) 806 (buffer-local-value 'list-buffers-directory buffer))) 807 "")))) 808 809 (defun marginalia-annotate-buffer (cand) 810 "Annotate buffer CAND with modification status, file name and major mode." 811 (when-let (buffer (get-buffer cand)) 812 (marginalia--fields 813 ((marginalia--buffer-status buffer)) 814 ((marginalia--buffer-file buffer) 815 :truncate -0.5 :face 'marginalia-file-name)))) 816 817 (defun marginalia--full-candidate (cand) 818 "Return completion candidate CAND in full. 819 For some completion tables, the completion candidates offered are 820 meant to be only a part of the full minibuffer contents. For 821 example, during file name completion the candidates are one path 822 component of a full file path." 823 (if-let (win (active-minibuffer-window)) 824 (with-current-buffer (window-buffer win) 825 (concat (substring (minibuffer-contents-no-properties) 826 0 marginalia--base-position) 827 cand)) 828 ;; no minibuffer is active, trust that cand already conveys all 829 ;; necessary information (there's not much else we can do) 830 cand)) 831 832 (defun marginalia--remote-protocol (path) 833 "Return the remote protocol of PATH." 834 (save-match-data 835 (setq path (substitute-in-file-name path)) 836 (and (string-match "\\`/\\([^/|:]+\\):" path) 837 (match-string 1 path)))) 838 839 (defun marginalia--annotate-local-file (cand) 840 "Annotate local file CAND." 841 (when-let (attrs (ignore-errors 842 ;; may throw permission denied errors 843 (file-attributes (substitute-in-file-name 844 (marginalia--full-candidate cand)) 845 'integer))) 846 ;; HACK: Format differently accordingly to alignment, since the file owner 847 ;; is usually not displayed. Otherwise we will see an excessive amount of 848 ;; whitespace in front of the file permissions. Furthermore the alignment 849 ;; in `consult-buffer' will look ugly. TODO: Find a better solution! 850 (if (eq marginalia-align 'right) 851 (marginalia--fields 852 ;; File owner at the left 853 ((marginalia--file-owner attrs) :face 'marginalia-file-owner) 854 ((marginalia--file-modes attrs)) 855 ((file-size-human-readable (file-attribute-size attrs)) 856 :face 'marginalia-size :width -7) 857 ((marginalia--time (file-attribute-modification-time attrs)) 858 :face 'marginalia-date :width -12)) 859 (marginalia--fields 860 ((marginalia--file-modes attrs)) 861 ((file-size-human-readable (file-attribute-size attrs)) 862 :face 'marginalia-size :width -7) 863 ((marginalia--time (file-attribute-modification-time attrs)) 864 :face 'marginalia-date :width -12) 865 ;; File owner at the right 866 ((marginalia--file-owner attrs) :face 'marginalia-file-owner))))) 867 868 (defun marginalia-annotate-file (cand) 869 "Annotate file CAND with its size, modification time and other attributes. 870 These annotations are skipped for remote paths." 871 (if-let (remote (or (marginalia--remote-protocol cand) 872 (when-let (win (active-minibuffer-window)) 873 (with-current-buffer (window-buffer win) 874 (marginalia--remote-protocol (minibuffer-contents-no-properties)))))) 875 (marginalia--fields ((format "*%s*" remote) :face 'marginalia-documentation)) 876 (marginalia--annotate-local-file cand))) 877 878 (defun marginalia--file-owner (attrs) 879 "Return file owner given ATTRS." 880 (let ((uid (file-attribute-user-id attrs)) 881 (gid (file-attribute-group-id attrs))) 882 (when (or (/= (user-uid) uid) (/= (group-gid) gid)) 883 (format "%s:%s" 884 (or (user-login-name uid) uid) 885 (or (group-name gid) gid))))) 886 887 (defun marginalia--file-modes (attrs) 888 "Return fontified file modes given the ATTRS." 889 ;; Without caching this can a be significant portion of the time 890 ;; `marginalia-annotate-file' takes to execute. Caching improves performance 891 ;; by about a factor of 20. 892 (setq attrs (file-attribute-modes attrs)) 893 (or (car (member attrs marginalia--fontified-file-modes)) 894 (progn 895 (setq attrs (substring attrs)) ;; copy because attrs is about to be modified 896 (dotimes (i (length attrs)) 897 (put-text-property 898 i (1+ i) 'face 899 (pcase (aref attrs i) 900 (?- 'marginalia-file-priv-no) 901 (?d 'marginalia-file-priv-dir) 902 (?l 'marginalia-file-priv-link) 903 (?r 'marginalia-file-priv-read) 904 (?w 'marginalia-file-priv-write) 905 (?x 'marginalia-file-priv-exec) 906 ((or ?s ?S ?t ?T) 'marginalia-file-priv-other) 907 (_ 'marginalia-file-priv-rare)) 908 attrs)) 909 (push attrs marginalia--fontified-file-modes) 910 attrs))) 911 912 (defconst marginalia--time-relative 913 `((100 "sec" 1) 914 (,(* 60 100) "min" 60.0) 915 (,(* 3600 30) "hour" 3600.0) 916 (,(* 3600 24 400) "day" ,(* 3600.0 24.0)) 917 (nil "year" ,(* 365.25 24 3600))) 918 "Formatting used by the function `marginalia--time-relative'.") 919 920 ;; Taken from `seconds-to-string'. 921 (defun marginalia--time-relative (time) 922 "Format TIME as a relative age." 923 (setq time (max 0 (float-time (time-since time)))) 924 (let ((sts marginalia--time-relative) here) 925 (while (and (car (setq here (pop sts))) (<= (car here) time))) 926 (setq time (round time (caddr here))) 927 (format "%s %s%s ago" time (cadr here) (if (= time 1) "" "s")))) 928 929 (defun marginalia--time-absolute (time) 930 "Format TIME as an absolute age." 931 (let ((system-time-locale "C")) 932 (format-time-string 933 (if (> (decoded-time-year (decode-time (current-time))) 934 (decoded-time-year (decode-time time))) 935 " %Y %b %d" 936 "%b %d %H:%M") 937 time))) 938 939 (defun marginalia--time (time) 940 "Format file age TIME, suitably for use in annotations." 941 (if (< (float-time (time-since time)) marginalia-max-relative-age) 942 (marginalia--time-relative time) 943 (marginalia--time-absolute time))) 944 945 (defvar-local marginalia--project-root 'unset) 946 (defun marginalia--project-root () 947 "Return project root." 948 (with-current-buffer 949 (if-let (win (active-minibuffer-window)) 950 (window-buffer win) 951 (current-buffer)) 952 (when (eq marginalia--project-root 'unset) 953 (setq marginalia--project-root 954 (or (let ((prompt (minibuffer-prompt))) 955 (and (string-match 956 "\\`\\(?:Dired\\|Find file\\) in \\(.*\\): \\'" 957 prompt) 958 (match-string 1 prompt))) 959 (when-let (proj (project-current)) 960 (cond 961 ((fboundp 'project-root) (project-root proj)) 962 ((fboundp 'project-roots) (car (project-roots proj)))))))) 963 marginalia--project-root)) 964 965 (defun marginalia-annotate-project-file (cand) 966 "Annotate file CAND with its size, modification time and other attributes." 967 ;; Absolute project directories also report project-file category 968 (if (file-name-absolute-p cand) 969 (marginalia-annotate-file cand) 970 (when-let (root (marginalia--project-root)) 971 (marginalia-annotate-file (expand-file-name cand root))))) 972 973 (defvar-local marginalia--library-cache nil) 974 (defun marginalia--library-cache () 975 "Return library cache hash table." 976 (with-current-buffer 977 (if-let (win (active-minibuffer-window)) 978 (window-buffer win) 979 (current-buffer)) 980 ;; `locate-file' and `locate-library' are bottlenecks for the 981 ;; annotator. Therefore we compute all the library paths first. 982 (unless marginalia--library-cache 983 (setq marginalia--library-cache (make-hash-table :test #'equal)) 984 ;; Search in reverse because of shadowing 985 (dolist (dir (reverse load-path)) 986 (dolist (file (ignore-errors 987 (directory-files dir 'full 988 "\\.el\\(?:\\.gz\\)?\\'"))) 989 (puthash (marginalia--library-name file) 990 file marginalia--library-cache)))) 991 marginalia--library-cache)) 992 993 (defun marginalia--library-name (file) 994 "Get name of library FILE." 995 (replace-regexp-in-string "\\(\\.gz\\|\\.elc?\\)+\\'" "" 996 (file-name-nondirectory file))) 997 998 (defun marginalia--library-doc (file) 999 "Return library documentation string for FILE." 1000 (let ((doc (get-text-property 0 'marginalia--library-doc file))) 1001 (unless doc 1002 ;; Extract documentation string. We cannot use `lm-summary' here, 1003 ;; since it decompresses the whole file, which is slower. 1004 (setq doc (or (ignore-errors 1005 (let ((shell-file-name "sh") 1006 (shell-command-switch "-c")) 1007 (shell-command-to-string 1008 (format (if (string-suffix-p ".gz" file) 1009 "gzip -c -q -d %s | head -n1" 1010 "head -n1 %s") 1011 (shell-quote-argument file))))) 1012 "")) 1013 (cond 1014 ((string-match "\\`(define-package\\s-+\"\\([^\"]+\\)\"" doc) 1015 (setq doc (format "Generated package description from %s.el" 1016 (match-string 1 doc)))) 1017 ((string-match "\\`;+\\s-*" doc) 1018 (setq doc (substring doc (match-end 0))) 1019 (when (string-match "\\`[^ \t]+\\s-+-+\\s-+" doc) 1020 (setq doc (substring doc (match-end 0)))) 1021 (when (string-match "\\s-*-\\*-" doc) 1022 (setq doc (substring doc 0 (match-beginning 0))))) 1023 (t (setq doc ""))) 1024 ;; Add the documentation string to the cache 1025 (put-text-property 0 1 'marginalia--library-doc doc file)) 1026 doc)) 1027 1028 (defun marginalia-annotate-library (cand) 1029 "Annotate library CAND with documentation and path." 1030 (setq cand (marginalia--library-name cand)) 1031 (when-let (file (gethash cand (marginalia--library-cache))) 1032 (marginalia--fields 1033 ;; Display if the corresponding feature is loaded. 1034 ;; feature/=library file, but better than nothing. 1035 ((when-let (sym (intern-soft cand)) 1036 (when (memq sym features) 1037 (propertize "Loaded" 'face 'marginalia-on))) 1038 :width 8) 1039 ((marginalia--library-doc file) 1040 :truncate 1.0 :face 'marginalia-documentation) 1041 ((abbreviate-file-name (file-name-directory file)) 1042 :truncate -0.5 :face 'marginalia-file-name)))) 1043 1044 (defun marginalia-annotate-tab (cand) 1045 "Annotate named tab CAND with tab index, window and buffer information." 1046 (when-let* ((tabs (funcall tab-bar-tabs-function)) 1047 (index (seq-position 1048 tabs nil 1049 (lambda (tab _) (equal (alist-get 'name tab) cand))))) 1050 (let* ((tab (nth index tabs)) 1051 (ws (alist-get 'ws tab)) 1052 (bufs (window-state-buffers ws))) 1053 ;; NOTE: When the buffer key is present in the window state 1054 ;; it is added in front of the window buffer list and gets duplicated. 1055 (when (cadr (assq 'buffer ws)) (pop bufs)) 1056 (concat 1057 (format #(" (%s)" 0 5 (face marginalia-key)) index) 1058 (marginalia--fields 1059 ((format "win:%s" 1060 (if (eq (car tab) 'current-tab) 1061 (length (window-list nil 'no-minibuf)) 1062 (length bufs))) 1063 :face 'marginalia-size) 1064 ((format "group:%s" (or (alist-get 'group tab) 'none)) 1065 :face 'marginalia-type 1066 :truncate 20) 1067 ((if (eq (car tab) 'current-tab) 1068 "(current tab)" 1069 (string-join bufs " ")) 1070 :face 'marginalia-documentation)))))) 1071 1072 (defun marginalia-classify-by-command-name () 1073 "Lookup category for current command." 1074 (and marginalia--command 1075 (alist-get marginalia--command marginalia-command-categories))) 1076 1077 (defun marginalia-classify-original-category () 1078 "Return original category reported by completion metadata." 1079 ;; NOTE: Use `alist-get' instead of `completion-metadata-get' to bypass our 1080 ;; `marginalia--completion-metadata-get' advice! 1081 (when-let (cat (alist-get 'category marginalia--metadata)) 1082 ;; Ignore Emacs 28 symbol-help category in order to ensure that the 1083 ;; categories are refined to our categories function and variable. 1084 (and (not (eq cat 'symbol-help)) cat))) 1085 1086 (defun marginalia-classify-symbol () 1087 "Determine if currently completing symbols." 1088 (when-let (mct minibuffer-completion-table) 1089 (when (or (eq mct 'help--symbol-completion-table) 1090 (obarrayp mct) 1091 (and (not (functionp mct)) (consp mct) (symbolp (car mct)))) ; assume list of symbols 1092 'symbol))) 1093 1094 (defun marginalia-classify-by-prompt () 1095 "Determine category by matching regexps against the minibuffer prompt. 1096 This runs through the `marginalia-prompt-categories' alist 1097 looking for a regexp that matches the prompt." 1098 (when-let (prompt (minibuffer-prompt)) 1099 (setq prompt 1100 (replace-regexp-in-string "(.*default.*)\\|\\[.*\\]" "" prompt)) 1101 (cl-loop for (regexp . category) in marginalia-prompt-categories 1102 when (string-match-p regexp prompt) 1103 return category))) 1104 1105 (defun marginalia--cache-reset (&rest _) 1106 "Reset the cache." 1107 (setq marginalia--cache (and marginalia--cache (> marginalia--cache-size 0) 1108 (cons nil (make-hash-table :test #'equal 1109 :size marginalia--cache-size))))) 1110 1111 (defun marginalia--cached (cache fun key) 1112 "Cached application of function FUN with KEY. 1113 The CACHE keeps around the last `marginalia--cache-size' computed 1114 annotations. The cache is mainly useful when scrolling in 1115 completion UIs like Vertico or Icomplete." 1116 (if cache 1117 (let ((ht (cdr cache))) 1118 (or (gethash key ht) 1119 (let ((val (funcall fun key))) 1120 (push key (car cache)) 1121 (puthash key val ht) 1122 (when (>= (hash-table-count ht) marginalia--cache-size) 1123 (let ((end (last (car cache) 2))) 1124 (remhash (cadr end) ht) 1125 (setcdr end nil))) 1126 val))) 1127 (funcall fun key))) 1128 1129 (defun marginalia--align (cands) 1130 "Align annotations of CANDS according to `marginalia-align'." 1131 (cl-loop for (cand . ann) in cands do 1132 (when-let (align (text-property-any 0 (length ann) 'marginalia--align t ann)) 1133 (setq marginalia--candw-max 1134 (max marginalia--candw-max 1135 (+ (string-width cand) 1136 (string-width (substring ann 0 align))))))) 1137 (setq marginalia--candw-max (* (ceiling marginalia--candw-max 1138 marginalia--candw-step) 1139 marginalia--candw-step)) 1140 (cl-loop for (cand . ann) in cands collect 1141 (progn 1142 (when-let (align (text-property-any 0 (length ann) 'marginalia--align t ann)) 1143 (put-text-property 1144 align (1+ align) 'display 1145 `(space :align-to 1146 ,(pcase-exhaustive marginalia-align 1147 ('center `(+ center ,marginalia-align-offset)) 1148 ('left `(+ left ,(+ marginalia-align-offset marginalia--candw-max))) 1149 ('right `(+ right ,(+ marginalia-align-offset 1 1150 (- (string-width (substring ann 0 align)) 1151 (string-width ann))))))) 1152 ann)) 1153 (list cand "" ann)))) 1154 1155 (defun marginalia--affixate (metadata annotator cands) 1156 "Affixate CANDS given METADATA and Marginalia ANNOTATOR." 1157 ;; Compute minimum width of windows, which display the minibuffer. 1158 ;; vertico-buffer displays the minibuffer in different windows. We may want 1159 ;; to generalize this and detect other types of completion buffers, e.g., 1160 ;; Embark Collect or the default completion buffer. 1161 (let* ((width (cl-loop for win in (get-buffer-window-list) minimize (window-width win))) 1162 (marginalia-field-width (min (/ width 2) marginalia-field-width)) 1163 (marginalia--metadata metadata) 1164 (cache marginalia--cache)) 1165 (marginalia--align 1166 ;; Run the annotators in the original window. `with-selected-window' 1167 ;; is necessary because of `lookup-minor-mode-from-indicator'. 1168 ;; Otherwise it would suffice to only change the current buffer. We 1169 ;; need the `selected-window' fallback for Embark Occur. 1170 (with-selected-window (or (minibuffer-selected-window) (selected-window)) 1171 (cl-loop for cand in cands collect 1172 (let ((ann (or (marginalia--cached cache annotator cand) ""))) 1173 (cons cand (if (string-blank-p ann) "" ann)))))))) 1174 1175 (defun marginalia--completion-metadata-get (metadata prop) 1176 "Meant as :before-until advice for `completion-metadata-get'. 1177 METADATA is the metadata. 1178 PROP is the property which is looked up." 1179 (pcase prop 1180 ('annotation-function 1181 ;; We do want the advice triggered for `completion-metadata-get'. 1182 (when-let* ((cat (completion-metadata-get metadata 'category)) 1183 (annotator (marginalia--annotator cat))) 1184 (lambda (cand) 1185 (let ((ann (caddar (marginalia--affixate metadata annotator (list cand))))) 1186 (and (not (equal ann "")) ann))))) 1187 ('affixation-function 1188 ;; We do want the advice triggered for `completion-metadata-get'. 1189 (when-let* ((cat (completion-metadata-get metadata 'category)) 1190 (annotator (marginalia--annotator cat))) 1191 (apply-partially #'marginalia--affixate metadata annotator))) 1192 ('category 1193 ;; Find the completion category by trying each of our classifiers. 1194 ;; Store the metadata for `marginalia-classify-original-category'. 1195 (let ((marginalia--metadata metadata)) 1196 (run-hook-with-args-until-success 'marginalia-classifiers))))) 1197 1198 (defun marginalia--minibuffer-setup () 1199 "Setup the minibuffer for Marginalia. 1200 Remember `this-command' for `marginalia-classify-by-command-name'." 1201 (setq marginalia--cache t marginalia--command this-command) 1202 ;; Reset cache if window size changes, recompute alignment 1203 (add-hook 'window-state-change-hook #'marginalia--cache-reset nil 'local) 1204 (marginalia--cache-reset)) 1205 1206 (defun marginalia--base-position (completions) 1207 "Record the base position of COMPLETIONS." 1208 ;; NOTE: As a small optimization track the base position only for file completions, 1209 ;; since `marginalia--full-candidate' is only used for files as of now. 1210 (when minibuffer-completing-file-name 1211 (let ((base (or (cdr (last completions)) 0))) 1212 (unless (= marginalia--base-position base) 1213 (marginalia--cache-reset) 1214 (setq marginalia--base-position base)))) 1215 completions) 1216 1217 ;;;###autoload 1218 (define-minor-mode marginalia-mode 1219 "Annotate completion candidates with richer information." 1220 :global t :group 'marginalia 1221 (if marginalia-mode 1222 (progn 1223 ;; Ensure that we remember this-command in order to select the annotation function. 1224 (add-hook 'minibuffer-setup-hook #'marginalia--minibuffer-setup) 1225 ;; Replace the metadata function. 1226 (advice-add #'completion-metadata-get :before-until #'marginalia--completion-metadata-get) 1227 ;; Record completion base position, for marginalia--full-candidate 1228 (advice-add #'completion-all-completions :filter-return #'marginalia--base-position)) 1229 (advice-remove #'completion-all-completions #'marginalia--base-position) 1230 (advice-remove #'completion-metadata-get #'marginalia--completion-metadata-get) 1231 (remove-hook 'minibuffer-setup-hook #'marginalia--minibuffer-setup))) 1232 1233 ;;;###autoload 1234 (defun marginalia-cycle () 1235 "Cycle between annotators in `marginalia-annotator-registry'." 1236 (interactive) 1237 (if-let* ((win (active-minibuffer-window)) 1238 (buf (window-buffer win))) 1239 (with-current-buffer buf 1240 (let* ((pt (max 0 (- (point) (minibuffer-prompt-end)))) 1241 (metadata (completion-metadata (buffer-substring-no-properties 1242 (minibuffer-prompt-end) 1243 (+ (minibuffer-prompt-end) pt)) 1244 minibuffer-completion-table 1245 minibuffer-completion-predicate)) 1246 (cat (completion-metadata-get metadata 'category))) 1247 (unless cat 1248 (user-error "Marginalia: Unknown completion category")) 1249 (setq cat (assq cat marginalia-annotator-registry)) 1250 (unless cat 1251 (user-error "Marginalia: No annotators found")) 1252 (marginalia--cache-reset) 1253 (setcdr cat (append (cddr cat) (list (cadr cat)))) 1254 ;; When the builtin annotator is selected and no builtin function is available, skip to 1255 ;; the next annotator. Note that we cannot use `completion-metadata-get' to access the 1256 ;; metadata since we must bypass the `marginalia--completion-metadata-get' advice. 1257 (when (and (eq (cadr cat) 'builtin) 1258 (not (assq 'annotation-function metadata)) 1259 (not (assq 'affixation-function metadata)) 1260 (not (plist-get completion-extra-properties :annotation-function)) 1261 (not (plist-get completion-extra-properties :affixation-function))) 1262 (setcdr cat (append (cddr cat) (list (cadr cat))))) 1263 (message "Marginalia: Use annotator `%s' for category `%s'" (cadr cat) (car cat)))) 1264 (user-error "Marginalia: No active minibuffer"))) 1265 1266 (provide 'marginalia) 1267 ;;; marginalia.el ends here