vertico.el (35008B)
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.8 9 ;; Package-Requires: ((emacs "27.1") (compat "29.1.4.4")) 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 (or (vertico--metadata-get 'affixation-function) 254 (plist-get completion-extra-properties :affixation-function)))) 255 (funcall aff cands) 256 (if-let ((ann (or (vertico--metadata-get 'annotation-function) 257 (plist-get completion-extra-properties :annotation-function)))) 258 (cl-loop for cand in cands collect 259 (let ((suff (or (funcall ann cand) ""))) 260 ;; The default completion UI adds the `completions-annotations' 261 ;; face if no other faces are present. 262 (unless (text-property-not-all 0 (length suff) 'face nil suff) 263 (setq suff (propertize suff 'face 'completions-annotations))) 264 (list cand "" suff))) 265 (cl-loop for cand in cands collect (list cand "" ""))))) 266 267 (defun vertico--move-to-front (elem list) 268 "Move ELEM to front of LIST." 269 (if-let ((found (member elem list))) ;; No duplicates, compare with Corfu. 270 (nconc (list (car found)) (delq (setcar found nil) list)) 271 list)) 272 273 (defun vertico--filter-completions (&rest args) 274 "Compute all completions for ARGS with lazy highlighting." 275 (dlet ((completion-lazy-hilit t) (completion-lazy-hilit-fn nil)) 276 (if (eval-when-compile (>= emacs-major-version 30)) 277 (cons (apply #'completion-all-completions args) completion-lazy-hilit-fn) 278 (cl-letf* ((orig-pcm (symbol-function #'completion-pcm--hilit-commonality)) 279 (orig-flex (symbol-function #'completion-flex-all-completions)) 280 ((symbol-function #'completion-flex-all-completions) 281 (lambda (&rest args) 282 ;; Unfortunately for flex we have to undo the lazy highlighting, since flex uses 283 ;; the completion-score for sorting, which is applied during highlighting. 284 (cl-letf (((symbol-function #'completion-pcm--hilit-commonality) orig-pcm)) 285 (apply orig-flex args)))) 286 ((symbol-function #'completion-pcm--hilit-commonality) 287 (lambda (pattern cands) 288 (setq completion-lazy-hilit-fn 289 (lambda (x) 290 ;; `completion-pcm--hilit-commonality' sometimes throws an internal error 291 ;; for example when entering "/sudo:://u". 292 (condition-case nil 293 (car (completion-pcm--hilit-commonality pattern (list x))) 294 (t x)))) 295 cands)) 296 ((symbol-function #'completion-hilit-commonality) 297 (lambda (cands prefix &optional base) 298 (setq completion-lazy-hilit-fn 299 (lambda (x) (car (completion-hilit-commonality (list x) prefix base)))) 300 (and cands (nconc cands base))))) 301 (cons (apply #'completion-all-completions args) completion-lazy-hilit-fn))))) 302 303 (defun vertico--metadata-get (prop) 304 "Return PROP from completion metadata." 305 (completion-metadata-get vertico--metadata prop)) 306 307 (defun vertico--sort-function () 308 "Return the sorting function." 309 (or vertico-sort-override-function 310 (vertico--metadata-get 'display-sort-function) 311 vertico-sort-function)) 312 313 (defun vertico--recompute (pt content) 314 "Recompute state given PT and CONTENT." 315 (pcase-let* ((table minibuffer-completion-table) 316 (pred minibuffer-completion-predicate) 317 (before (substring content 0 pt)) 318 (after (substring content pt)) 319 ;; bug#47678: `completion-boundaries' fails for `partial-completion' 320 ;; if the cursor is moved between the slashes of "~//". 321 ;; See also corfu.el which has the same issue. 322 (bounds (condition-case nil 323 (completion-boundaries before table pred after) 324 (t (cons 0 (length after))))) 325 (field (substring content (car bounds) (+ pt (cdr bounds)))) 326 ;; `minibuffer-completing-file-name' has been obsoleted by the completion category 327 (completing-file (eq 'file (vertico--metadata-get 'category))) 328 (`(,all . ,hl) (vertico--filter-completions content table pred pt vertico--metadata)) 329 (base (or (when-let ((z (last all))) (prog1 (cdr z) (setcdr z nil))) 0)) 330 (vertico--base (substring content 0 base)) 331 (def (or (car-safe minibuffer-default) minibuffer-default)) 332 (groups) (def-missing) (lock)) 333 ;; Filter the ignored file extensions. We cannot use modified predicate for this filtering, 334 ;; since this breaks the special casing in the `completion-file-name-table' for `file-exists-p' 335 ;; and `file-directory-p'. 336 (when completing-file (setq all (completion-pcm--filename-try-filter all))) 337 ;; Sort using the `display-sort-function' or the Vertico sort functions 338 (setq all (delete-consecutive-dups (funcall (or (vertico--sort-function) #'identity) all))) 339 ;; Move special candidates: "field" appears at the top, before "field/", before default value 340 (when (stringp def) 341 (setq all (vertico--move-to-front def all))) 342 (when (and completing-file (not (string-suffix-p "/" field))) 343 (setq all (vertico--move-to-front (concat field "/") all))) 344 (setq all (vertico--move-to-front field all)) 345 (when-let ((fun (and all (vertico--metadata-get 'group-function)))) 346 (setq groups (vertico--group-by fun all) all (car groups))) 347 (setq def-missing (and def (equal content "") (not (member def all))) 348 lock (and vertico--lock-candidate ;; Locked position of old candidate. 349 (if (< vertico--index 0) -1 350 (seq-position all (nth vertico--index vertico--candidates))))) 351 `((vertico--base . ,vertico--base) 352 (vertico--metadata . ,vertico--metadata) 353 (vertico--candidates . ,all) 354 (vertico--total . ,(length all)) 355 (vertico--hilit . ,(or hl #'identity)) 356 (vertico--allow-prompt . ,(and (not (eq vertico-preselect 'no-prompt)) 357 (or def-missing (eq vertico-preselect 'prompt) 358 (memq minibuffer--require-match 359 '(nil confirm confirm-after-completion))))) 360 (vertico--lock-candidate . ,lock) 361 (vertico--groups . ,(cadr groups)) 362 (vertico--all-groups . ,(or (caddr groups) vertico--all-groups)) 363 (vertico--index . ,(or lock 364 (if (or def-missing (eq vertico-preselect 'prompt) (not all) 365 (and completing-file (eq vertico-preselect 'directory) 366 (= (length vertico--base) (length content)) 367 (test-completion content table pred))) 368 -1 0)))))) 369 370 (defun vertico--cycle (list n) 371 "Rotate LIST to position N." 372 (nconc (copy-sequence (nthcdr n list)) (seq-take list n))) 373 374 (defun vertico--group-by (fun elems) 375 "Group ELEMS by FUN." 376 (let ((ht (make-hash-table :test #'equal)) titles groups) 377 ;; Build hash table of groups 378 (cl-loop for elem on elems 379 for title = (funcall fun (car elem) nil) do 380 (if-let ((group (gethash title ht))) 381 (setcdr group (setcdr (cdr group) elem)) ;; Append to tail of group 382 (puthash title (cons elem elem) ht) ;; New group element (head . tail) 383 (push title titles))) 384 (setq titles (nreverse titles)) 385 ;; Cycle groups if `vertico--lock-groups' is set 386 (when-let ((vertico--lock-groups) 387 (group (seq-find (lambda (group) (gethash group ht)) 388 vertico--all-groups))) 389 (setq titles (vertico--cycle titles (seq-position titles group)))) 390 ;; Build group list 391 (dolist (title titles) 392 (push (gethash title ht) groups)) 393 ;; Unlink last tail 394 (setcdr (cdar groups) nil) 395 (setq groups (nreverse groups)) 396 ;; Link groups 397 (let ((link groups)) 398 (while (cdr link) 399 (setcdr (cdar link) (caadr link)) 400 (pop link))) 401 ;; Check if new groups are found 402 (dolist (group vertico--all-groups) 403 (remhash group ht)) 404 (list (caar groups) titles 405 (if (hash-table-empty-p ht) vertico--all-groups titles)))) 406 407 (defun vertico--remote-p (path) 408 "Return t if PATH is a remote path." 409 (string-match-p "\\`/[^/|:]+:" (substitute-in-file-name path))) 410 411 (defun vertico--update (&optional interruptible) 412 "Update state, optionally INTERRUPTIBLE." 413 (let* ((pt (max 0 (- (point) (minibuffer-prompt-end)))) 414 (content (minibuffer-contents-no-properties)) 415 (input (cons content pt))) 416 (unless (or (and interruptible (input-pending-p)) (equal vertico--input input)) 417 ;; Redisplay to make input immediately visible before expensive candidate 418 ;; recomputation (gh:minad/vertico#89). No redisplay during init because 419 ;; of flicker. 420 (when (and interruptible (consp vertico--input)) 421 ;; Prevent recursive exhibit from timer (`consult-vertico--refresh'). 422 (cl-letf (((symbol-function #'vertico--exhibit) #'ignore)) (redisplay))) 423 (pcase (let ((vertico--metadata (completion-metadata (substring content 0 pt) 424 minibuffer-completion-table 425 minibuffer-completion-predicate))) 426 ;; If Tramp is used, do not compute the candidates in an 427 ;; interruptible fashion, since this will break the Tramp 428 ;; password and user name prompts (See gh:minad/vertico#23). 429 (if (or (not interruptible) 430 (and (eq 'file (vertico--metadata-get 'category)) 431 (or (vertico--remote-p content) (vertico--remote-p default-directory)))) 432 (vertico--recompute pt content) 433 (let ((non-essential t)) 434 (while-no-input (vertico--recompute pt content))))) 435 ('nil (abort-recursive-edit)) 436 ((and state (pred consp)) 437 (setq vertico--input input) 438 (dolist (s state) (set (car s) (cdr s)))))))) 439 440 (defun vertico--display-string (str) 441 "Return display STR without display and invisible properties." 442 (let ((end (length str)) (pos 0) chunks) 443 (while (< pos end) 444 (let ((nextd (next-single-property-change pos 'display str end)) 445 (disp (get-text-property pos 'display str))) 446 (if (stringp disp) 447 (let ((face (get-text-property pos 'face str))) 448 (when face 449 (add-face-text-property 0 (length disp) face t (setq disp (concat disp)))) 450 (setq pos nextd chunks (cons disp chunks))) 451 (while (< pos nextd) 452 (let ((nexti (next-single-property-change pos 'invisible str nextd))) 453 (unless (or (get-text-property pos 'invisible str) 454 (and (= pos 0) (= nexti end))) ;; full string -> no allocation 455 (push (substring str pos nexti) chunks)) 456 (setq pos nexti)))))) 457 (if chunks (apply #'concat (nreverse chunks)) str))) 458 459 (defun vertico--window-width () 460 "Return minimum width of windows, which display the minibuffer." 461 (cl-loop for win in (get-buffer-window-list) minimize (window-width win))) 462 463 (defun vertico--truncate-multiline (str max) 464 "Truncate multiline STR to MAX." 465 (let ((pos 0) (res "")) 466 (while (and (< (length res) (* 2 max)) (string-match "\\(\\S-+\\)\\|\\s-+" str pos)) 467 (setq res (concat res (if (match-end 1) (match-string 0 str) 468 (if (string-search "\n" (match-string 0 str)) 469 (car vertico-multiline) " "))) 470 pos (match-end 0))) 471 (truncate-string-to-width (string-trim res) max 0 nil (cdr vertico-multiline)))) 472 473 (defun vertico--compute-scroll () 474 "Compute new scroll position." 475 (let ((off (max (min vertico-scroll-margin (/ vertico-count 2)) 0)) 476 (corr (if (= vertico-scroll-margin (/ vertico-count 2)) (1- (mod vertico-count 2)) 0))) 477 (setq vertico--scroll (min (max 0 (- vertico--total vertico-count)) 478 (max 0 (+ vertico--index off 1 (- vertico-count)) 479 (min (- vertico--index off corr) vertico--scroll)))))) 480 481 (defun vertico--format-group-title (title cand) 482 "Format group TITLE given the current CAND." 483 (when (string-prefix-p title cand) 484 ;; Highlight title if title is a prefix of the candidate 485 (setq cand (propertize cand 'face 'vertico-group-title) 486 title (substring (funcall vertico--hilit cand) 0 (length title))) 487 (vertico--remove-face 0 (length title) 'completions-first-difference title)) 488 (format (concat vertico-group-format "\n") title)) 489 490 (defun vertico--format-count () 491 "Format the count string." 492 (format (car vertico-count-format) 493 (format (cdr vertico-count-format) 494 (cond ((>= vertico--index 0) (1+ vertico--index)) 495 (vertico--allow-prompt "*") 496 (t "!")) 497 vertico--total))) 498 499 (defun vertico--display-count () 500 "Update count overlay `vertico--count-ov'." 501 (move-overlay vertico--count-ov (point-min) (point-min)) 502 (overlay-put vertico--count-ov 'before-string 503 (if vertico-count-format (vertico--format-count) ""))) 504 505 (defun vertico--prompt-selection () 506 "Highlight the prompt if selected." 507 (let ((inhibit-modification-hooks t)) 508 (if (and (< vertico--index 0) vertico--allow-prompt) 509 (add-face-text-property (minibuffer-prompt-end) (point-max) 'vertico-current 'append) 510 (vertico--remove-face (minibuffer-prompt-end) (point-max) 'vertico-current)))) 511 512 (defun vertico--remove-face (beg end face &optional obj) 513 "Remove FACE between BEG and END from OBJ." 514 (while (< beg end) 515 (let ((next (next-single-property-change beg 'face obj end))) 516 (when-let ((val (get-text-property beg 'face obj))) 517 (put-text-property beg next 'face (remq face (ensure-list val)) obj)) 518 (setq beg next)))) 519 520 (defun vertico--exhibit () 521 "Exhibit completion UI." 522 (let ((buffer-undo-list t)) ;; Overlays affect point position and undo list! 523 (vertico--update 'interruptible) 524 (vertico--prompt-selection) 525 (vertico--display-count) 526 (vertico--display-candidates (vertico--arrange-candidates)))) 527 528 (defun vertico--goto (index) 529 "Go to candidate with INDEX." 530 (setq vertico--index 531 (max (if (or vertico--allow-prompt (= 0 vertico--total)) -1 0) 532 (min index (1- vertico--total))) 533 vertico--lock-candidate (or (>= vertico--index 0) vertico--allow-prompt))) 534 535 (defun vertico--candidate (&optional hl) 536 "Return current candidate string with optional highlighting if HL is non-nil." 537 (let ((content (substring (or (car-safe vertico--input) (minibuffer-contents-no-properties))))) 538 (cond 539 ((>= vertico--index 0) 540 (let ((cand (substring (nth vertico--index vertico--candidates)))) 541 ;; XXX Drop the completions-common-part face which is added by the 542 ;; `completion--twq-all' hack. This should better be fixed in Emacs 543 ;; itself, the corresponding code is already marked as fixme. 544 (vertico--remove-face 0 (length cand) 'completions-common-part cand) 545 (concat vertico--base (if hl (funcall vertico--hilit cand) cand)))) 546 ((and (equal content "") (or (car-safe minibuffer-default) minibuffer-default))) 547 (t content)))) 548 549 (defun vertico--match-p (input) 550 "Return t if INPUT is a valid match." 551 (let ((rm minibuffer--require-match)) 552 (or (memq rm '(nil confirm-after-completion)) 553 (equal "" input) ;; Null completion, returns default value 554 (and (functionp rm) (funcall rm input)) ;; Emacs 29 supports functions 555 (test-completion input minibuffer-completion-table minibuffer-completion-predicate) 556 (if (eq rm 'confirm) (eq (ignore-errors (read-char "Confirm")) 13) 557 (minibuffer-message "Match required") nil)))) 558 559 (cl-defgeneric vertico--format-candidate (cand prefix suffix index _start) 560 "Format CAND given PREFIX, SUFFIX and INDEX." 561 (setq cand (vertico--display-string (concat prefix cand suffix "\n"))) 562 (when (= index vertico--index) 563 (add-face-text-property 0 (length cand) 'vertico-current 'append cand)) 564 cand) 565 566 (cl-defgeneric vertico--arrange-candidates () 567 "Arrange candidates." 568 (vertico--compute-scroll) 569 (let ((curr-line 0) lines) 570 ;; Compute group titles 571 (let* (title (index vertico--scroll) 572 (group-fun (and vertico-group-format (vertico--metadata-get 'group-function))) 573 (candidates 574 (vertico--affixate 575 (cl-loop repeat vertico-count for c in (nthcdr index vertico--candidates) 576 collect (funcall vertico--hilit (substring c)))))) 577 (pcase-dolist ((and cand `(,str . ,_)) candidates) 578 (when-let ((new-title (and group-fun (funcall group-fun str nil)))) 579 (unless (equal title new-title) 580 (setq title new-title) 581 (push (vertico--format-group-title title str) lines)) 582 (setcar cand (funcall group-fun str 'transform))) 583 (when (= index vertico--index) 584 (setq curr-line (length lines))) 585 (push (cons index cand) lines) 586 (cl-incf index))) 587 ;; Drop excess lines 588 (setq lines (nreverse lines)) 589 (cl-loop for count from (length lines) above vertico-count do 590 (if (< curr-line (/ count 2)) 591 (nbutlast lines) 592 (setq curr-line (1- curr-line) lines (cdr lines)))) 593 ;; Format candidates 594 (let ((max-width (- (vertico--window-width) 4)) start) 595 (cl-loop for line on lines do 596 (pcase (car line) 597 (`(,index ,cand ,prefix ,suffix) 598 (setq start (or start index)) 599 (when (string-search "\n" cand) 600 (setq cand (vertico--truncate-multiline cand max-width))) 601 (setcar line (vertico--format-candidate cand prefix suffix index start)))))) 602 lines)) 603 604 (cl-defgeneric vertico--display-candidates (lines) 605 "Update candidates overlay `vertico--candidates-ov' with LINES." 606 (move-overlay vertico--candidates-ov (point-max) (point-max)) 607 (overlay-put vertico--candidates-ov 'after-string 608 (apply #'concat #(" " 0 1 (cursor t)) (and lines "\n") lines)) 609 (vertico--resize-window (length lines))) 610 611 (cl-defgeneric vertico--resize-window (height) 612 "Resize active minibuffer window to HEIGHT." 613 (setq-local truncate-lines (< (point) (* 0.8 (vertico--window-width))) 614 resize-mini-windows 'grow-only 615 max-mini-window-height 1.0) 616 (unless truncate-lines (set-window-hscroll nil 0)) 617 (unless (frame-root-window-p (active-minibuffer-window)) 618 (unless vertico-resize (setq height (max height vertico-count))) 619 (let ((dp (- (max (cdr (window-text-pixel-size)) 620 (* (default-line-height) (1+ height))) 621 (window-pixel-height)))) 622 (when (or (and (> dp 0) (/= height 0)) 623 (and (< dp 0) (eq vertico-resize t))) 624 (window-resize nil dp nil nil 'pixelwise))))) 625 626 (cl-defgeneric vertico--prepare () 627 "Ensure that the state is prepared before running the next command." 628 (when (and (symbolp this-command) (string-prefix-p "vertico-" (symbol-name this-command))) 629 (vertico--update))) 630 631 (cl-defgeneric vertico--setup () 632 "Setup completion UI." 633 (setq-local scroll-margin 0 634 vertico--input t 635 completion-auto-help nil 636 completion-show-inline-help nil 637 vertico--candidates-ov (make-overlay (point-max) (point-max) nil t t) 638 vertico--count-ov (make-overlay (point-min) (point-min) nil t t)) 639 (overlay-put vertico--count-ov 'priority 1) ;; For `minibuffer-depth-indicate-mode' 640 (use-local-map vertico-map) 641 (add-hook 'pre-command-hook #'vertico--prepare nil 'local) 642 (add-hook 'post-command-hook #'vertico--exhibit nil 'local)) 643 644 (cl-defgeneric vertico--advice (&rest app) 645 "Advice for completion function, apply APP." 646 (minibuffer-with-setup-hook #'vertico--setup (apply app))) 647 648 (defun vertico-first () 649 "Go to first candidate, or to the prompt when the first candidate is selected." 650 (interactive) 651 (vertico--goto (if (> vertico--index 0) 0 -1))) 652 653 (defun vertico-last () 654 "Go to last candidate." 655 (interactive) 656 (vertico--goto (1- vertico--total))) 657 658 (defun vertico-scroll-down (&optional n) 659 "Go back by N pages." 660 (interactive "p") 661 (vertico--goto (max 0 (- vertico--index (* (or n 1) vertico-count))))) 662 663 (defun vertico-scroll-up (&optional n) 664 "Go forward by N pages." 665 (interactive "p") 666 (vertico-scroll-down (- (or n 1)))) 667 668 (defun vertico-next (&optional n) 669 "Go forward N candidates." 670 (interactive "p") 671 (let ((index (+ vertico--index (or n 1)))) 672 (vertico--goto 673 (cond 674 ((not vertico-cycle) index) 675 ((= vertico--total 0) -1) 676 (vertico--allow-prompt (1- (mod (1+ index) (1+ vertico--total)))) 677 (t (mod index vertico--total)))))) 678 679 (defun vertico-previous (&optional n) 680 "Go backward N candidates." 681 (interactive "p") 682 (vertico-next (- (or n 1)))) 683 684 (defun vertico-exit (&optional arg) 685 "Exit minibuffer with current candidate or input if prefix ARG is given." 686 (interactive "P") 687 (when (and (not arg) (>= vertico--index 0)) 688 (vertico-insert)) 689 (when (vertico--match-p (minibuffer-contents-no-properties)) 690 (exit-minibuffer))) 691 692 (defun vertico-next-group (&optional n) 693 "Cycle N groups forward. 694 When the prefix argument is 0, the group order is reset." 695 (interactive "p") 696 (when (cdr vertico--groups) 697 (if (setq vertico--lock-groups (not (eq n 0))) 698 (setq vertico--groups (vertico--cycle vertico--groups 699 (let ((len (length vertico--groups))) 700 (- len (mod (- (or n 1)) len)))) 701 vertico--all-groups (vertico--cycle vertico--all-groups 702 (seq-position vertico--all-groups 703 (car vertico--groups)))) 704 (setq vertico--groups nil 705 vertico--all-groups nil)) 706 (setq vertico--lock-candidate nil 707 vertico--input nil))) 708 709 (defun vertico-previous-group (&optional n) 710 "Cycle N groups backward. 711 When the prefix argument is 0, the group order is reset." 712 (interactive "p") 713 (vertico-next-group (- (or n 1)))) 714 715 (defun vertico-exit-input () 716 "Exit minibuffer with input." 717 (interactive) 718 (vertico-exit t)) 719 720 (defun vertico-save () 721 "Save current candidate to kill ring." 722 (interactive) 723 (if (or (use-region-p) (not transient-mark-mode)) 724 (call-interactively #'kill-ring-save) 725 (kill-new (vertico--candidate)))) 726 727 (defun vertico-insert () 728 "Insert current candidate in minibuffer." 729 (interactive) 730 ;; XXX There is a small bug here, depending on interpretation. When completing 731 ;; "~/emacs/master/li|/calc" where "|" is the cursor, then the returned 732 ;; candidate only includes the prefix "~/emacs/master/lisp/", but not the 733 ;; suffix "/calc". Default completion has the same problem when selecting in 734 ;; the *Completions* buffer. See bug#48356. 735 (when (> vertico--total 0) 736 (let ((vertico--index (max 0 vertico--index))) 737 (insert (prog1 (vertico--candidate) (delete-minibuffer-contents)))))) 738 739 ;;;###autoload 740 (define-minor-mode vertico-mode 741 "VERTical Interactive COmpletion." 742 :global t :group 'vertico 743 (dolist (fun '(completing-read-default completing-read-multiple)) 744 (if vertico-mode 745 (advice-add fun :around #'vertico--advice) 746 (advice-remove fun #'vertico--advice)))) 747 748 (defun vertico--command-p (_sym buffer) 749 "Return non-nil if Vertico is active in BUFFER." 750 (buffer-local-value 'vertico--input buffer)) 751 752 ;; Emacs 28: Do not show Vertico commands in M-X 753 (dolist (sym '(vertico-next vertico-next-group vertico-previous vertico-previous-group 754 vertico-scroll-down vertico-scroll-up vertico-exit vertico-insert 755 vertico-exit-input vertico-save vertico-first vertico-last)) 756 (put sym 'completion-predicate #'vertico--command-p)) 757 758 (provide 'vertico) 759 ;;; vertico.el ends here