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