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