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