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