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