vertico.el (35214B)
1 ;;; vertico.el --- VERTical Interactive COmpletion -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2021-2024 Free Software Foundation, Inc. 4 5 ;; Author: Daniel Mendler <mail@daniel-mendler.de> 6 ;; Maintainer: Daniel Mendler <mail@daniel-mendler.de> 7 ;; Created: 2021 8 ;; Package-Version: 20240926.924 9 ;; Package-Revision: 7741da042ddf 10 ;; Package-Requires: ((emacs "28.1") (compat "30")) 11 ;; URL: https://github.com/minad/vertico 12 ;; Keywords: convenience, files, 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 ;; Vertico provides a performant and minimalistic vertical completion UI 32 ;; based on the default completion system. By reusing the built-in 33 ;; facilities, Vertico achieves full compatibility with built-in Emacs 34 ;; completion commands and completion tables. 35 36 ;;; Code: 37 38 (require 'compat) 39 (eval-when-compile 40 (require 'cl-lib) 41 (require 'subr-x)) 42 43 (defgroup vertico nil 44 "VERTical Interactive COmpletion." 45 :link '(info-link :tag "Info Manual" "(vertico)") 46 :link '(url-link :tag "Website" "https://github.com/minad/vertico") 47 :link '(emacs-library-link :tag "Library Source" "vertico.el") 48 :group 'convenience 49 :group 'minibuffer 50 :prefix "vertico-") 51 52 (defcustom vertico-count-format (cons "%-6s " "%s/%s") 53 "Format string used for the candidate count." 54 :type '(choice (const :tag "No candidate count" nil) (cons string string))) 55 56 (defcustom vertico-group-format 57 (concat #(" " 0 4 (face vertico-group-separator)) 58 #(" %s " 0 4 (face vertico-group-title)) 59 #(" " 0 1 (face vertico-group-separator display (space :align-to right)))) 60 "Format string used for the group title." 61 :type '(choice (const :tag "No group titles" nil) string)) 62 63 (defcustom vertico-count 10 64 "Maximal number of candidates to show." 65 :type 'natnum) 66 67 (defcustom vertico-preselect 'directory 68 "Configure if the prompt or first candidate is preselected. 69 - prompt: Always select the prompt. 70 - first: Select the first candidate, allow prompt selection. 71 - no-prompt: Like first, but forbid selection of the prompt entirely. 72 - directory: Like first, but select the prompt if it is a directory." 73 :type '(choice (const prompt) (const first) (const no-prompt) (const directory))) 74 75 (defcustom vertico-scroll-margin 2 76 "Number of lines at the top and bottom when scrolling. 77 The value should lie between 0 and vertico-count/2." 78 :type 'natnum) 79 80 (defcustom vertico-resize resize-mini-windows 81 "How to resize the Vertico minibuffer window, see `resize-mini-windows'." 82 :type '(choice (const :tag "Fixed" nil) 83 (const :tag "Shrink and grow" t) 84 (const :tag "Grow-only" grow-only))) 85 86 (defcustom vertico-cycle nil 87 "Enable cycling for `vertico-next' and `vertico-previous'." 88 :type 'boolean) 89 90 (defcustom vertico-multiline 91 (cons #("↲" 0 1 (face vertico-multiline)) #("…" 0 1 (face vertico-multiline))) 92 "Replacements for multiline strings." 93 :type '(cons (string :tag "Newline") (string :tag "Truncation"))) 94 95 (defcustom vertico-sort-function #'vertico-sort-history-length-alpha 96 "Default sorting function, used if no `display-sort-function' is specified." 97 :type `(choice 98 (const :tag "No sorting" nil) 99 (const :tag "By history, length and alpha" ,#'vertico-sort-history-length-alpha) 100 (const :tag "By history and alpha" ,#'vertico-sort-history-alpha) 101 (const :tag "By length and alpha" ,#'vertico-sort-length-alpha) 102 (const :tag "Alphabetically" ,#'vertico-sort-alpha) 103 (function :tag "Custom function"))) 104 105 (defcustom vertico-sort-override-function nil 106 "Override sort function which overrides the `display-sort-function'." 107 :type '(choice (const nil) function)) 108 109 (defgroup vertico-faces nil 110 "Faces used by Vertico." 111 :group 'vertico 112 :group 'faces) 113 114 (defface vertico-multiline '((t :inherit shadow)) 115 "Face used to highlight multiline replacement characters.") 116 117 (defface vertico-group-title '((t :inherit shadow :slant italic)) 118 "Face used for the title text of the candidate group headlines.") 119 120 (defface vertico-group-separator '((t :inherit shadow :strike-through t)) 121 "Face used for the separator lines of the candidate groups.") 122 123 (defface vertico-current '((t :inherit highlight :extend t)) 124 "Face used to highlight the currently selected candidate.") 125 126 (defvar-keymap vertico-map 127 :doc "Vertico minibuffer keymap derived from `minibuffer-local-map'." 128 :parent minibuffer-local-map 129 "<remap> <beginning-of-buffer>" #'vertico-first 130 "<remap> <minibuffer-beginning-of-buffer>" #'vertico-first 131 "<remap> <end-of-buffer>" #'vertico-last 132 "<remap> <scroll-down-command>" #'vertico-scroll-down 133 "<remap> <scroll-up-command>" #'vertico-scroll-up 134 "<remap> <next-line>" #'vertico-next 135 "<remap> <previous-line>" #'vertico-previous 136 "<remap> <next-line-or-history-element>" #'vertico-next 137 "<remap> <previous-line-or-history-element>" #'vertico-previous 138 "<remap> <backward-paragraph>" #'vertico-previous-group 139 "<remap> <forward-paragraph>" #'vertico-next-group 140 "<remap> <exit-minibuffer>" #'vertico-exit 141 "<remap> <kill-ring-save>" #'vertico-save 142 "M-RET" #'vertico-exit-input 143 "TAB" #'vertico-insert) 144 145 (defvar-local vertico--hilit #'identity 146 "Lazy candidate highlighting function.") 147 148 (defvar-local vertico--history-hash nil 149 "History hash table and corresponding base string.") 150 151 (defvar-local vertico--candidates-ov nil 152 "Overlay showing the candidates.") 153 154 (defvar-local vertico--count-ov nil 155 "Overlay showing the number of candidates.") 156 157 (defvar-local vertico--index -1 158 "Index of current candidate or negative for prompt selection.") 159 160 (defvar-local vertico--scroll 0 161 "Scroll position.") 162 163 (defvar-local vertico--input nil 164 "Cons of last minibuffer contents and point or t.") 165 166 (defvar-local vertico--candidates nil 167 "List of candidates.") 168 169 (defvar-local vertico--metadata nil 170 "Completion metadata.") 171 172 (defvar-local vertico--base "" 173 "Base string, which is concatenated with the candidate.") 174 175 (defvar-local vertico--total 0 176 "Length of the candidate list `vertico--candidates'.") 177 178 (defvar-local vertico--lock-candidate nil 179 "Lock-in current candidate.") 180 181 (defvar-local vertico--lock-groups nil 182 "Lock-in current group order.") 183 184 (defvar-local vertico--all-groups nil 185 "List of all group titles.") 186 187 (defvar-local vertico--groups nil 188 "List of current group titles.") 189 190 (defvar-local vertico--allow-prompt nil 191 "Prompt selection is allowed.") 192 193 (defun vertico--history-hash () 194 "Recompute history hash table and return it." 195 (or (and (equal (car vertico--history-hash) vertico--base) (cdr vertico--history-hash)) 196 (let* ((base vertico--base) 197 (base-len (length base)) 198 (hist (and (not (eq minibuffer-history-variable t)) ;; Disabled for `t'. 199 (symbol-value minibuffer-history-variable))) 200 (hash (make-hash-table :test #'equal :size (length hist))) 201 (file-p (and (> base-len 0) ;; Step-wise completion, unlike `project-find-file' 202 (eq minibuffer-history-variable 'file-name-history))) 203 (curr-file (when-let ((win (and file-p (minibuffer-selected-window))) 204 (file (buffer-file-name (window-buffer win)))) 205 (abbreviate-file-name file)))) 206 (cl-loop for elem in hist for index from 0 do 207 (when (and (not (equal curr-file elem)) ;; Deprioritize current file 208 (or (= base-len 0) 209 (and (>= (length elem) base-len) 210 (eq t (compare-strings base 0 base-len elem 0 base-len))))) 211 (let ((file-sep (and file-p (string-search "/" elem base-len)))) 212 ;; Drop base string from history elements & special file handling. 213 (when (or (> base-len 0) file-sep) 214 (setq elem (substring elem base-len (and file-sep (1+ file-sep))))) 215 (unless (gethash elem hash) (puthash elem index hash))))) 216 (cdr (setq vertico--history-hash (cons base hash)))))) 217 218 (defun vertico--length-string< (x y) 219 "Sorting predicate which compares X and Y first by length then by `string<'." 220 (or (< (length x) (length y)) (and (= (length x) (length y)) (string< x y)))) 221 222 (defun vertico--sort-decorated (list) 223 "Sort decorated LIST and remove decorations." 224 (setq list (sort list #'car-less-than-car)) 225 (cl-loop for item on list do (setcar item (cdar item))) 226 list) 227 228 (defmacro vertico--define-sort (by bsize bindex bpred pred) 229 "Generate optimized sorting function. 230 The function is configured by BY, BSIZE, BINDEX, BPRED and PRED." 231 `(defun ,(intern (mapconcat #'symbol-name `(vertico sort ,@by) "-")) (candidates) 232 ,(concat "Sort candidates by " (mapconcat #'symbol-name by ", ") ".") 233 (let* ((buckets (make-vector ,bsize nil)) 234 ,@(and (eq (car by) 'history) '((hhash (vertico--history-hash)) (hcands)))) 235 (dolist (% candidates) 236 ;; Find recent candidate in history or fill bucket 237 (,@(if (not (eq (car by) 'history)) `(progn) 238 `(if-let ((idx (gethash % hhash))) (push (cons idx %) hcands))) 239 (let ((idx (min ,(1- bsize) ,bindex))) 240 (aset buckets idx (cons % (aref buckets idx)))))) 241 (nconc ,@(and (eq (car by) 'history) '((vertico--sort-decorated hcands))) 242 (mapcan (lambda (bucket) (sort bucket #',bpred)) 243 (nbutlast (append buckets nil))) 244 ;; Last bucket needs special treatment 245 (sort (aref buckets ,(1- bsize)) #',pred))))) 246 247 (vertico--define-sort (history length alpha) 32 (length %) string< vertico--length-string<) 248 (vertico--define-sort (history alpha) 32 (if (equal % "") 0 (/ (aref % 0) 4)) string< string<) 249 (vertico--define-sort (length alpha) 32 (length %) string< vertico--length-string<) 250 (vertico--define-sort (alpha) 32 (if (equal % "") 0 (/ (aref % 0) 4)) string< string<) 251 252 (defun vertico--affixate (cands) 253 "Annotate CANDS with annotation function." 254 (if-let ((aff (vertico--metadata-get 'affixation-function))) 255 (funcall aff cands) 256 (if-let ((ann (vertico--metadata-get 'annotation-function))) 257 (cl-loop for cand in cands collect 258 (let ((suff (or (funcall ann cand) ""))) 259 ;; The default completion UI adds the `completions-annotations' 260 ;; face if no other faces are present. 261 (unless (text-property-not-all 0 (length suff) 'face nil suff) 262 (setq suff (propertize suff 'face 'completions-annotations))) 263 (list cand "" suff))) 264 (cl-loop for cand in cands collect (list cand "" ""))))) 265 266 (defun vertico--move-to-front (elem list) 267 "Move ELEM to front of LIST." 268 (if-let ((found (member elem list))) ;; No duplicates, compare with Corfu. 269 (nconc (list (car found)) (delq (setcar found nil) list)) 270 list)) 271 272 (defun vertico--filter-completions (&rest args) 273 "Compute all completions for ARGS with lazy highlighting." 274 (dlet ((completion-lazy-hilit t) (completion-lazy-hilit-fn nil)) 275 (static-if (>= emacs-major-version 30) 276 (cons (apply #'completion-all-completions args) completion-lazy-hilit-fn) 277 (cl-letf* ((orig-pcm (symbol-function #'completion-pcm--hilit-commonality)) 278 (orig-flex (symbol-function #'completion-flex-all-completions)) 279 ((symbol-function #'completion-flex-all-completions) 280 (lambda (&rest args) 281 ;; Unfortunately for flex we have to undo the lazy highlighting, since flex uses 282 ;; the completion-score for sorting, which is applied during highlighting. 283 (cl-letf (((symbol-function #'completion-pcm--hilit-commonality) orig-pcm)) 284 (apply orig-flex args)))) 285 ((symbol-function #'completion-pcm--hilit-commonality) 286 (lambda (pattern cands) 287 (setq completion-lazy-hilit-fn 288 (lambda (x) 289 ;; `completion-pcm--hilit-commonality' sometimes throws an internal error 290 ;; for example when entering "/sudo:://u". 291 (condition-case nil 292 (car (completion-pcm--hilit-commonality pattern (list x))) 293 (t x)))) 294 cands)) 295 ((symbol-function #'completion-hilit-commonality) 296 (lambda (cands prefix &optional base) 297 (setq completion-lazy-hilit-fn 298 (lambda (x) (car (completion-hilit-commonality (list x) prefix base)))) 299 (and cands (nconc cands base))))) 300 (cons (apply #'completion-all-completions args) completion-lazy-hilit-fn))))) 301 302 (defun vertico--metadata-get (prop) 303 "Return PROP from completion metadata." 304 (compat-call completion-metadata-get vertico--metadata prop)) 305 306 (defun vertico--sort-function () 307 "Return the sorting function." 308 (or vertico-sort-override-function 309 (vertico--metadata-get 'display-sort-function) 310 vertico-sort-function)) 311 312 (defun vertico--recompute (pt content) 313 "Recompute state given PT and CONTENT." 314 (pcase-let* ((table minibuffer-completion-table) 315 (pred minibuffer-completion-predicate) 316 (before (substring content 0 pt)) 317 (after (substring content pt)) 318 ;; bug#47678: `completion-boundaries' fails for `partial-completion' 319 ;; if the cursor is moved before the slashes of "~//". 320 ;; See also corfu.el which has the same issue. 321 (bounds (condition-case nil 322 (completion-boundaries before table pred after) 323 (t (cons 0 (length after))))) 324 (field (substring content (car bounds) (+ pt (cdr bounds)))) 325 ;; `minibuffer-completing-file-name' has been obsoleted by the completion category 326 (completing-file (eq 'file (vertico--metadata-get 'category))) 327 (`(,all . ,hl) (vertico--filter-completions content table pred pt vertico--metadata)) 328 (base (or (when-let ((z (last all))) (prog1 (cdr z) (setcdr z nil))) 0)) 329 (vertico--base (substring content 0 base)) 330 (def (or (car-safe minibuffer-default) minibuffer-default)) 331 (groups) (def-missing) (lock)) 332 ;; Filter the ignored file extensions. We cannot use modified predicate for this filtering, 333 ;; since this breaks the special casing in the `completion-file-name-table' for `file-exists-p' 334 ;; and `file-directory-p'. 335 (when completing-file (setq all (completion-pcm--filename-try-filter all))) 336 ;; Sort using the `display-sort-function' or the Vertico sort functions 337 (setq all (delete-consecutive-dups (funcall (or (vertico--sort-function) #'identity) all))) 338 ;; Move special candidates: "field" appears at the top, before "field/", before default value 339 (when (stringp def) 340 (setq all (vertico--move-to-front def all))) 341 (when (and completing-file (not (string-suffix-p "/" field))) 342 (setq all (vertico--move-to-front (concat field "/") all))) 343 (setq all (vertico--move-to-front field all)) 344 (when-let ((fun (and all (vertico--metadata-get 'group-function)))) 345 (setq groups (vertico--group-by fun all) all (car groups))) 346 (setq def-missing (and def (equal content "") (not (member def all))) 347 lock (and vertico--lock-candidate ;; Locked position of old candidate. 348 (if (< vertico--index 0) -1 349 (seq-position all (nth vertico--index vertico--candidates))))) 350 `((vertico--base . ,vertico--base) 351 (vertico--metadata . ,vertico--metadata) 352 (vertico--candidates . ,all) 353 (vertico--total . ,(length all)) 354 (vertico--hilit . ,(or hl #'identity)) 355 (vertico--allow-prompt . ,(and (not (eq vertico-preselect 'no-prompt)) 356 (or def-missing (eq vertico-preselect 'prompt) 357 (memq minibuffer--require-match 358 '(nil confirm confirm-after-completion))))) 359 (vertico--lock-candidate . ,lock) 360 (vertico--groups . ,(cadr groups)) 361 (vertico--all-groups . ,(or (caddr groups) vertico--all-groups)) 362 (vertico--index . ,(or lock 363 (if (or def-missing (eq vertico-preselect 'prompt) (not all) 364 (and completing-file (eq vertico-preselect 'directory) 365 (= (length vertico--base) (length content)) 366 (test-completion content table pred))) 367 -1 0)))))) 368 369 (defun vertico--cycle (list n) 370 "Rotate LIST to position N." 371 (nconc (copy-sequence (nthcdr n list)) (seq-take list n))) 372 373 (defun vertico--group-by (fun elems) 374 "Group ELEMS by FUN." 375 (let ((ht (make-hash-table :test #'equal)) titles groups) 376 ;; Build hash table of groups 377 (cl-loop for elem on elems 378 for title = (funcall fun (car elem) nil) do 379 (if-let ((group (gethash title ht))) 380 (setcdr group (setcdr (cdr group) elem)) ;; Append to tail of group 381 (puthash title (cons elem elem) ht) ;; New group element (head . tail) 382 (push title titles))) 383 (setq titles (nreverse titles)) 384 ;; Cycle groups if `vertico--lock-groups' is set 385 (when-let ((vertico--lock-groups) 386 (group (seq-find (lambda (group) (gethash group ht)) 387 vertico--all-groups))) 388 (setq titles (vertico--cycle titles (seq-position titles group)))) 389 ;; Build group list 390 (dolist (title titles) 391 (push (gethash title ht) groups)) 392 ;; Unlink last tail 393 (setcdr (cdar groups) nil) 394 (setq groups (nreverse groups)) 395 ;; Link groups 396 (let ((link groups)) 397 (while (cdr link) 398 (setcdr (cdar link) (caadr link)) 399 (pop link))) 400 ;; Check if new groups are found 401 (dolist (group vertico--all-groups) 402 (remhash group ht)) 403 (list (caar groups) titles 404 (if (hash-table-empty-p ht) vertico--all-groups titles)))) 405 406 (defun vertico--remote-p (path) 407 "Return t if PATH is a remote path." 408 (string-match-p "\\`/[^/|:]+:" (substitute-in-file-name path))) 409 410 (defun vertico--update (&optional interruptible) 411 "Update state, optionally INTERRUPTIBLE." 412 (let* ((pt (max 0 (- (point) (minibuffer-prompt-end)))) 413 (content (minibuffer-contents-no-properties)) 414 (input (cons content pt))) 415 (unless (or (and interruptible (input-pending-p)) (equal vertico--input input)) 416 ;; Redisplay to make input immediately visible before expensive candidate 417 ;; recomputation (gh:minad/vertico#89). No redisplay during init because 418 ;; of flicker. 419 (when (and interruptible (consp vertico--input)) 420 ;; Prevent recursive exhibit from timer (`consult-vertico--refresh'). 421 (cl-letf (((symbol-function #'vertico--exhibit) #'ignore)) (redisplay))) 422 (pcase (let ((vertico--metadata (completion-metadata (substring content 0 pt) 423 minibuffer-completion-table 424 minibuffer-completion-predicate))) 425 ;; If Tramp is used, do not compute the candidates in an 426 ;; interruptible fashion, since this will break the Tramp 427 ;; password and user name prompts (See gh:minad/vertico#23). 428 (if (or (not interruptible) 429 (and (eq 'file (vertico--metadata-get 'category)) 430 (or (vertico--remote-p content) (vertico--remote-p default-directory)))) 431 (vertico--recompute pt content) 432 (let ((non-essential t)) 433 (while-no-input (vertico--recompute pt content))))) 434 ('nil (abort-recursive-edit)) 435 ((and state (pred consp)) 436 (setq vertico--input input) 437 (dolist (s state) (set (car s) (cdr s)))))))) 438 439 (defun vertico--display-string (str) 440 "Return display STR without display and invisible properties." 441 (let ((end (length str)) (pos 0) chunks) 442 (while (< pos end) 443 (let ((nextd (next-single-property-change pos 'display str end)) 444 (disp (get-text-property pos 'display str))) 445 (if (stringp disp) 446 (let ((face (get-text-property pos 'face str))) 447 (when face 448 (add-face-text-property 0 (length disp) face t (setq disp (concat disp)))) 449 (setq pos nextd chunks (cons disp chunks))) 450 (while (< pos nextd) 451 (let ((nexti (next-single-property-change pos 'invisible str nextd))) 452 (unless (or (get-text-property pos 'invisible str) 453 (and (= pos 0) (= nexti end))) ;; full string -> no allocation 454 (push (substring str pos nexti) chunks)) 455 (setq pos nexti)))))) 456 (if chunks (apply #'concat (nreverse chunks)) str))) 457 458 (defun vertico--window-width () 459 "Return minimum width of windows, which display the minibuffer." 460 (cl-loop for win in (get-buffer-window-list) minimize (window-width win))) 461 462 (defun vertico--truncate-multiline (str max) 463 "Truncate multiline STR to MAX." 464 (let ((pos 0) (res "")) 465 (while (and (< (length res) (* 2 max)) (string-match "\\(\\S-+\\)\\|\\s-+" str pos)) 466 (setq res (concat res (if (match-end 1) (match-string 0 str) 467 (if (string-search "\n" (match-string 0 str)) 468 (car vertico-multiline) " "))) 469 pos (match-end 0))) 470 (truncate-string-to-width (string-trim res) max 0 nil (cdr vertico-multiline)))) 471 472 (defun vertico--compute-scroll () 473 "Compute new scroll position." 474 (let ((off (max (min vertico-scroll-margin (/ vertico-count 2)) 0)) 475 (corr (if (= vertico-scroll-margin (/ vertico-count 2)) (1- (mod vertico-count 2)) 0))) 476 (setq vertico--scroll (min (max 0 (- vertico--total vertico-count)) 477 (max 0 (+ vertico--index off 1 (- vertico-count)) 478 (min (- vertico--index off corr) vertico--scroll)))))) 479 480 (defun vertico--format-group-title (title cand) 481 "Format group TITLE given the current CAND." 482 (when (string-prefix-p title cand) 483 ;; Highlight title if title is a prefix of the candidate 484 (setq cand (propertize cand 'face 'vertico-group-title) 485 title (substring (funcall vertico--hilit cand) 0 (length title))) 486 (vertico--remove-face 0 (length title) 'completions-first-difference title)) 487 (format (concat vertico-group-format "\n") title)) 488 489 (defun vertico--format-count () 490 "Format the count string." 491 (format (car vertico-count-format) 492 (format (cdr vertico-count-format) 493 (cond ((>= vertico--index 0) (1+ vertico--index)) 494 (vertico--allow-prompt "*") 495 (t "!")) 496 vertico--total))) 497 498 (defun vertico--display-count () 499 "Update count overlay `vertico--count-ov'." 500 (move-overlay vertico--count-ov (point-min) (point-min)) 501 (overlay-put vertico--count-ov 'before-string 502 (if vertico-count-format (vertico--format-count) ""))) 503 504 (defun vertico--prompt-selection () 505 "Highlight the prompt if selected." 506 (let ((inhibit-modification-hooks t)) 507 (if (and (< vertico--index 0) vertico--allow-prompt) 508 (add-face-text-property (minibuffer-prompt-end) (point-max) 'vertico-current 'append) 509 (vertico--remove-face (minibuffer-prompt-end) (point-max) 'vertico-current)))) 510 511 (defun vertico--remove-face (beg end face &optional obj) 512 "Remove FACE between BEG and END from OBJ." 513 (while (< beg end) 514 (let ((next (next-single-property-change beg 'face obj end))) 515 (when-let ((val (get-text-property beg 'face obj))) 516 (put-text-property beg next 'face (remq face (ensure-list val)) obj)) 517 (setq beg next)))) 518 519 (defun vertico--exhibit () 520 "Exhibit completion UI." 521 (let ((buffer-undo-list t)) ;; Overlays affect point position and undo list! 522 (vertico--update 'interruptible) 523 (vertico--prompt-selection) 524 (vertico--display-count) 525 (vertico--display-candidates (vertico--arrange-candidates)))) 526 527 (defun vertico--goto (index) 528 "Go to candidate with INDEX." 529 (setq vertico--index 530 (max (if (or vertico--allow-prompt (= 0 vertico--total)) -1 0) 531 (min index (1- vertico--total))) 532 vertico--lock-candidate (or (>= vertico--index 0) vertico--allow-prompt))) 533 534 (defun vertico--candidate (&optional hl) 535 "Return current candidate string with optional highlighting if HL is non-nil." 536 (let ((content (substring (or (car-safe vertico--input) (minibuffer-contents-no-properties))))) 537 (cond 538 ((>= vertico--index 0) 539 (let ((cand (substring (nth vertico--index vertico--candidates)))) 540 ;; XXX Drop the completions-common-part face which is added by the 541 ;; `completion--twq-all' hack. This should better be fixed in Emacs 542 ;; itself, the corresponding code is already marked as fixme. 543 (vertico--remove-face 0 (length cand) 'completions-common-part cand) 544 (concat vertico--base (if hl (funcall vertico--hilit cand) cand)))) 545 ((and (equal content "") (or (car-safe minibuffer-default) minibuffer-default))) 546 (t content)))) 547 548 (defun vertico--match-p (input) 549 "Return t if INPUT is a valid match." 550 (let ((rm minibuffer--require-match)) 551 (or (memq rm '(nil confirm-after-completion)) 552 (equal "" input) ;; Null completion, returns default value 553 (if (functionp rm) (funcall rm input) ;; Emacs 29 supports functions 554 (test-completion input minibuffer-completion-table minibuffer-completion-predicate)) 555 (if (eq rm 'confirm) (eq (ignore-errors (read-char "Confirm")) 13) 556 (minibuffer-message "Match required") nil)))) 557 558 (cl-defgeneric vertico--format-candidate (cand prefix suffix index _start) 559 "Format CAND given PREFIX, SUFFIX and INDEX." 560 (setq cand (vertico--display-string (concat prefix cand suffix "\n"))) 561 (when (= index vertico--index) 562 (add-face-text-property 0 (length cand) 'vertico-current 'append cand)) 563 cand) 564 565 (cl-defgeneric vertico--arrange-candidates () 566 "Arrange candidates." 567 (vertico--compute-scroll) 568 (let ((curr-line 0) lines) 569 ;; Compute group titles 570 (let* (title (index vertico--scroll) 571 (group-fun (and vertico-group-format (vertico--metadata-get 'group-function))) 572 (candidates 573 (vertico--affixate 574 (cl-loop repeat vertico-count for c in (nthcdr index vertico--candidates) 575 collect (funcall vertico--hilit (substring c)))))) 576 (pcase-dolist ((and cand `(,str . ,_)) candidates) 577 (when-let ((new-title (and group-fun (funcall group-fun str nil)))) 578 (unless (equal title new-title) 579 (setq title new-title) 580 (push (vertico--format-group-title title str) lines)) 581 (setcar cand (funcall group-fun str 'transform))) 582 (when (= index vertico--index) 583 (setq curr-line (length lines))) 584 (push (cons index cand) lines) 585 (cl-incf index))) 586 ;; Drop excess lines 587 (setq lines (nreverse lines)) 588 (cl-loop for count from (length lines) above vertico-count do 589 (if (< curr-line (/ count 2)) 590 (nbutlast lines) 591 (setq curr-line (1- curr-line) lines (cdr lines)))) 592 ;; Format candidates 593 (let ((max-width (- (vertico--window-width) 4)) start) 594 (cl-loop for line on lines do 595 (pcase (car line) 596 (`(,index ,cand ,prefix ,suffix) 597 (setq start (or start index)) 598 (when (string-search "\n" cand) 599 (setq cand (vertico--truncate-multiline cand max-width))) 600 (setcar line (vertico--format-candidate cand prefix suffix index start)))))) 601 lines)) 602 603 (cl-defgeneric vertico--display-candidates (lines) 604 "Update candidates overlay `vertico--candidates-ov' with LINES." 605 (move-overlay vertico--candidates-ov (point-max) (point-max)) 606 (overlay-put vertico--candidates-ov 'after-string 607 (apply #'concat #(" " 0 1 (cursor t)) (and lines "\n") lines)) 608 (vertico--resize-window (length lines))) 609 610 (cl-defgeneric vertico--resize-window (height) 611 "Resize active minibuffer window to HEIGHT." 612 (setq-local truncate-lines (< (point) (* 0.8 (vertico--window-width))) 613 resize-mini-windows 'grow-only 614 max-mini-window-height 1.0) 615 (unless truncate-lines (set-window-hscroll nil 0)) 616 (unless (frame-root-window-p (active-minibuffer-window)) 617 (unless vertico-resize (setq height (max height vertico-count))) 618 (let ((dp (- (max (cdr (window-text-pixel-size)) 619 (* (default-line-height) (1+ height))) 620 (window-pixel-height)))) 621 (when (or (and (> dp 0) (/= height 0)) 622 (and (< dp 0) (eq vertico-resize t))) 623 (window-resize nil dp nil nil 'pixelwise))))) 624 625 (cl-defgeneric vertico--prepare () 626 "Ensure that the state is prepared before running the next command." 627 (when (and (symbolp this-command) (string-prefix-p "vertico-" (symbol-name this-command))) 628 (vertico--update))) 629 630 (cl-defgeneric vertico--setup () 631 "Setup completion UI." 632 (setq-local scroll-margin 0 633 vertico--input t 634 completion-auto-help nil 635 completion-show-inline-help nil 636 vertico--candidates-ov (make-overlay (point-max) (point-max) nil t t) 637 vertico--count-ov (make-overlay (point-min) (point-min) nil t t)) 638 (overlay-put vertico--count-ov 'priority 1) ;; For `minibuffer-depth-indicate-mode' 639 (use-local-map vertico-map) 640 (add-hook 'pre-command-hook #'vertico--prepare nil 'local) 641 (add-hook 'post-command-hook #'vertico--exhibit nil 'local)) 642 643 (cl-defgeneric vertico--advice (&rest app) 644 "Advice for completion function, apply APP." 645 (minibuffer-with-setup-hook #'vertico--setup (apply app))) 646 647 (defun vertico-first () 648 "Go to first candidate, or to the prompt when the first candidate is selected." 649 (interactive) 650 (vertico--goto (if (> vertico--index 0) 0 -1))) 651 652 (defun vertico-last () 653 "Go to last candidate." 654 (interactive) 655 (vertico--goto (1- vertico--total))) 656 657 (defun vertico-scroll-down (&optional n) 658 "Go back by N pages." 659 (interactive "p") 660 (vertico--goto (max 0 (- vertico--index (* (or n 1) vertico-count))))) 661 662 (defun vertico-scroll-up (&optional n) 663 "Go forward by N pages." 664 (interactive "p") 665 (vertico-scroll-down (- (or n 1)))) 666 667 (defun vertico-next (&optional n) 668 "Go forward N candidates." 669 (interactive "p") 670 (let ((index (+ vertico--index (or n 1)))) 671 (vertico--goto 672 (cond 673 ((not vertico-cycle) index) 674 ((= vertico--total 0) -1) 675 (vertico--allow-prompt (1- (mod (1+ index) (1+ vertico--total)))) 676 (t (mod index vertico--total)))))) 677 678 (defun vertico-previous (&optional n) 679 "Go backward N candidates." 680 (interactive "p") 681 (vertico-next (- (or n 1)))) 682 683 (defun vertico-exit (&optional arg) 684 "Exit minibuffer with current candidate or input if prefix ARG is given." 685 (interactive "P") 686 (when (and (not arg) (>= vertico--index 0)) 687 (vertico-insert)) 688 (when (vertico--match-p (minibuffer-contents-no-properties)) 689 (exit-minibuffer))) 690 691 (defun vertico-next-group (&optional n) 692 "Cycle N groups forward. 693 When the prefix argument is 0, the group order is reset." 694 (interactive "p") 695 (when (cdr vertico--groups) 696 (if (setq vertico--lock-groups (not (eq n 0))) 697 (setq vertico--groups (vertico--cycle vertico--groups 698 (let ((len (length vertico--groups))) 699 (- len (mod (- (or n 1)) len)))) 700 vertico--all-groups (vertico--cycle vertico--all-groups 701 (seq-position vertico--all-groups 702 (car vertico--groups)))) 703 (setq vertico--groups nil 704 vertico--all-groups nil)) 705 (setq vertico--lock-candidate nil 706 vertico--input nil))) 707 708 (defun vertico-previous-group (&optional n) 709 "Cycle N groups backward. 710 When the prefix argument is 0, the group order is reset." 711 (interactive "p") 712 (vertico-next-group (- (or n 1)))) 713 714 (defun vertico-exit-input () 715 "Exit minibuffer with input." 716 (interactive) 717 (vertico-exit t)) 718 719 (defun vertico-save () 720 "Save current candidate to kill ring." 721 (interactive) 722 (if (or (use-region-p) (not transient-mark-mode)) 723 (call-interactively #'kill-ring-save) 724 (kill-new (vertico--candidate)))) 725 726 (defun vertico-insert () 727 "Insert current candidate in minibuffer." 728 (interactive) 729 ;; XXX There is a small bug here, depending on interpretation. When completing 730 ;; "~/emacs/master/li|/calc" where "|" is the cursor, then the returned 731 ;; candidate only includes the prefix "~/emacs/master/lisp/", but not the 732 ;; suffix "/calc". Default completion has the same problem when selecting in 733 ;; the *Completions* buffer. See bug#48356. 734 (when (> vertico--total 0) 735 (let ((vertico--index (max 0 vertico--index))) 736 (insert (prog1 (vertico--candidate) (delete-minibuffer-contents)))))) 737 738 ;;;###autoload 739 (define-minor-mode vertico-mode 740 "VERTical Interactive COmpletion." 741 :global t :group 'vertico 742 (dolist (fun '(completing-read-default completing-read-multiple)) 743 (if vertico-mode 744 (advice-add fun :around #'vertico--advice) 745 (advice-remove fun #'vertico--advice)))) 746 747 (defun vertico--command-p (_sym buffer) 748 "Return non-nil if Vertico is active in BUFFER." 749 (buffer-local-value 'vertico--input buffer)) 750 751 ;; Do not show Vertico commands in M-X 752 (dolist (sym '(vertico-next vertico-next-group vertico-previous vertico-previous-group 753 vertico-scroll-down vertico-scroll-up vertico-exit vertico-insert 754 vertico-exit-input vertico-save vertico-first vertico-last 755 vertico-repeat-previous ;; autoloads in vertico-repeat.el 756 vertico-quick-jump vertico-quick-exit vertico-quick-insert ;; autoloads in vertico-quick.el 757 vertico-directory-up vertico-directory-enter ;; autoloads in vertico-directory.el 758 vertico-directory-delete-char vertico-directory-delete-word)) 759 (put sym 'completion-predicate #'vertico--command-p)) 760 761 (provide 'vertico) 762 ;;; vertico.el ends here