consult.el (214318B)
1 ;;; consult.el --- Consulting completing-read -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2021-2023 Free Software Foundation, Inc. 4 5 ;; Author: Daniel Mendler and Consult contributors 6 ;; Maintainer: Daniel Mendler <mail@daniel-mendler.de> 7 ;; Created: 2020 8 ;; Version: 0.31 9 ;; Package-Requires: ((emacs "27.1") (compat "29.1.0.1")) 10 ;; Homepage: https://github.com/minad/consult 11 12 ;; This file is part of GNU Emacs. 13 14 ;; This program is free software: you can redistribute it and/or modify 15 ;; it under the terms of the GNU General Public License as published by 16 ;; the Free Software Foundation, either version 3 of the License, or 17 ;; (at your option) any later version. 18 19 ;; This program is distributed in the hope that it will be useful, 20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 22 ;; GNU General Public License for more details. 23 24 ;; You should have received a copy of the GNU General Public License 25 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 26 27 ;;; Commentary: 28 29 ;; Consult implements a set of `consult-<thing>' commands, which aim to 30 ;; improve the way you use Emacs. The commands are founded on 31 ;; `completing-read', which selects from a list of candidate strings. 32 ;; Consult provides an enhanced buffer switcher `consult-buffer' and 33 ;; search and navigation commands like `consult-imenu' and 34 ;; `consult-line'. Searching through multiple files is supported by the 35 ;; asynchronous `consult-grep' command. Many Consult commands support 36 ;; previewing candidates. If a candidate is selected in the completion 37 ;; view, the buffer shows the candidate immediately. 38 39 ;; The Consult commands are compatible with multiple completion systems 40 ;; based on the Emacs `completing-read' API, including the default 41 ;; completion system, Vertico, Mct and Icomplete. 42 43 ;; See the README for an overview of the available Consult commands and 44 ;; the documentation of the configuration and installation of the 45 ;; package. 46 47 ;; The full list of contributors can be found in the acknowledgments 48 ;; section of the README. 49 50 ;;; Code: 51 52 (eval-when-compile 53 (require 'cl-lib) 54 (require 'subr-x)) 55 (require 'bookmark) 56 (require 'kmacro) 57 (require 'recentf) 58 (require 'seq) 59 (require 'compat) 60 61 (defgroup consult nil 62 "Consulting `completing-read'." 63 :group 'convenience 64 :group 'minibuffer 65 :prefix "consult-") 66 67 ;;;; Customization 68 69 (defcustom consult-narrow-key nil 70 "Prefix key for narrowing during completion. 71 72 Good choices for this key are (kbd \"<\") or (kbd \"C-+\") for example. 73 74 The key must be either a string or a vector. 75 This is the key representation accepted by `define-key'." 76 :type '(choice key-sequence (const nil))) 77 78 (defcustom consult-widen-key nil 79 "Key used for widening during completion. 80 81 If this key is unset, defaults to twice the `consult-narrow-key'. 82 83 The key must be either a string or a vector. 84 This is the key representation accepted by `define-key'." 85 :type '(choice key-sequence (const nil))) 86 87 (defcustom consult-project-function 88 #'consult--default-project-function 89 "Function which returns project root directory. 90 The function takes one boolargument MAY-PROMPT. If MAY-PROMPT is non-nil, 91 the function may ask the prompt the user for a project directory. 92 The root directory is used by `consult-buffer' and `consult-grep'." 93 :type '(choice function (const nil))) 94 95 (defcustom consult-async-refresh-delay 0.2 96 "Refreshing delay of the completion ui for asynchronous commands. 97 98 The completion ui is only updated every `consult-async-refresh-delay' 99 seconds. This applies to asynchronous commands like for example 100 `consult-grep'." 101 :type 'float) 102 103 (defcustom consult-async-input-throttle 0.4 104 "Input throttle for asynchronous commands. 105 106 The asynchronous process is started only every 107 `consult-async-input-throttle' seconds. This applies to asynchronous 108 commands, e.g., `consult-grep'." 109 :type 'float) 110 111 (defcustom consult-async-input-debounce 0.2 112 "Input debounce for asynchronous commands. 113 114 The asynchronous process is started only when there has not been new 115 input for `consult-async-input-debounce' seconds. This applies to 116 asynchronous commands, e.g., `consult-grep'." 117 :type 'float) 118 119 (defcustom consult-async-min-input 3 120 "Minimum number of letters needed, before asynchronous process is called. 121 122 This applies to asynchronous commands, e.g., `consult-grep'." 123 :type 'integer) 124 125 (defcustom consult-async-split-style 'perl 126 "Async splitting style, see `consult-async-split-styles-alist'." 127 :type '(choice (const :tag "No splitting" nil) 128 (const :tag "Comma" comma) 129 (const :tag "Semicolon" semicolon) 130 (const :tag "Perl" perl))) 131 132 (defcustom consult-async-split-styles-alist 133 '((nil :function consult--split-nil) 134 (comma :separator ?, :function consult--split-separator) 135 (semicolon :separator ?\; :function consult--split-separator) 136 (perl :initial "#" :function consult--split-perl)) 137 "Async splitting styles." 138 :type '(alist :key-type symbol :value-type plist)) 139 140 (defcustom consult-mode-histories 141 '((eshell-mode eshell-history-ring eshell-history-index eshell-bol) 142 (comint-mode comint-input-ring comint-input-ring-index comint-bol) 143 (term-mode term-input-ring term-input-ring-index term-bol)) 144 "Alist of mode histories (mode history index bol). 145 The histories can be rings or lists. Index, if provided, is a 146 variable to set to the index of the selection within the ring or 147 list. Bol, if provided is a function which jumps to the beginning 148 of the line after the prompt." 149 :type '(alist :key-type symbol 150 :value-type (group :tag "Include Index" 151 (symbol :tag "List/Ring") 152 (symbol :tag "Index Variable") 153 (symbol :tag "Bol Function")))) 154 155 (defcustom consult-themes nil 156 "List of themes (symbols or regexps) to be presented for selection. 157 nil shows all `custom-available-themes'." 158 :type '(repeat (choice symbol regexp))) 159 160 (defcustom consult-after-jump-hook '(recenter) 161 "Function called after jumping to a location. 162 163 Commonly used functions for this hook are `recenter' and 164 `reposition-window'. You may want to add a function which pulses the 165 current line, e.g., `pulse-momentary-highlight-one-line' is supported on 166 Emacs 28 and newer. The hook called during preview and for the jump 167 after selection." 168 :type 'hook) 169 170 (defcustom consult-line-start-from-top nil 171 "Start search from the top if non-nil. 172 Otherwise start the search at the current line and wrap around." 173 :type 'boolean) 174 175 (defcustom consult-point-placement 'match-beginning 176 "Where to leave point when jumping to a match. 177 This setting affects the command `consult-line' and the `consult-grep' variants." 178 :type '(choice (const :tag "Beginning of the line" line-beginning) 179 (const :tag "Beginning of the match" match-beginning) 180 (const :tag "End of the match" match-end))) 181 182 (defcustom consult-line-numbers-widen t 183 "Show absolute line numbers when narrowing is active. 184 185 See also `display-line-numbers-widen'." 186 :type 'boolean) 187 188 (defcustom consult-goto-line-numbers t 189 "Show line numbers for `consult-goto-line'." 190 :type 'boolean) 191 192 (defcustom consult-fontify-preserve t 193 "Preserve fontification for line-based commands." 194 :type 'boolean) 195 196 (defcustom consult-fontify-max-size 1048576 197 "Buffers larger than this byte limit are not fontified. 198 199 This is necessary in order to prevent a large startup time 200 for navigation commands like `consult-line'." 201 :type 'integer) 202 203 (defcustom consult-buffer-filter 204 '("\\` " 205 "\\`\\*Completions\\*\\'" 206 "\\`\\*Flymake log\\*\\'" 207 "\\`\\*Semantic SymRef\\*\\'" 208 "\\`\\*tramp/.*\\*\\'") 209 "Filter regexps for `consult-buffer'. 210 211 The default setting is to filter ephemeral buffer names beginning with a space 212 character, the *Completions* buffer and a few log buffers." 213 :type '(repeat regexp)) 214 215 (defcustom consult-buffer-sources 216 '(consult--source-hidden-buffer 217 consult--source-modified-buffer 218 consult--source-buffer 219 consult--source-recent-file 220 consult--source-file-register 221 consult--source-bookmark 222 consult--source-project-buffer 223 consult--source-project-recent-file) 224 "Sources used by `consult-buffer'. 225 See also `consult-project-buffer-sources'. 226 See `consult--multi' for a description of the source data structure." 227 :type '(repeat symbol)) 228 229 (defcustom consult-project-buffer-sources nil 230 "Sources used by `consult-project-buffer'. 231 See also `consult-buffer-sources'. 232 See `consult--multi' for a description of the source data structure." 233 :type '(repeat symbol)) 234 235 (defcustom consult-mode-command-filter 236 '(;; Filter commands 237 "-mode\\'" "--" 238 ;; Filter whole features 239 simple mwheel time so-long recentf) 240 "Filter commands for `consult-mode-command'." 241 :type '(repeat (choice symbol regexp))) 242 243 (defcustom consult-grep-max-columns 300 244 "Maximal number of columns of grep output." 245 :type 'integer) 246 247 (defconst consult--grep-match-regexp 248 "\\`\\(?:\\./\\)?\\([^\n\0]+\\)\0\\([0-9]+\\)\\([-:\0]\\)" 249 "Regexp used to match file and line of grep output.") 250 251 (defcustom consult-grep-args 252 '("grep" (consult--grep-exclude-args) 253 "--null --line-buffered --color=never --ignore-case --line-number -I -r .") 254 "Command line arguments for grep, see `consult-grep'. 255 The dynamically computed arguments are appended. 256 Can be either a string, or a list of strings or expressions." 257 :type '(choice string (repeat (choice string expression)))) 258 259 (defcustom consult-git-grep-args 260 "git --no-pager grep --null --color=never --ignore-case\ 261 --extended-regexp --line-number -I" 262 "Command line arguments for git-grep, see `consult-git-grep'. 263 The dynamically computed arguments are appended. 264 Can be either a string, or a list of strings or expressions." 265 :type '(choice string (repeat (choice string expression)))) 266 267 (defcustom consult-ripgrep-args 268 "rg --null --line-buffered --color=never --max-columns=1000 --path-separator /\ 269 --smart-case --no-heading --line-number ." 270 "Command line arguments for ripgrep, see `consult-ripgrep'. 271 The dynamically computed arguments are appended. 272 Can be either a string, or a list of strings or expressions." 273 :type '(choice string (repeat (choice string expression)))) 274 275 (defcustom consult-find-args 276 "find . -not ( -wholename */.* -prune )" 277 "Command line arguments for find, see `consult-find'. 278 The dynamically computed arguments are appended. 279 Can be either a string, or a list of strings or expressions." 280 :type '(choice string (repeat (choice string expression)))) 281 282 (defcustom consult-locate-args 283 "locate --ignore-case --existing" 284 "Command line arguments for locate, see `consult-locate'. 285 The dynamically computed arguments are appended. 286 Can be either a string, or a list of strings or expressions." 287 :type '(choice string (repeat (choice string expression)))) 288 289 (defcustom consult-man-args 290 "man -k" 291 "Command line arguments for man, see `consult-man'. 292 The dynamically computed arguments are appended. 293 Can be either a string, or a list of strings or expressions." 294 :type '(choice string (repeat (choice string expression)))) 295 296 (defcustom consult-preview-key 'any 297 "Preview trigger keys, can be nil, \\='any, a single key or a list of keys." 298 :type '(choice (const :tag "Any key" any) 299 (list :tag "Debounced" (const :debounce) (float :tag "Seconds" 0.1) (const any)) 300 (const :tag "No preview" nil) 301 (key-sequence :tag "Key") 302 (repeat :tag "List of keys" key-sequence))) 303 304 (defcustom consult-preview-max-size 10485760 305 "Files larger than this byte limit are not previewed." 306 :type 'integer) 307 308 (defcustom consult-preview-raw-size 524288 309 "Files larger than this byte limit are previewed in raw form." 310 :type 'integer) 311 312 (defcustom consult-preview-max-count 10 313 "Number of files to keep open at once during preview." 314 :type 'integer) 315 316 (defcustom consult-preview-excluded-files nil 317 "List of regexps matched against names of files, which are not previewed." 318 :type '(repeat regexp)) 319 320 (defcustom consult-preview-allowed-hooks 321 '(global-font-lock-mode-check-buffers 322 save-place-find-file-hook) 323 "List of `find-file' hooks, which should be executed during file preview." 324 :type '(repeat symbol)) 325 326 (defcustom consult-preview-variables 327 '((inhibit-message . t) 328 (enable-dir-local-variables . nil) 329 (enable-local-variables . :safe) 330 (non-essential . t) 331 (delay-mode-hooks . t)) 332 "Variables which are bound for file preview." 333 :type '(alist :key-type symbol)) 334 335 (defcustom consult-bookmark-narrow 336 `((?f "File" ,#'bookmark-default-handler) 337 (?h "Help" ,#'help-bookmark-jump) 338 (?i "Info" ,#'Info-bookmark-jump) 339 (?p "Picture" ,#'image-bookmark-jump) 340 (?d "Docview" ,#'doc-view-bookmark-jump) 341 (?m "Man" ,#'Man-bookmark-jump) 342 (?w "Woman" ,#'woman-bookmark-jump) 343 (?g "Gnus" ,#'gnus-summary-bookmark-jump) 344 ;; Introduced on Emacs 28 345 (?s "Eshell" eshell-bookmark-jump) 346 (?e "Eww" eww-bookmark-jump) 347 (?v "VC Directory" vc-dir-bookmark-jump)) 348 "Bookmark narrowing configuration. 349 350 Each element of the list must have the form \\='(char name handler)." 351 :type '(repeat (list character string function))) 352 353 (defcustom consult-yank-rotate 354 (if (boundp 'yank-from-kill-ring-rotate) 355 yank-from-kill-ring-rotate 356 t) 357 "Rotate the `kill-ring' in the `consult-yank' commands." 358 :type 'boolean) 359 360 ;;;; Faces 361 362 (defgroup consult-faces nil 363 "Faces used by Consult." 364 :group 'consult 365 :group 'faces) 366 367 (defface consult-preview-line 368 '((t :inherit consult-preview-insertion :extend t)) 369 "Face used for line previews.") 370 371 (defface consult-highlight-match 372 '((t :inherit match)) 373 "Face used to highlight matches in the completion candidates. 374 Used for example in `consult-grep'.") 375 376 (defface consult-preview-match 377 '((t :inherit isearch)) 378 "Face used for match previews, e.g., in `consult-line'.") 379 380 (defface consult-preview-cursor 381 '((t :inherit cursor)) 382 "Face used for cursor previews and marks, e.g., in `consult-mark'.") 383 384 (defface consult-preview-insertion 385 '((t :inherit region)) 386 "Face used for previews of text to be inserted. 387 Used by `consult-completion-in-region', `consult-yank' and `consult-history'.") 388 389 (defface consult-narrow-indicator 390 '((t :inherit warning)) 391 "Face used for the narrowing indicator.") 392 393 (defface consult-async-running 394 '((t :inherit consult-narrow-indicator)) 395 "Face used if asynchronous process is running.") 396 397 (defface consult-async-finished 398 '((t :inherit success)) 399 "Face used if asynchronous process has finished.") 400 401 (defface consult-async-failed 402 '((t :inherit error)) 403 "Face used if asynchronous process has failed.") 404 405 (defface consult-async-split 406 '((t :inherit font-lock-negation-char-face)) 407 "Face used to highlight punctuation character.") 408 409 (defface consult-help 410 '((t :inherit shadow)) 411 "Face used to highlight help, e.g., in `consult-register-store'.") 412 413 (defface consult-key 414 '((t :inherit font-lock-keyword-face)) 415 "Face used to highlight keys, e.g., in `consult-register'.") 416 417 (defface consult-line-number 418 '((t :inherit consult-key)) 419 "Face used to highlight location line in `consult-global-mark'.") 420 421 (defface consult-file 422 '((t :inherit font-lock-function-name-face)) 423 "Face used to highlight files in `consult-buffer'.") 424 425 (defface consult-grep-context 426 '((t :inherit shadow)) 427 "Face used to highlight grep context in `consult-grep'.") 428 429 (defface consult-bookmark 430 '((t :inherit font-lock-constant-face)) 431 "Face used to highlight bookmarks in `consult-buffer'.") 432 433 (defface consult-buffer 434 '((t)) 435 "Face used to highlight buffers in `consult-buffer'.") 436 437 (defface consult-line-number-prefix 438 '((t :inherit line-number)) 439 "Face used to highlight line number prefixes.") 440 441 (defface consult-line-number-wrapped 442 '((t :inherit consult-line-number-prefix :inherit font-lock-warning-face)) 443 "Face used to highlight line number prefixes, if the line number wrapped around.") 444 445 (defface consult-separator 446 '((((class color) (min-colors 88) (background light)) 447 :foreground "#ccc") 448 (((class color) (min-colors 88) (background dark)) 449 :foreground "#333")) 450 "Face used for thin line separators in `consult-register-window'.") 451 452 ;;;; History variables 453 454 (defvar consult--keep-lines-history nil) 455 (defvar consult--grep-history nil) 456 (defvar consult--find-history nil) 457 (defvar consult--man-history nil) 458 (defvar consult--line-history nil) 459 (defvar consult--line-multi-history nil) 460 (defvar consult--theme-history nil) 461 (defvar consult--minor-mode-menu-history nil) 462 (defvar consult--kmacro-history nil) 463 (defvar consult--buffer-history nil) 464 465 ;;;; Internal variables 466 467 (defvar consult--regexp-compiler 468 #'consult--default-regexp-compiler 469 "Regular expression compiler used by `consult-grep' and other commands. 470 The function must return a list of regular expressions and a highlighter 471 function.") 472 473 (defvar consult--customize-alist 474 ;; Disable preview in frames, since frames do not get up cleaned 475 ;; properly. Preview is only supported by `consult-buffer' and 476 ;; `consult-buffer-other-window'. 477 `((,#'consult-buffer-other-frame :preview-key nil)) 478 "Command configuration alist for fine-grained configuration. 479 480 Each element of the list must have the form (command-name plist...). The 481 options set here will be evaluated and passed to `consult--read', when 482 called from the corresponding command. Note that the options depend on 483 the private `consult--read' API and should not be considered as stable 484 as the public API.") 485 486 (defvar consult--buffer-display #'switch-to-buffer 487 "Buffer display function.") 488 489 (defvar consult--completion-candidate-hook 490 (list #'consult--default-completion-minibuffer-candidate 491 #'consult--default-completion-list-candidate) 492 "Get candidate from completion system.") 493 494 (defvar consult--completion-refresh-hook nil 495 "Refresh completion system.") 496 497 (defvar-local consult--preview-function nil 498 "Minibuffer-local variable which exposes the current preview function. 499 This function can be called by custom completion systems from 500 outside the minibuffer.") 501 502 (defconst consult--tofu-char #x200000 503 "Special character used to encode line prefixes for disambiguation. 504 We use invalid characters outside the Unicode range.") 505 506 (defconst consult--tofu-range #x100000 507 "Special character range.") 508 509 (defvar-local consult--narrow nil 510 "Current narrowing key.") 511 512 (defvar-local consult--narrow-keys nil 513 "Narrowing prefixes of the current completion.") 514 515 (defvar-local consult--narrow-predicate nil 516 "Narrowing predicate of the current completion.") 517 518 (defvar-local consult--narrow-overlay nil 519 "Narrowing indicator overlay.") 520 521 (defvar consult--gc-threshold (* 64 1024 1024) 522 "Large gc threshold for temporary increase.") 523 524 (defvar consult--gc-percentage 0.5 525 "Large gc percentage for temporary increase.") 526 527 (defvar consult--process-chunk (* 1024 1024) 528 "Increase process output chunk size.") 529 530 (defvar consult--async-log 531 " *consult-async*" 532 "Buffer for async logging output used by `consult--async-process'.") 533 534 (defvar-local consult--focus-lines-overlays nil 535 "Overlays used by `consult-focus-lines'.") 536 537 ;;;; Customization helper 538 539 (defun consult--customize-put (cmds prop form) 540 "Set property PROP to FORM of commands CMDS." 541 (dolist (cmd cmds) 542 (cond 543 ((and (boundp cmd) (consp (symbol-value cmd))) 544 (set cmd (plist-put (symbol-value cmd) prop (eval form 'lexical)))) 545 ((functionp cmd) 546 (setf (alist-get cmd consult--customize-alist) 547 (plist-put (alist-get cmd consult--customize-alist) prop form))) 548 (t (user-error "%s is neither a Consult command nor a Consult source" 549 cmd)))) 550 nil) 551 552 (defmacro consult-customize (&rest args) 553 "Set properties of commands or sources. 554 ARGS is a list of commands or sources followed by the list of 555 keyword-value pairs. For `consult-customize' to succeed, the 556 customized sources and commands must exist. When a command is 557 invoked, the value of `this-command' is used to lookup the 558 corresponding customization options." 559 (let (setter) 560 (while args 561 (let ((cmds (seq-take-while (lambda (x) (not (keywordp x))) args))) 562 (setq args (seq-drop-while (lambda (x) (not (keywordp x))) args)) 563 (while (keywordp (car args)) 564 (push `(consult--customize-put ',cmds ,(car args) ',(cadr args)) setter) 565 (setq args (cddr args))))) 566 (macroexp-progn setter))) 567 568 (defun consult--customize-get (&optional cmd) 569 "Get configuration from `consult--customize-alist' for CMD." 570 (mapcar (lambda (x) (eval x 'lexical)) 571 (alist-get (or cmd this-command) consult--customize-alist))) 572 573 ;;;; Helper functions and macros 574 575 (defun consult--in-buffer (fun &optional buffer) 576 "Ensure that FUN is executed inside BUFFER." 577 (unless buffer (setq buffer (current-buffer))) 578 (lambda (&rest args) 579 (with-current-buffer buffer 580 (apply fun args)))) 581 582 (defun consult--completion-table-in-buffer (table &optional buffer) 583 "Ensure that completion TABLE is executed inside BUFFER." 584 (if (functionp table) 585 (consult--in-buffer 586 (lambda (str pred action) 587 (if (eq action 'metadata) 588 (mapcar 589 (lambda (x) 590 (if (and (string-suffix-p (symbol-name (car-safe x)) "-function") (cdr x)) 591 (cons (car x) (consult--in-buffer (cdr x))) 592 x)) 593 (funcall table str pred action)) 594 (funcall table str pred action))) 595 buffer) 596 table)) 597 598 (defun consult--build-args (arg) 599 "Return ARG as a flat list of split strings. 600 601 Turn ARG into a list, and for each element either: 602 - split it if it a string. 603 - eval it if it is an expression." 604 (mapcan (lambda (x) 605 (if (stringp x) 606 (split-string-and-unquote x) 607 (ensure-list (eval x 'lexical)))) 608 (ensure-list arg))) 609 610 (defun consult--command-split (str) 611 "Return command argument and options list given input STR." 612 (save-match-data 613 (let ((opts (when (string-match " +--\\( +\\|\\'\\)" str) 614 (prog1 (substring str (match-end 0)) 615 (setq str (substring str 0 (match-beginning 0))))))) 616 ;; split-string-and-unquote fails if the quotes are invalid. Ignore it. 617 (cons str (and opts (ignore-errors (split-string-and-unquote opts))))))) 618 619 (defun consult--find-highlights (str start &rest ignored-faces) 620 "Find highlighted regions in STR from position START. 621 Highlighted regions have a non-nil face property. 622 IGNORED-FACES are ignored when searching for matches." 623 (let (highlights 624 (end (length str)) 625 (beg start)) 626 (while (< beg end) 627 (let ((next (next-single-property-change beg 'face str end)) 628 (val (get-text-property beg 'face str))) 629 (when (and val 630 (not (memq val ignored-faces)) 631 (not (and (consp val) 632 (seq-some (lambda (x) (memq x ignored-faces)) val)))) 633 (push (cons (- beg start) (- next start)) highlights)) 634 (setq beg next))) 635 (nreverse highlights))) 636 637 (defun consult--point-placement (str start &rest ignored-faces) 638 "Compute point placement from STR with START offset. 639 IGNORED-FACES are ignored when searching for matches. 640 Return cons of point position and a list of match begin/end pairs." 641 (let* ((matches (apply #'consult--find-highlights str start ignored-faces)) 642 (pos (pcase-exhaustive consult-point-placement 643 ('match-beginning (or (caar matches) 0)) 644 ('match-end (or (cdar (last matches)) 0)) 645 ('line-beginning 0)))) 646 (dolist (match matches) 647 (cl-decf (car match) pos) 648 (cl-decf (cdr match) pos)) 649 (cons pos matches))) 650 651 (defun consult--highlight-regexps (regexps ignore-case str) 652 "Highlight REGEXPS in STR. 653 If a regular expression contains capturing groups, only these are highlighted. 654 If no capturing groups are used highlight the whole match. Case is ignored 655 if IGNORE-CASE is non-nil." 656 (dolist (re regexps) 657 (let ((i 0)) 658 (while (let ((case-fold-search ignore-case)) 659 (string-match re str i)) 660 ;; Unfortunately there is no way to avoid the allocation of the match 661 ;; data, since the number of capturing groups is unknown. 662 (let ((m (match-data))) 663 (setq i (cadr m) m (or (cddr m) m)) 664 (while m 665 (when (car m) 666 (add-face-text-property (car m) (cadr m) 667 'consult-highlight-match nil str)) 668 (setq m (cddr m)))))))) 669 670 (defconst consult--convert-regexp-table 671 (append 672 ;; For simplicity, treat word beginning/end as word boundaries, 673 ;; since PCRE does not make this distinction. Usually the 674 ;; context determines if \b is the beginning or the end. 675 '(("\\<" . "\\b") ("\\>" . "\\b") 676 ("\\_<" . "\\b") ("\\_>" . "\\b")) 677 ;; Treat \` and \' as beginning and end of line. This is more 678 ;; widely supported and makes sense for line-based commands. 679 '(("\\`" . "^") ("\\'" . "$")) 680 ;; Historical: Unescaped *, +, ? are supported at the beginning 681 (mapcan (lambda (x) 682 (mapcar (lambda (y) 683 (cons (concat x y) 684 (concat (string-remove-prefix "\\" x) "\\" y))) 685 '("*" "+" "?"))) 686 '("" "\\(" "\\(?:" "\\|" "^")) 687 ;; Different escaping 688 (mapcan (lambda (x) `(,x (,(cdr x) . ,(car x)))) 689 '(("\\|" . "|") 690 ("\\(" . "(") ("\\)" . ")") 691 ("\\{" . "{") ("\\}" . "}")))) 692 "Regexp conversion table.") 693 694 (defun consult--convert-regexp (regexp type) 695 "Convert Emacs REGEXP to regexp syntax TYPE." 696 (if (memq type '(emacs basic)) 697 regexp 698 ;; Support for Emacs regular expressions is fairly complete for basic 699 ;; usage. There are a few unsupported Emacs regexp features: 700 ;; - \= point matching 701 ;; - Syntax classes \sx \Sx 702 ;; - Character classes \cx \Cx 703 ;; - Explicitly numbered groups (?3:group) 704 (replace-regexp-in-string 705 (rx (or "\\\\" "\\^" ;; Pass through 706 (seq (or "\\(?:" "\\|") (any "*+?")) ;; Historical: \|+ or \(?:* etc 707 (seq "\\(" (any "*+")) ;; Historical: \(* or \(+ 708 (seq (or bos "^") (any "*+?")) ;; Historical: + or * at the beginning 709 (seq (opt "\\") (any "(){|}")) ;; Escape parens/braces/pipe 710 (seq "\\" (any "'<>`")) ;; Special escapes 711 (seq "\\_" (any "<>")))) ;; Beginning or end of symbol 712 (lambda (x) (or (cdr (assoc x consult--convert-regexp-table)) x)) 713 regexp 'fixedcase 'literal))) 714 715 (defun consult--default-regexp-compiler (input type ignore-case) 716 "Compile the INPUT string to a list of regular expressions. 717 The function should return a pair, the list of regular expressions and a 718 highlight function. The highlight function should take a single 719 argument, the string to highlight given the INPUT. TYPE is the desired 720 type of regular expression, which can be `basic', `extended', `emacs' or 721 `pcre'. If IGNORE-CASE is non-nil return a highlight function which 722 matches case insensitively." 723 (setq input (consult--split-escaped input)) 724 (cons (mapcar (lambda (x) (consult--convert-regexp x type)) input) 725 (when-let (regexps (seq-filter #'consult--valid-regexp-p input)) 726 (apply-partially #'consult--highlight-regexps regexps ignore-case)))) 727 728 (defun consult--split-escaped (str) 729 "Split STR at spaces, which can be escaped with backslash." 730 (mapcar 731 (lambda (x) (string-replace "\0" " " x)) 732 (split-string (replace-regexp-in-string 733 "\\\\\\\\\\|\\\\ " 734 (lambda (x) (if (equal x "\\ ") "\0" x)) 735 str 'fixedcase 'literal) 736 " +" t))) 737 738 (defun consult--join-regexps (regexps type) 739 "Join REGEXPS of TYPE." 740 ;; Add lookahead wrapper only if there is more than one regular expression 741 (cond 742 ((and (eq type 'pcre) (cdr regexps)) 743 (concat "^" (mapconcat (lambda (x) (format "(?=.*%s)" x)) 744 regexps ""))) 745 ((eq type 'basic) 746 (string-join regexps ".*")) 747 (t 748 (when (length> regexps 3) 749 (message "Too many regexps, %S ignored. Use post-filtering!" 750 (string-join (seq-drop regexps 3) " ")) 751 (setq regexps (seq-take regexps 3))) 752 (consult--regexp-join-permutations regexps 753 (and (memq type '(basic emacs)) "\\"))))) 754 755 (defun consult--regexp-join-permutations (regexps esc) 756 "Join all permutations of REGEXPS. 757 ESC is the escaping string for choice and groups." 758 (pcase regexps 759 ('nil "") 760 (`(,r) r) 761 (`(,r1 ,r2) (concat r1 ".*" r2 esc "|" r2 ".*" r1)) 762 (_ (mapconcat 763 (lambda (r) 764 (concat r ".*" esc "(" 765 (consult--regexp-join-permutations (remove r regexps) esc) 766 esc ")")) 767 regexps (concat esc "|"))))) 768 769 (defun consult--valid-regexp-p (re) 770 "Return t if regexp RE is valid." 771 (condition-case nil 772 (progn (string-match-p re "") t) 773 (invalid-regexp nil))) 774 775 (defun consult--regexp-filter (regexps) 776 "Create filter regexp from REGEXPS." 777 (if (stringp regexps) 778 regexps 779 (mapconcat (lambda (x) (concat "\\(?:" x "\\)")) regexps "\\|"))) 780 781 (defmacro consult--keep! (list form) 782 "Evaluate FORM for every element of LIST and keep the non-nil results." 783 (declare (indent 1)) 784 (let ((head (make-symbol "head")) 785 (prev (make-symbol "prev")) 786 (result (make-symbol "result"))) 787 `(let* ((,head (cons nil ,list)) 788 (,prev ,head)) 789 (while (cdr ,prev) 790 (if-let (,result (let ((it (cadr ,prev))) ,form)) 791 (progn 792 (pop ,prev) 793 (setcar ,prev ,result)) 794 (setcdr ,prev (cddr ,prev)))) 795 (setq ,list (cdr ,head)) 796 nil))) 797 798 ;; Upstream bug#46326, Consult issue https://github.com/minad/consult/issues/193 799 (defmacro consult--minibuffer-with-setup-hook (fun &rest body) 800 "Variant of `minibuffer-with-setup-hook' using a symbol and `fset'. 801 802 This macro is only needed to prevent memory leaking issues with 803 the upstream `minibuffer-with-setup-hook' macro. 804 FUN is the hook function and BODY opens the minibuffer." 805 (declare (indent 1) (debug t)) 806 (let ((hook (make-symbol "hook")) 807 (append)) 808 (when (eq (car-safe fun) :append) 809 (setq append '(t) fun (cadr fun))) 810 `(let ((,hook (make-symbol "consult--minibuffer-setup"))) 811 (fset ,hook (lambda () 812 (remove-hook 'minibuffer-setup-hook ,hook) 813 (funcall ,fun))) 814 (unwind-protect 815 (progn 816 (add-hook 'minibuffer-setup-hook ,hook ,@append) 817 ,@body) 818 (remove-hook 'minibuffer-setup-hook ,hook))))) 819 820 (defun consult--completion-filter (pattern cands category _highlight) 821 "Filter CANDS with PATTERN. 822 823 CATEGORY is the completion category, used to find the completion style via 824 `completion-category-defaults' and `completion-category-overrides'. 825 HIGHLIGHT must be non-nil if the resulting strings should be highlighted." 826 ;; completion-all-completions returns an improper list 827 ;; where the last link is not necessarily nil. 828 (nconc (completion-all-completions pattern cands nil (length pattern) 829 `(metadata (category . ,category))) 830 nil)) 831 832 (defun consult--completion-filter-complement (pattern cands category _highlight) 833 "Filter CANDS with complement of PATTERN. 834 See `consult--completion-filter' for the arguments CATEGORY and HIGHLIGHT." 835 (let ((ht (consult--string-hash (consult--completion-filter pattern cands category nil)))) 836 (seq-remove (lambda (x) (gethash x ht)) cands))) 837 838 (defun consult--completion-filter-dispatch (pattern cands category highlight) 839 "Filter CANDS with PATTERN with optional complement. 840 Either using `consult--completion-filter' or 841 `consult--completion-filter-complement', depending on if the pattern starts 842 with a bang. See `consult--completion-filter' for the arguments CATEGORY and 843 HIGHLIGHT." 844 (cond 845 ((string-match-p "\\`!? ?\\'" pattern) cands) ;; empty pattern 846 ((string-prefix-p "! " pattern) (consult--completion-filter-complement 847 (substring pattern 2) cands category nil)) 848 (t (consult--completion-filter pattern cands category highlight)))) 849 850 (defmacro consult--each-line (beg end &rest body) 851 "Iterate over each line. 852 853 The line beginning/ending BEG/END is bound in BODY." 854 (declare (indent 2)) 855 (let ((max (make-symbol "max"))) 856 `(save-excursion 857 (let ((,beg (point-min)) (,max (point-max)) end) 858 (while (< ,beg ,max) 859 (goto-char ,beg) 860 (let ((inhibit-field-text-motion t)) 861 (setq ,end (line-end-position))) 862 ,@body 863 (setq ,beg (1+ ,end))))))) 864 865 (defun consult--display-width (string) 866 "Compute width of STRING taking display and invisible properties into account." 867 (let ((pos 0) (width 0) (end (length string))) 868 (while (< pos end) 869 (let ((nextd (next-single-property-change pos 'display string end)) 870 (display (get-text-property pos 'display string))) 871 (if (stringp display) 872 (setq width (+ width (string-width display)) 873 pos nextd) 874 (while (< pos nextd) 875 (let ((nexti (next-single-property-change pos 'invisible string nextd))) 876 (unless (get-text-property pos 'invisible string) 877 (setq width (+ width (compat-call string-width string pos nexti)))) 878 (setq pos nexti)))))) 879 width)) 880 881 (defun consult--string-hash (strings) 882 "Create hashtable from STRINGS." 883 (let ((ht (make-hash-table :test #'equal :size (length strings)))) 884 (dolist (str strings) 885 (puthash str t ht)) 886 ht)) 887 888 (defmacro consult--local-let (binds &rest body) 889 "Buffer local let BINDS of dynamic variables in BODY." 890 (declare (indent 1)) 891 (let ((buffer (make-symbol "buffer")) 892 (local (mapcar (lambda (x) (cons (make-symbol "local") (car x))) binds))) 893 `(let ((,buffer (current-buffer)) 894 ,@(mapcar (lambda (x) `(,(car x) (local-variable-p ',(cdr x)))) local)) 895 (unwind-protect 896 (progn 897 ,@(mapcar (lambda (x) `(make-local-variable ',(car x))) binds) 898 (let (,@binds) 899 ,@body)) 900 (when (buffer-live-p ,buffer) 901 (with-current-buffer ,buffer 902 ,@(mapcar (lambda (x) 903 `(unless ,(car x) 904 (kill-local-variable ',(cdr x)))) 905 local))))))) 906 907 (defun consult--abbreviate-directory (dir) 908 "Return abbreviated directory DIR for use in `completing-read' prompt." 909 (save-match-data 910 (let ((adir (abbreviate-file-name dir))) 911 (if (string-match "/\\([^/]+\\)/\\([^/]+\\)/\\'" adir) 912 (format "…/%s/%s/" (match-string 1 adir) (match-string 2 adir)) 913 adir)))) 914 915 (defun consult--directory-prompt (prompt dir) 916 "Return prompt and directory. 917 918 PROMPT is the prompt prefix. The directory 919 is appended to the prompt prefix. For projects 920 only the project name is shown. The `default-directory' 921 is not shown. Other directories are abbreviated and 922 only the last two path components are shown. 923 924 If DIR is a string, it is returned. 925 If DIR is a true value, the user is asked. 926 Then the `consult-project-function' is tried. 927 Otherwise the `default-directory' is returned." 928 (let* ((dir 929 (cond 930 ((stringp dir) dir) 931 (dir 932 ;; Preserve this-command across `read-directory-name' call, 933 ;; such that `consult-customize' continues to work. 934 (let ((this-command this-command)) 935 (read-directory-name "Directory: " nil nil t))) 936 (t (or (consult--project-root) default-directory)))) 937 (edir (file-name-as-directory (expand-file-name dir))) 938 ;; Bind default-directory in order to find the project 939 (pdir (let ((default-directory edir)) (consult--project-root)))) 940 (cons 941 (format "%s (%s): " prompt 942 (if (equal edir pdir) 943 (concat "Project " (consult--project-name pdir)) 944 (consult--abbreviate-directory dir))) 945 edir))) 946 947 (defun consult--default-project-function (may-prompt) 948 "Return project root directory. 949 When no project is found and MAY-PROMPT is non-nil ask the user." 950 (when-let (proj (project-current may-prompt)) 951 (cond 952 ((fboundp 'project-root) (project-root proj)) 953 ((fboundp 'project-roots) (car (project-roots proj)))))) 954 955 (defun consult--project-root (&optional may-prompt) 956 "Return project root as absolute path. 957 When no project is found and MAY-PROMPT is non-nil ask the user." 958 ;; Preserve this-command across project selection, 959 ;; such that `consult-customize' continues to work. 960 (let ((this-command this-command)) 961 (when-let (root (and consult-project-function 962 (funcall consult-project-function may-prompt))) 963 (expand-file-name root)))) 964 965 (defun consult--project-name (dir) 966 "Return the project name for DIR." 967 (if (string-match "/\\([^/]+\\)/\\'" dir) 968 (match-string 1 dir) 969 dir)) 970 971 (defun consult--format-location (file line &optional str) 972 "Format location string 'FILE:LINE:STR'." 973 (setq line (number-to-string line) 974 str (concat file ":" line (and str ":") str) 975 file (length file)) 976 (put-text-property 0 file 'face 'consult-file str) 977 (put-text-property (1+ file) (+ 1 file (length line)) 'face 'consult-line-number str) 978 str) 979 980 (defmacro consult--overlay (beg end &rest props) 981 "Make consult overlay between BEG and END with PROPS." 982 (let ((ov (make-symbol "ov")) 983 (puts)) 984 (while props 985 (push `(overlay-put ,ov ,(car props) ,(cadr props)) puts) 986 (setq props (cddr props))) 987 `(let ((,ov (make-overlay ,beg ,end))) 988 ,@puts 989 ,ov))) 990 991 (defun consult--remove-dups (list) 992 "Remove duplicate strings from LIST." 993 (delete-dups (copy-sequence list))) 994 995 (defsubst consult--in-range-p (pos) 996 "Return t if position POS lies in range `point-min' to `point-max'." 997 (<= (point-min) pos (point-max))) 998 999 (defun consult--type-group (types) 1000 "Return group function for TYPES." 1001 (lambda (cand transform) 1002 (if transform 1003 cand 1004 (alist-get (get-text-property 0 'consult--type cand) types)))) 1005 1006 (defun consult--type-narrow (types) 1007 "Return narrowing configuration from TYPES." 1008 (list :predicate 1009 (lambda (cand) (eq (get-text-property 0 'consult--type cand) consult--narrow)) 1010 :keys types)) 1011 1012 (defun consult--completion-window-p () 1013 "Return non-nil if the selected window belongs to the completion UI." 1014 (or (eq (selected-window) (active-minibuffer-window)) 1015 (eq #'completion-list-mode (buffer-local-value 'major-mode (window-buffer))))) 1016 1017 (defun consult--location-state (candidates) 1018 "Location state function. 1019 The cheap location markers from CANDIDATES are upgraded on window 1020 selection change to full Emacs markers." 1021 (let ((jump (consult--jump-state)) 1022 (hook (make-symbol "consult--location-upgrade"))) 1023 (fset hook 1024 (lambda (_) 1025 (unless (consult--completion-window-p) 1026 (remove-hook 'window-selection-change-functions hook) 1027 (mapc #'consult--get-location 1028 (if (functionp candidates) (funcall candidates) candidates))))) 1029 (lambda (action cand) 1030 (pcase action 1031 ('setup (add-hook 'window-selection-change-functions hook)) 1032 ('exit (remove-hook 'window-selection-change-functions hook))) 1033 (funcall jump action cand)))) 1034 1035 (defun consult--get-location (cand) 1036 "Return location from CAND." 1037 (let ((loc (get-text-property 0 'consult-location cand))) 1038 (when (consp (car loc)) 1039 ;; Transform cheap marker to real marker 1040 (setcar loc (set-marker (make-marker) (cdar loc) (caar loc)))) 1041 loc)) 1042 1043 (defun consult--lookup-member (selected candidates &rest _) 1044 "Lookup SELECTED in CANDIDATES list, return original element." 1045 (car (member selected candidates))) 1046 1047 (defun consult--lookup-cons (selected candidates &rest _) 1048 "Lookup SELECTED in CANDIDATES alist, return cons." 1049 (assoc selected candidates)) 1050 1051 (defun consult--lookup-cdr (selected candidates &rest _) 1052 "Lookup SELECTED in CANDIDATES alist, return cdr of element." 1053 (cdr (assoc selected candidates))) 1054 1055 (defun consult--lookup-location (selected candidates &rest _) 1056 "Lookup SELECTED in CANDIDATES list of `consult-location' category. 1057 Return the location marker." 1058 (when-let (found (member selected candidates)) 1059 (setq found (car (consult--get-location (car found)))) 1060 ;; Check that marker is alive 1061 (and (or (not (markerp found)) (marker-buffer found)) found))) 1062 1063 (defun consult--lookup-prop (prop selected candidates &rest _) 1064 "Lookup SELECTED in CANDIDATES list and return PROP value." 1065 (when-let (found (member selected candidates)) 1066 (get-text-property 0 prop (car found)))) 1067 1068 (defun consult--lookup-candidate (selected candidates &rest _) 1069 "Lookup SELECTED in CANDIDATES list and return property `consult--candidate'." 1070 (consult--lookup-prop 'consult--candidate selected candidates)) 1071 1072 (defun consult--forbid-minibuffer () 1073 "Raise an error if executed from the minibuffer." 1074 (when (minibufferp) 1075 (user-error "`%s' called inside the minibuffer" this-command))) 1076 1077 (defun consult--require-minibuffer () 1078 "Raise an error if executed outside the minibuffer." 1079 (unless (minibufferp) 1080 (user-error "`%s' must be called inside the minibuffer" this-command))) 1081 1082 (defun consult--fontify-all () 1083 "Ensure that the whole buffer is fontified." 1084 ;; Font-locking is lazy, i.e., if a line has not been looked at yet, the line 1085 ;; is not font-locked. We would observe this if consulting an unfontified 1086 ;; line. Therefore we have to enforce font-locking now, which is slow. In 1087 ;; order to prevent is hang-up we check the buffer size against 1088 ;; `consult-fontify-max-size'. 1089 (when (and consult-fontify-preserve jit-lock-mode 1090 (< (buffer-size) consult-fontify-max-size)) 1091 (jit-lock-fontify-now))) 1092 1093 (defun consult--fontify-region (start end) 1094 "Ensure that region between START and END is fontified." 1095 (when (and consult-fontify-preserve jit-lock-mode) 1096 (jit-lock-fontify-now start end))) 1097 1098 (defmacro consult--with-increased-gc (&rest body) 1099 "Temporarily increase the gc limit in BODY to optimize for throughput." 1100 (let ((overwrite (make-symbol "overwrite"))) 1101 `(let* ((,overwrite (> consult--gc-threshold gc-cons-threshold)) 1102 (gc-cons-threshold (if ,overwrite consult--gc-threshold gc-cons-threshold)) 1103 (gc-cons-percentage (if ,overwrite consult--gc-percentage gc-cons-percentage))) 1104 ,@body))) 1105 1106 (defun consult--count-lines (pos) 1107 "Move to position POS and return number of lines." 1108 (let ((line 0)) 1109 (while (< (point) pos) 1110 (forward-line) 1111 (when (<= (point) pos) 1112 (cl-incf line))) 1113 (goto-char pos) 1114 line)) 1115 1116 (defun consult--position-marker (buffer line column) 1117 "Get marker in BUFFER from LINE and COLUMN." 1118 (when (buffer-live-p buffer) 1119 (with-current-buffer buffer 1120 (save-restriction 1121 (save-excursion 1122 (widen) 1123 (goto-char (point-min)) 1124 ;; Location data might be invalid by now! 1125 (ignore-errors 1126 (forward-line (1- line)) 1127 (forward-char column)) 1128 (point-marker)))))) 1129 1130 (defun consult--line-prefix (&optional curr-line) 1131 "Annotate `consult-location' candidates with line numbers. 1132 CURR-LINE is the current line number." 1133 (setq curr-line (or curr-line -1)) 1134 (let* ((width (length (number-to-string (line-number-at-pos 1135 (point-max) 1136 consult-line-numbers-widen)))) 1137 (before (format #("%%%dd " 0 6 (face consult-line-number-wrapped)) width)) 1138 (after (format #("%%%dd " 0 6 (face consult-line-number-prefix)) width))) 1139 (lambda (cand) 1140 (let ((line (cdr (get-text-property 0 'consult-location cand)))) 1141 (list cand (format (if (< line curr-line) before after) line) ""))))) 1142 1143 (defun consult--location-candidate (cand marker line &rest props) 1144 "Add MARKER and LINE as \\='consult-location text property to CAND. 1145 Furthermore add the additional text properties PROPS, and append 1146 tofu-encoded MARKER suffix for disambiguation." 1147 ;; Handle cheap marker 1148 (setq cand (concat cand (consult--tofu-encode (if (consp marker) (cdr marker) marker)))) 1149 (add-text-properties 0 1 `(consult-location (,marker . ,line) ,@props) cand) 1150 cand) 1151 1152 ;; There is a similar variable `yank-excluded-properties'. Unfortunately 1153 ;; we cannot use it here since it excludes too much (e.g., invisible) 1154 ;; and at the same time not enough (e.g., cursor-sensor-functions). 1155 (defconst consult--remove-text-properties 1156 '(category cursor cursor-intangible cursor-sensor-functions field follow-link 1157 fontified front-sticky help-echo insert-behind-hooks insert-in-front-hooks intangible keymap 1158 local-map modification-hooks mouse-face pointer read-only rear-nonsticky yank-handler) 1159 "List of text properties to remove from buffer strings.") 1160 1161 (defsubst consult--buffer-substring (beg end &optional fontify) 1162 "Return buffer substring between BEG and END. 1163 If FONTIFY and `consult-fontify-preserve' are non-nil, first ensure that the 1164 region has been fontified." 1165 (if consult-fontify-preserve 1166 (let (str) 1167 (when fontify (consult--fontify-region beg end)) 1168 (setq str (buffer-substring beg end)) 1169 ;; TODO Propose the addition of a function `preserve-list-of-text-properties' 1170 (remove-list-of-text-properties 0 (- end beg) consult--remove-text-properties str) 1171 str) 1172 (buffer-substring-no-properties beg end))) 1173 1174 (defun consult--region-with-cursor (beg end marker) 1175 "Return region string with a marking at the cursor position. 1176 1177 BEG is the begin position. 1178 END is the end position. 1179 MARKER is the cursor position." 1180 (let ((str (consult--buffer-substring beg end 'fontify))) 1181 (if (>= marker end) 1182 (concat str #(" " 0 1 (face consult-preview-cursor))) 1183 (put-text-property (- marker beg) (- (1+ marker) beg) 1184 'face 'consult-preview-cursor str) 1185 str))) 1186 1187 (defun consult--line-with-cursor (marker) 1188 "Return current line where the cursor MARKER is highlighted." 1189 (let ((inhibit-field-text-motion t)) 1190 (consult--region-with-cursor (line-beginning-position) (line-end-position) marker))) 1191 1192 ;;;; Preview support 1193 1194 (defun consult--filter-find-file-hook (orig &rest hooks) 1195 "Filter `find-file-hook' by `consult-preview-allowed-hooks'. 1196 This function is an advice for `run-hooks'. 1197 ORIG is the original function, HOOKS the arguments." 1198 (if (memq 'find-file-hook hooks) 1199 (cl-letf* (((default-value 'find-file-hook) 1200 (seq-filter (lambda (x) 1201 (memq x consult-preview-allowed-hooks)) 1202 (default-value 'find-file-hook))) 1203 (find-file-hook (default-value 'find-file-hook))) 1204 (apply orig hooks)) 1205 (apply orig hooks))) 1206 1207 (defun consult--find-file-temporarily-1 (name) 1208 "Open file NAME, helper function for `consult--find-file-temporarily'." 1209 (when-let* (((not (seq-find (lambda (x) (string-match-p x name)) 1210 consult-preview-excluded-files))) 1211 ;; file-attributes may throw permission denied error 1212 (attrs (ignore-errors (file-attributes name))) 1213 (size (file-attribute-size attrs))) 1214 (if (> size consult-preview-max-size) 1215 (format "File `%s' (%s) is too large for preview" 1216 name (file-size-human-readable size)) 1217 (let ((buf (find-file-noselect name 'nowarn (> size consult-preview-raw-size)))) 1218 (cond 1219 ((and (> size consult-preview-raw-size) 1220 (with-current-buffer buf 1221 (save-excursion 1222 (goto-char (point-min)) 1223 (search-forward "\0" nil 'noerror)))) 1224 (kill-buffer buf) 1225 (format "Binary file `%s' not previewed literally" name)) 1226 ((ignore-errors (buffer-local-value 'so-long-detected-p buf)) 1227 (kill-buffer buf) 1228 (format "File `%s' with long lines not previewed" name)) 1229 (t buf)))))) 1230 1231 (defun consult--find-file-temporarily (name) 1232 "Open file NAME temporarily for preview." 1233 (let ((vars (delq nil 1234 (mapcar 1235 (pcase-lambda (`(,k . ,v)) 1236 (if (boundp k) 1237 (list k v (default-value k) (symbol-value k)) 1238 (message "consult-preview-variables: The variable `%s' is not bound" k) 1239 nil)) 1240 consult-preview-variables))) 1241 buf) 1242 (unwind-protect 1243 (progn 1244 (advice-add #'run-hooks :around #'consult--filter-find-file-hook) 1245 (pcase-dolist (`(,k ,v . ,_) vars) 1246 (set-default k v) 1247 (set k v)) 1248 (setq buf (consult--find-file-temporarily-1 name))) 1249 (advice-remove #'run-hooks #'consult--filter-find-file-hook) 1250 (pcase-dolist (`(,k ,_ ,d ,v) vars) 1251 (set-default k d) 1252 (set k v))) 1253 (if (stringp buf) (progn (message "%s" buf) nil) buf))) 1254 1255 (defun consult--temporary-files () 1256 "Return a function to open files temporarily for preview." 1257 (let ((dir default-directory) 1258 (hook (make-symbol "consult--temporary-files-window-selection-change")) 1259 (orig-buffers (buffer-list)) 1260 temporary-buffers) 1261 (fset hook 1262 (lambda (_) 1263 ;; Fully initialize previewed files and keep them alive. 1264 (unless (consult--completion-window-p) 1265 (let (live-files) 1266 (pcase-dolist (`(,file . ,buf) temporary-buffers) 1267 (when-let (wins (and (buffer-live-p buf) 1268 (get-buffer-window-list buf))) 1269 (push (cons file (mapcar 1270 (lambda (win) 1271 (cons win (window-state-get win t))) 1272 wins)) 1273 live-files))) 1274 (pcase-dolist (`(,_ . ,buf) temporary-buffers) 1275 (kill-buffer buf)) 1276 (setq temporary-buffers nil) 1277 (pcase-dolist (`(,file . ,wins) live-files) 1278 (when-let (buf (find-file-noselect file)) 1279 (push buf orig-buffers) 1280 (pcase-dolist (`(,win . ,state) wins) 1281 (setf (car (alist-get 'buffer state)) buf) 1282 (window-state-put state win)))))))) 1283 (lambda (&optional name) 1284 (if name 1285 (let ((default-directory dir)) 1286 (setq name (abbreviate-file-name (expand-file-name name))) 1287 (or 1288 ;; Find existing fully initialized buffer (non-previewed). We have 1289 ;; to check for fully initialized buffer before accessing the 1290 ;; previewed buffers, since `embark-act' can open a buffer which is 1291 ;; currently previewed, such that we end up with two buffers for 1292 ;; the same file - one previewed and only partially initialized and 1293 ;; one fully initialized. In this case we prefer the fully 1294 ;; initialized buffer. For directories `get-file-buffer' returns nil, 1295 ;; therefore we have to special case Dired. 1296 (if (and (fboundp 'dired-find-buffer-nocreate) (file-directory-p name)) 1297 (dired-find-buffer-nocreate name) 1298 (get-file-buffer name)) 1299 ;; Find existing previewed buffer. Previewed buffers are not fully 1300 ;; initialized (hooks are delayed) in order to ensure fast preview. 1301 (cdr (assoc name temporary-buffers)) 1302 ;; Finally, if no existing buffer has been found, open the file for 1303 ;; preview. 1304 (when-let (buf (consult--find-file-temporarily name)) 1305 ;; Only add new buffer if not already in the list 1306 (unless (or (rassq buf temporary-buffers) (memq buf orig-buffers)) 1307 (add-hook 'window-selection-change-functions hook) 1308 (push (cons name buf) temporary-buffers) 1309 ;; Disassociate buffer from file by setting `buffer-file-name' 1310 ;; and `dired-directory' to nil and rename the buffer. This 1311 ;; lets us open an already previewed buffer with the Embark 1312 ;; default action C-. RET. 1313 (with-current-buffer buf 1314 (rename-buffer 1315 (format " Preview:%s" 1316 (file-name-nondirectory (directory-file-name name))) 1317 'unique)) 1318 ;; The buffer disassociation is delayed to avoid breaking modes 1319 ;; like `pdf-view-mode' or `doc-view-mode' which rely on 1320 ;; `buffer-file-name'. Executing (set-visited-file-name nil) 1321 ;; early also prevents the major mode initialization. 1322 (let ((hook (make-symbol "consult--temporary-files-disassociate"))) 1323 (fset hook (lambda () 1324 (when (buffer-live-p buf) 1325 (with-current-buffer buf 1326 (remove-hook 'pre-command-hook hook) 1327 (setq-local buffer-read-only t 1328 dired-directory nil 1329 buffer-file-name nil))))) 1330 (add-hook 'pre-command-hook hook)) 1331 ;; Only keep a few buffers alive 1332 (while (length> temporary-buffers consult-preview-max-count) 1333 (kill-buffer (cdar (last temporary-buffers))) 1334 (setq temporary-buffers (nbutlast temporary-buffers)))) 1335 buf))) 1336 (remove-hook 'window-selection-change-functions hook) 1337 (pcase-dolist (`(,_ . ,buf) temporary-buffers) 1338 (kill-buffer buf)) 1339 (setq temporary-buffers nil))))) 1340 1341 (declare-function org-fold-core-region "org-fold-core") 1342 (declare-function org-fold-core-get-regions "org-fold-core") 1343 1344 (defun consult--invisible-open-permanently () 1345 "Open overlays which hide the current line. 1346 See `isearch-open-necessary-overlays' and `isearch-open-overlay-temporary'." 1347 (if (and (derived-mode-p #'org-mode) (fboundp 'org-fold-show-set-visibility)) 1348 ;; New Org 9.6 fold-core API 1349 (org-fold-show-set-visibility 'canonical) 1350 (dolist (ov (let ((inhibit-field-text-motion t)) 1351 (overlays-in (line-beginning-position) (line-end-position)))) 1352 (when-let (fun (overlay-get ov 'isearch-open-invisible)) 1353 (when (invisible-p (overlay-get ov 'invisible)) 1354 (funcall fun ov)))))) 1355 1356 (defun consult--invisible-open-temporarily () 1357 "Temporarily open overlays which hide the current line. 1358 See `isearch-open-necessary-overlays' and `isearch-open-overlay-temporary'." 1359 (if (and (derived-mode-p #'org-mode) (fboundp 'org-fold-show-set-visibility)) 1360 ;; New Org 9.6 fold-core API 1361 ;; TODO The provided Org API `org-fold-show-set-visibility' cannot be used 1362 ;; efficiently. We obtain all regions in the whole buffer in order to 1363 ;; restore them. A better show API would return all the applied 1364 ;; modifications such that we can restore the ones which got modified. 1365 (let ((regions (delq nil (org-fold-core-get-regions 1366 :with-markers t :from (point-min) :to (point-max))))) 1367 (org-fold-show-set-visibility 'canonical) 1368 (list (lambda () 1369 (pcase-dolist (`(,beg ,end ,spec) regions) 1370 (org-fold-core-region beg end t spec) 1371 (when (markerp beg) (set-marker beg nil)) 1372 (when (markerp end) (set-marker end nil)))))) 1373 (let (restore) 1374 (dolist (ov (let ((inhibit-field-text-motion t)) 1375 (overlays-in (line-beginning-position) (line-end-position)))) 1376 (let ((inv (overlay-get ov 'invisible))) 1377 (when (and (invisible-p inv) (overlay-get ov 'isearch-open-invisible)) 1378 (push (if-let (fun (overlay-get ov 'isearch-open-invisible-temporary)) 1379 (progn 1380 (funcall fun ov nil) 1381 (lambda () (funcall fun ov t))) 1382 (overlay-put ov 'invisible nil) 1383 (lambda () (overlay-put ov 'invisible inv))) 1384 restore)))) 1385 restore))) 1386 1387 (defun consult--jump-1 (pos) 1388 "Go to POS and recenter." 1389 (if (and (markerp pos) (not (marker-buffer pos))) 1390 ;; Only print a message, no error in order to not mess 1391 ;; with the minibuffer update hook. 1392 (message "Buffer is dead") 1393 ;; Switch to buffer if it is not visible 1394 (when-let (buf (and (markerp pos) (marker-buffer pos))) 1395 (unless (and (eq (current-buffer) buf) (eq (window-buffer) buf)) 1396 (consult--buffer-action buf 'norecord))) 1397 ;; Widen if we cannot jump to the position (idea from flycheck-jump-to-error) 1398 (unless (= (goto-char pos) (point)) 1399 (widen) 1400 (goto-char pos)))) 1401 1402 (defun consult--jump (pos) 1403 "Push current position to mark ring, go to POS and recenter." 1404 (when pos 1405 ;; Extract marker from list with with overlay positions, see `consult--line-match' 1406 (when (consp pos) (setq pos (car pos))) 1407 ;; When the marker is in the same buffer, record previous location 1408 ;; such that the user can jump back quickly. 1409 (when (or (not (markerp pos)) (eq (current-buffer) (marker-buffer pos))) 1410 ;; push-mark mutates markers in the mark-ring and the mark-marker. 1411 ;; Therefore we transform the marker to a number to be safe. 1412 ;; We all love side effects! 1413 (setq pos (+ pos 0)) 1414 (push-mark (point) t)) 1415 (consult--jump-1 pos) 1416 (consult--invisible-open-permanently) 1417 (run-hooks 'consult-after-jump-hook)) 1418 nil) 1419 1420 (defun consult--jump-preview () 1421 "The preview function used if selecting from a list of candidate positions. 1422 The function can be used as the `:state' argument of `consult--read'." 1423 (let ((saved-min (point-min-marker)) 1424 (saved-max (point-max-marker)) 1425 (saved-pos (point-marker)) 1426 overlays invisible) 1427 (set-marker-insertion-type saved-max t) ;; Grow when text is inserted 1428 (lambda (action cand) 1429 (when (eq action 'preview) 1430 (mapc #'funcall invisible) 1431 (mapc #'delete-overlay overlays) 1432 (setq invisible nil overlays nil) 1433 (if (not cand) 1434 ;; If position cannot be previewed, return to saved position 1435 (let ((saved-buffer (marker-buffer saved-pos))) 1436 (if (not saved-buffer) 1437 (message "Buffer is dead") 1438 (set-buffer saved-buffer) 1439 (narrow-to-region saved-min saved-max) 1440 (goto-char saved-pos))) 1441 ;; Handle positions with overlay information 1442 (consult--jump-1 (or (car-safe cand) cand)) 1443 (setq invisible (consult--invisible-open-temporarily) 1444 overlays 1445 (list (save-excursion 1446 (let ((vbeg (progn (beginning-of-visual-line) (point))) 1447 (vend (progn (end-of-visual-line) (point))) 1448 (end (line-end-position))) 1449 (consult--overlay vbeg (if (= vend end) (1+ end) vend) 1450 'face 'consult-preview-line 1451 'window (selected-window) 1452 'priority 1))) 1453 (consult--overlay (point) (1+ (point)) 1454 'face 'consult-preview-cursor 1455 'window (selected-window) 1456 'priority 3))) 1457 (dolist (match (cdr-safe cand)) 1458 (push (consult--overlay (+ (point) (car match)) 1459 (+ (point) (cdr match)) 1460 'face 'consult-preview-match 1461 'window (selected-window) 1462 'priority 2) 1463 overlays)) 1464 (run-hooks 'consult-after-jump-hook)))))) 1465 1466 (defun consult--jump-state () 1467 "The state function used if selecting from a list of candidate positions." 1468 (consult--state-with-return (consult--jump-preview) #'consult--jump)) 1469 1470 (defun consult--state-with-return (state return) 1471 "Compose STATE function with RETURN function." 1472 (lambda (action cand) 1473 (funcall state action cand) 1474 (when (and cand (eq action 'return)) 1475 (funcall return cand)))) 1476 1477 (defmacro consult--define-state (type) 1478 "Define state function for TYPE." 1479 `(defun ,(intern (format "consult--%s-state" type)) () 1480 ,(format "State function for %ss with preview. 1481 The result can be passed as :state argument to `consult--read'." type) 1482 (consult--state-with-return (,(intern (format "consult--%s-preview" type))) 1483 #',(intern (format "consult--%s-action" type))))) 1484 1485 (defun consult--preview-key-normalize (preview-key) 1486 "Normalize PREVIEW-KEY, return alist of keys and debounce times." 1487 (let ((keys) 1488 (debounce 0)) 1489 (setq preview-key (ensure-list preview-key)) 1490 (while preview-key 1491 (if (eq (car preview-key) :debounce) 1492 (setq debounce (cadr preview-key) 1493 preview-key (cddr preview-key)) 1494 (push (cons (car preview-key) debounce) keys) 1495 (pop preview-key))) 1496 keys)) 1497 1498 (defun consult--preview-key-debounce (preview-key cand) 1499 "Return debounce value of PREVIEW-KEY given the current candidate CAND." 1500 (when (and (consp preview-key) (memq :keys preview-key)) 1501 (setq preview-key (funcall (plist-get preview-key :predicate) cand))) 1502 (let ((map (make-sparse-keymap)) 1503 (keys (this-single-command-keys)) 1504 any) 1505 (dolist (x (consult--preview-key-normalize preview-key)) 1506 (if (eq (car x) 'any) 1507 (setq any (cdr x)) 1508 (define-key map (car x) `(lambda () ,(cdr x))))) 1509 (setq keys (lookup-key map keys)) 1510 (if (functionp keys) (funcall keys) any))) 1511 1512 (defun consult--append-local-post-command-hook (fun) 1513 "Append FUN to local `post-command-hook' list." 1514 ;; Symbol indirection because of bug#46407. 1515 (let ((hook (make-symbol "consult--preview-post-command"))) 1516 (fset hook fun) 1517 ;; TODO Emacs 28 has a bug, where the hook--depth-alist is not cleaned up properly 1518 ;; Do not use the broken add-hook here. 1519 ;;(add-hook 'post-command-hook sym 'append 'local) 1520 (setq-local post-command-hook 1521 (append 1522 (remove t post-command-hook) 1523 (list hook) 1524 (and (memq t post-command-hook) '(t)))))) 1525 1526 (defun consult--with-preview-1 (preview-key state transform candidate fun) 1527 "Add preview support for FUN. 1528 See `consult--with-preview' for the arguments 1529 PREVIEW-KEY, STATE, TRANSFORM and CANDIDATE." 1530 (let ((input "") narrow selected timer last-preview) 1531 (consult--minibuffer-with-setup-hook 1532 (if (and state preview-key) 1533 (lambda () 1534 (let ((exit-hook (make-symbol "consult--preview-minibuffer-exit")) 1535 (depth (recursion-depth))) 1536 (fset exit-hook 1537 (lambda () 1538 (when (= (recursion-depth) depth) 1539 (remove-hook 'minibuffer-exit-hook exit-hook) 1540 (when timer 1541 (cancel-timer timer) 1542 (setq timer nil)) 1543 (with-selected-window (or (minibuffer-selected-window) (next-window)) 1544 ;; STEP 3: Reset preview 1545 (when last-preview 1546 (funcall state 'preview nil)) 1547 ;; STEP 4: Notify the preview function of the minibuffer exit 1548 (funcall state 'exit nil))))) 1549 (add-hook 'minibuffer-exit-hook exit-hook)) 1550 ;; STEP 1: Setup the preview function 1551 (with-selected-window (or (minibuffer-selected-window) (next-window)) 1552 (funcall state 'setup nil)) 1553 (setq consult--preview-function 1554 (lambda () 1555 (when-let ((cand (funcall candidate))) 1556 (with-selected-window (active-minibuffer-window) 1557 (let ((input (minibuffer-contents-no-properties)) 1558 (new-preview (cons input cand))) 1559 (with-selected-window (or (minibuffer-selected-window) (next-window)) 1560 (when-let* ((transformed (funcall transform narrow input cand)) 1561 (debounce (consult--preview-key-debounce preview-key transformed))) 1562 (when timer 1563 (cancel-timer timer) 1564 (setq timer nil)) 1565 (unless (equal-including-properties last-preview new-preview) 1566 (if (> debounce 0) 1567 (let ((win (selected-window))) 1568 (setq timer 1569 (run-at-time 1570 debounce nil 1571 (lambda () 1572 (when (window-live-p win) 1573 (with-selected-window win 1574 ;; STEP 2: Preview candidate 1575 (funcall state 'preview transformed) 1576 (setq last-preview new-preview))))))) 1577 ;; STEP 2: Preview candidate 1578 (funcall state 'preview transformed) 1579 (setq last-preview new-preview)))))))))) 1580 (consult--append-local-post-command-hook 1581 (lambda () 1582 (setq input (minibuffer-contents-no-properties) 1583 narrow consult--narrow) 1584 (funcall consult--preview-function)))) 1585 (lambda () 1586 (consult--append-local-post-command-hook 1587 (lambda () (setq input (minibuffer-contents-no-properties) 1588 narrow consult--narrow))))) 1589 (unwind-protect 1590 (cons (setq selected (when-let (result (funcall fun)) 1591 (funcall transform narrow input result))) 1592 input) 1593 (when state 1594 ;; STEP 5: The preview function should perform its final action 1595 (funcall state 'return selected)))))) 1596 1597 (defmacro consult--with-preview (preview-key state transform candidate &rest body) 1598 "Add preview support to BODY. 1599 1600 STATE is the state function. 1601 TRANSFORM is the transformation function. 1602 CANDIDATE is the function returning the current candidate. 1603 PREVIEW-KEY are the keys which triggers the preview. 1604 1605 The state function takes two arguments, an action argument and the 1606 selected candidate. The candidate argument can be nil if no candidate is 1607 selected or if the selection was aborted. The function is called in 1608 sequence with the following arguments: 1609 1610 1. \\='setup nil After entering the mb (minibuffer-setup-hook). 1611 ⎧ 2. \\='preview CAND/nil Preview candidate CAND or reset if CAND is nil. 1612 ⎪ \\='preview CAND/nil 1613 ⎪ \\='preview CAND/nil 1614 ⎪ ... 1615 ⎩ 3. \\='preview nil Reset preview. 1616 4. \\='exit nil Before exiting the mb (minibuffer-exit-hook). 1617 5. \\='return CAND/nil After leaving the mb, CAND has been selected. 1618 1619 The state function is always executed with the original window selected, 1620 see `minibuffer-selected-window'. The state function is called once in 1621 the beginning of the minibuffer setup with the `setup' argument. This is 1622 useful in order to perform certain setup operations which require that 1623 the minibuffer is initialized. During completion candidates are 1624 previewed. Then the function is called with the `preview' argument and a 1625 candidate CAND or nil if no candidate is selected. Furthermore if nil is 1626 passed for CAND, then the preview must be undone and the original state 1627 must be restored. The call with the `exit' argument happens once at the 1628 end of the completion process, just before exiting the minibuffer. The 1629 minibuffer is still alive at that point. Both `setup' and `exit' are 1630 only useful for setup and cleanup operations. They don't receive a 1631 candidate as argument. After leaving the minibuffer, the selected 1632 candidate or nil is passed to the state function with the action 1633 argument `return'. At this point the state function can perform the 1634 actual action on the candidate. The state function with the `return' 1635 argument is the continuation of `consult--read'. Via `unwind-protect' it 1636 is guaranteed, that if the `setup' action of a state function is 1637 invoked, the state function will also be called with `exit' and 1638 `return'." 1639 (declare (indent 4)) 1640 `(consult--with-preview-1 ,preview-key ,state ,transform ,candidate (lambda () ,@body))) 1641 1642 ;;;; Narrowing support 1643 1644 (defun consult--widen-key () 1645 "Return widening key, if `consult-widen-key' is not set. 1646 The default is twice the `consult-narrow-key'." 1647 (or consult-widen-key (and consult-narrow-key (vconcat consult-narrow-key consult-narrow-key)))) 1648 1649 (defun consult-narrow (key) 1650 "Narrow current completion with KEY. 1651 1652 This command is used internally by the narrowing system of `consult--read'." 1653 (interactive 1654 (list (unless (equal (this-single-command-keys) (consult--widen-key)) 1655 last-command-event))) 1656 (consult--require-minibuffer) 1657 (setq consult--narrow key) 1658 (when consult--narrow-predicate 1659 (setq minibuffer-completion-predicate (and consult--narrow consult--narrow-predicate))) 1660 (when consult--narrow-overlay 1661 (delete-overlay consult--narrow-overlay)) 1662 (when consult--narrow 1663 (setq consult--narrow-overlay 1664 (consult--overlay 1665 (1- (minibuffer-prompt-end)) (minibuffer-prompt-end) 1666 'before-string 1667 (propertize (format " [%s]" (alist-get consult--narrow 1668 consult--narrow-keys)) 1669 'face 'consult-narrow-indicator)))) 1670 (run-hooks 'consult--completion-refresh-hook)) 1671 1672 (defconst consult--narrow-delete 1673 `(menu-item 1674 "" nil :filter 1675 ,(lambda (&optional _) 1676 (when (string= (minibuffer-contents-no-properties) "") 1677 (lambda () 1678 (interactive) 1679 (consult-narrow nil)))))) 1680 1681 (defconst consult--narrow-space 1682 `(menu-item 1683 "" nil :filter 1684 ,(lambda (&optional _) 1685 (let ((str (minibuffer-contents-no-properties))) 1686 (when-let (pair (or (and (length= str 1) 1687 (assoc (aref str 0) consult--narrow-keys)) 1688 (and (string= str "") 1689 (assoc 32 consult--narrow-keys)))) 1690 (lambda () 1691 (interactive) 1692 (delete-minibuffer-contents) 1693 (consult-narrow (car pair)))))))) 1694 1695 (defun consult-narrow-help () 1696 "Print narrowing help as a `minibuffer-message'. 1697 1698 This command can be bound to a key in `consult-narrow-map', 1699 to make it available for commands with narrowing." 1700 (interactive) 1701 (consult--require-minibuffer) 1702 (let ((minibuffer-message-timeout 1000000)) 1703 (minibuffer-message 1704 (mapconcat 1705 (lambda (x) (concat 1706 (propertize (char-to-string (car x)) 'face 'consult-key) " " 1707 (propertize (cdr x) 'face 'consult-help))) 1708 (seq-filter (lambda (x) (/= (car x) 32)) 1709 consult--narrow-keys) 1710 " ")))) 1711 1712 (defun consult--narrow-setup (settings map) 1713 "Setup narrowing with SETTINGS and keymap MAP." 1714 (if (memq :keys settings) 1715 (setq consult--narrow-predicate (plist-get settings :predicate) 1716 consult--narrow-keys (plist-get settings :keys)) 1717 (setq consult--narrow-predicate nil 1718 consult--narrow-keys settings)) 1719 (when consult-narrow-key 1720 (dolist (pair consult--narrow-keys) 1721 (define-key map 1722 (vconcat consult-narrow-key (vector (car pair))) 1723 (cons (cdr pair) #'consult-narrow)))) 1724 (when-let (widen (consult--widen-key)) 1725 (define-key map widen (cons "All" #'consult-narrow)))) 1726 1727 ;; Emacs 28: hide in M-X 1728 (put #'consult-narrow-help 'completion-predicate #'ignore) 1729 (put #'consult-narrow 'completion-predicate #'ignore) 1730 1731 ;;;; Splitting completion style 1732 1733 (defun consult--split-perl (str &optional _plist) 1734 "Split input STR in async input and filtering part. 1735 1736 The function returns a list with three elements: The async 1737 string, the start position of the completion filter string and a 1738 force flag. If the first character is a punctuation character it 1739 determines the separator. Examples: \"/async/filter\", 1740 \"#async#filter\"." 1741 (if (string-match-p "^[[:punct:]]" str) 1742 (save-match-data 1743 (let ((q (regexp-quote (substring str 0 1)))) 1744 (string-match (concat "^" q "\\([^" q "]*\\)\\(" q "\\)?") str) 1745 `(,(match-string 1 str) 1746 ,(match-end 0) 1747 ;; Force update it two punctuation characters are entered. 1748 ,(match-end 2) 1749 ;; List of highlights 1750 (0 . ,(match-beginning 1)) 1751 ,@(and (match-end 2) `((,(match-beginning 2) . ,(match-end 2))))))) 1752 `(,str ,(length str)))) 1753 1754 (defun consult--split-nil (str &optional _plist) 1755 "Treat the complete input STR as async input." 1756 `(,str ,(length str))) 1757 1758 (defun consult--split-separator (str plist) 1759 "Split input STR in async input and filtering part at first separator. 1760 PLIST is the splitter configuration, including the separator." 1761 (let ((sep (regexp-quote (char-to-string (plist-get plist :separator))))) 1762 (save-match-data 1763 (if (string-match (format "^\\([^%s]+\\)\\(%s\\)?" sep sep) str) 1764 `(,(match-string 1 str) 1765 ,(match-end 0) 1766 ;; Force update it space is entered. 1767 ,(match-end 2) 1768 ;; List of highlights 1769 ,@(and (match-end 2) `((,(match-beginning 2) . ,(match-end 2))))) 1770 `(,str ,(length str)))))) 1771 1772 (defun consult--split-setup (split) 1773 "Setup splitting completion style with splitter function SPLIT." 1774 (let* ((styles completion-styles) 1775 (catdef completion-category-defaults) 1776 (catovr completion-category-overrides) 1777 (try (lambda (str table pred point) 1778 (let ((completion-styles styles) 1779 (completion-category-defaults catdef) 1780 (completion-category-overrides catovr) 1781 (pos (cadr (funcall split str)))) 1782 (pcase (completion-try-completion (substring str pos) table pred 1783 (max 0 (- point pos))) 1784 ('t t) 1785 (`(,newstr . ,newpt) 1786 (cons (concat (substring str 0 pos) newstr) 1787 (+ pos newpt))))))) 1788 (all (lambda (str table pred point) 1789 (let ((completion-styles styles) 1790 (completion-category-defaults catdef) 1791 (completion-category-overrides catovr) 1792 (pos (cadr (funcall split str)))) 1793 (completion-all-completions (substring str pos) table pred 1794 (max 0 (- point pos))))))) 1795 (setq-local completion-styles-alist (cons `(consult--split ,try ,all "") 1796 completion-styles-alist) 1797 completion-styles '(consult--split) 1798 completion-category-defaults nil 1799 completion-category-overrides nil))) 1800 1801 ;;;; Async support 1802 1803 (defmacro consult--with-async (bind &rest body) 1804 "Setup asynchronous completion in BODY. 1805 1806 BIND is the asynchronous function binding." 1807 (declare (indent 1)) 1808 (let ((async (car bind))) 1809 `(let ((,async ,@(cdr bind)) 1810 (new-chunk (max read-process-output-max consult--process-chunk)) 1811 orig-chunk) 1812 (consult--minibuffer-with-setup-hook 1813 ;; Append such that we overwrite the completion style setting of 1814 ;; `fido-mode'. See `consult--async-split' and 1815 ;; `consult--split-setup'. 1816 (:append 1817 (lambda () 1818 (when (functionp ,async) 1819 (setq orig-chunk read-process-output-max 1820 read-process-output-max new-chunk) 1821 (funcall ,async 'setup) 1822 (let* ((mb (current-buffer)) 1823 (fun (lambda () 1824 (when-let (win (active-minibuffer-window)) 1825 (when (eq (window-buffer win) mb) 1826 (with-current-buffer mb 1827 (let ((inhibit-modification-hooks t)) 1828 ;; Push input string to request refresh. 1829 (funcall ,async (minibuffer-contents-no-properties)))))))) 1830 ;; We use a symbol in order to avoid adding lambdas to 1831 ;; the hook variable. Symbol indirection because of 1832 ;; bug#46407. 1833 (sym (make-symbol "consult--async-after-change"))) 1834 ;; Delay modification hook to ensure that minibuffer is still 1835 ;; alive after the change, such that we don't restart a new 1836 ;; asynchronous search right before exiting the minibuffer. 1837 (fset sym (lambda (&rest _) (run-at-time 0 nil fun))) 1838 (add-hook 'after-change-functions sym nil 'local) 1839 (funcall sym))))) 1840 (let ((,async (if (functionp ,async) ,async (lambda (_) ,async)))) 1841 (unwind-protect 1842 ,(macroexp-progn body) 1843 (funcall ,async 'destroy) 1844 (when (and orig-chunk (eq read-process-output-max new-chunk)) 1845 (setq read-process-output-max orig-chunk)))))))) 1846 1847 (defun consult--async-sink () 1848 "Create ASYNC sink function. 1849 1850 An async function must accept a single action argument. For the \\='setup action 1851 it is guaranteed that the call originates from the minibuffer. For the other 1852 actions no assumption about the context can be made. 1853 1854 \\='setup Setup the internal closure state. Return nil. 1855 \\='destroy Destroy the internal closure state. Return nil. 1856 \\='flush Flush the list of candidates. Return nil. 1857 \\='refresh Request UI refresh. Return nil. 1858 nil Return the list of candidates. 1859 list Append the list to the already existing candidates list and return it. 1860 string Update with the current user input string. Return nil." 1861 (let (candidates last buffer) 1862 (lambda (action) 1863 (pcase-exhaustive action 1864 ('setup 1865 (setq buffer (current-buffer)) 1866 nil) 1867 ((or (pred stringp) 'destroy) nil) 1868 ('flush (setq candidates nil last nil)) 1869 ('refresh 1870 ;; Refresh the UI when the current minibuffer window belongs 1871 ;; to the current asynchronous completion session. 1872 (when-let (win (active-minibuffer-window)) 1873 (when (eq (window-buffer win) buffer) 1874 (with-selected-window win 1875 (run-hooks 'consult--completion-refresh-hook) 1876 ;; Interaction between asynchronous completion tables and 1877 ;; preview: We have to trigger preview immediately when 1878 ;; candidates arrive (Issue #436). 1879 (when (and consult--preview-function candidates) 1880 (funcall consult--preview-function))))) 1881 nil) 1882 ('nil candidates) 1883 ((pred consp) 1884 (setq last (last (if last (setcdr last action) (setq candidates action)))) 1885 candidates))))) 1886 1887 (defun consult--async-split-style () 1888 "Return the async splitting style function and initial string." 1889 (or (alist-get consult-async-split-style consult-async-split-styles-alist) 1890 (user-error "Splitting style `%s' not found" consult-async-split-style))) 1891 1892 (defun consult--async-split-initial (initial) 1893 "Return initial string for async command. 1894 INITIAL is the additional initial string." 1895 (concat (plist-get (consult--async-split-style) :initial) initial)) 1896 1897 (defun consult--async-split-thingatpt (thing) 1898 "Return THING at point with async initial prefix." 1899 (when-let (str (thing-at-point thing)) 1900 (consult--async-split-initial str))) 1901 1902 (defun consult--async-split (async &optional split) 1903 "Create async function, which splits the input string. 1904 ASYNC is the async sink. 1905 SPLIT is the splitting function." 1906 (unless split 1907 (let* ((style (consult--async-split-style)) 1908 (fn (plist-get style :function))) 1909 (setq split (lambda (str) (funcall fn str style))))) 1910 (lambda (action) 1911 (pcase action 1912 ('setup 1913 (consult--split-setup split) 1914 (funcall async 'setup)) 1915 ((pred stringp) 1916 (pcase-let* ((`(,async-str ,_ ,force . ,highlights) 1917 (funcall split action)) 1918 (async-len (length async-str)) 1919 (input-len (length action)) 1920 (end (minibuffer-prompt-end))) 1921 ;; Highlight punctuation characters 1922 (remove-list-of-text-properties end (+ end input-len) '(face)) 1923 (dolist (hl highlights) 1924 (put-text-property (+ end (car hl)) (+ end (cdr hl)) 1925 'face 'consult-async-split)) 1926 (funcall async 1927 ;; Pass through if the input is long enough! 1928 (if (or force (>= async-len consult-async-min-input)) 1929 async-str 1930 ;; Pretend that there is no input 1931 "")))) 1932 (_ (funcall async action))))) 1933 1934 (defun consult--async-log (formatted &rest args) 1935 "Log FORMATTED ARGS to variable `consult--async-log'." 1936 (with-current-buffer (get-buffer-create consult--async-log) 1937 (goto-char (point-max)) 1938 (insert (apply #'format formatted args)))) 1939 1940 (defun consult--process-indicator (event) 1941 "Return the process indicator character for EVENT." 1942 (cond 1943 ((string-prefix-p "killed" event) 1944 #(";" 0 1 (face consult-async-failed))) 1945 ((string-prefix-p "finished" event) 1946 #(":" 0 1 (face consult-async-finished))) 1947 (t 1948 #("!" 0 1 (face consult-async-failed))))) 1949 1950 (defun consult--async-process (async cmd &rest props) 1951 "Create process source async function. 1952 1953 ASYNC is the async function which receives the candidates. 1954 CMD is the command line builder function. 1955 PROPS are optional properties passed to `make-process'." 1956 (let (proc proc-buf last-args indicator count) 1957 (lambda (action) 1958 (pcase action 1959 ("" ;; If no input is provided kill current process 1960 (when proc 1961 (delete-process proc) 1962 (kill-buffer proc-buf) 1963 (setq proc nil proc-buf nil)) 1964 (setq last-args nil)) 1965 ((pred stringp) 1966 (funcall async action) 1967 (let* ((args (funcall cmd action)) 1968 (flush t) 1969 (rest "") 1970 (proc-filter 1971 (lambda (_ out) 1972 (when flush 1973 (setq flush nil) 1974 (funcall async 'flush)) 1975 (let ((lines (split-string out "[\r\n]+"))) 1976 (if (not (cdr lines)) 1977 (setq rest (concat rest (car lines))) 1978 (setcar lines (concat rest (car lines))) 1979 (let* ((len (length lines)) 1980 (last (nthcdr (- len 2) lines))) 1981 (setq rest (cadr last) 1982 count (+ count len -1)) 1983 (setcdr last nil) 1984 (funcall async lines)))))) 1985 (proc-sentinel 1986 (lambda (_ event) 1987 (when flush 1988 (setq flush nil) 1989 (funcall async 'flush)) 1990 (overlay-put indicator 'display (consult--process-indicator event)) 1991 (when (and (string-prefix-p "finished" event) (not (string= rest ""))) 1992 (cl-incf count) 1993 (funcall async (list rest))) 1994 (consult--async-log 1995 "consult--async-process sentinel: event=%s lines=%d\n" 1996 (string-trim event) count) 1997 (with-current-buffer (get-buffer-create consult--async-log) 1998 (goto-char (point-max)) 1999 (insert ">>>>> stderr >>>>>\n") 2000 (insert-buffer-substring proc-buf) 2001 (insert "<<<<< stderr <<<<<\n"))))) 2002 (unless (equal args last-args) 2003 (setq last-args args) 2004 (when proc 2005 (delete-process proc) 2006 (kill-buffer proc-buf) 2007 (setq proc nil proc-buf nil)) 2008 (when args 2009 (overlay-put indicator 'display #("*" 0 1 (face consult-async-running))) 2010 (consult--async-log "consult--async-process started %S\n" args) 2011 (setq count 0 2012 proc-buf (generate-new-buffer " *consult-async-stderr*") 2013 proc (apply #'make-process 2014 `(,@props 2015 :connection-type pipe 2016 :name ,(car args) 2017 ;;; XXX tramp bug, the stderr buffer must be empty 2018 :stderr ,proc-buf 2019 :noquery t 2020 :command ,args 2021 :filter ,proc-filter 2022 :sentinel ,proc-sentinel)))))) 2023 nil) 2024 ('destroy 2025 (when proc 2026 (delete-process proc) 2027 (kill-buffer proc-buf) 2028 (setq proc nil proc-buf nil)) 2029 (delete-overlay indicator) 2030 (funcall async 'destroy)) 2031 ('setup 2032 (setq indicator (make-overlay (- (minibuffer-prompt-end) 2) 2033 (- (minibuffer-prompt-end) 1))) 2034 (funcall async 'setup)) 2035 (_ (funcall async action)))))) 2036 2037 (defun consult--async-highlight (async builder) 2038 "Return ASYNC function which highlightes the candidates. 2039 BUILDER is the command line builder." 2040 (let ((highlight)) 2041 (lambda (action) 2042 (cond 2043 ((stringp action) 2044 (setq highlight (plist-get (funcall builder action) :highlight)) 2045 (funcall async action)) 2046 ((and (consp action) highlight) 2047 (dolist (str action) 2048 (funcall highlight str)) 2049 (funcall async action)) 2050 (t (funcall async action)))))) 2051 2052 (defun consult--async-throttle (async &optional throttle debounce) 2053 "Create async function from ASYNC which throttles input. 2054 2055 The THROTTLE delay defaults to `consult-async-input-throttle'. 2056 The DEBOUNCE delay defaults to `consult-async-input-debounce'." 2057 (setq throttle (or throttle consult-async-input-throttle) 2058 debounce (or debounce consult-async-input-debounce)) 2059 (let ((input "") (last) (timer)) 2060 (lambda (action) 2061 (pcase action 2062 ((pred stringp) 2063 (unless (string= action input) 2064 (when timer 2065 (cancel-timer timer) 2066 (setq timer nil)) 2067 (funcall async "") ;; cancel running process 2068 (setq input action) 2069 (unless (string= action "") 2070 (setq timer 2071 (run-at-time 2072 (+ debounce 2073 (if last 2074 (min (- (float-time) last) throttle) 2075 0)) 2076 nil 2077 (lambda () 2078 (setq last (float-time)) 2079 (funcall async action)))))) 2080 nil) 2081 ('destroy 2082 (when timer (cancel-timer timer)) 2083 (funcall async 'destroy)) 2084 (_ (funcall async action)))))) 2085 2086 (defun consult--async-refresh-immediate (async) 2087 "Create async function from ASYNC, which refreshes the display. 2088 2089 The refresh happens immediately when candidates are pushed." 2090 (lambda (action) 2091 (pcase action 2092 ((or (pred consp) 'flush) 2093 (prog1 (funcall async action) 2094 (funcall async 'refresh))) 2095 (_ (funcall async action))))) 2096 2097 (defun consult--async-refresh-timer (async &optional delay) 2098 "Create async function from ASYNC, which refreshes the display. 2099 2100 The refresh happens after a DELAY, defaulting to `consult-async-refresh-delay'." 2101 (let ((timer) (refresh) (delay (or delay consult-async-refresh-delay))) 2102 (lambda (action) 2103 (prog1 (funcall async action) 2104 (pcase action 2105 ((or (pred consp) 'flush) 2106 (setq refresh t) 2107 (unless timer 2108 (setq timer (run-at-time 2109 nil delay 2110 (lambda () 2111 (when refresh 2112 (setq refresh nil) 2113 (funcall async 'refresh))))))) 2114 ('destroy (when timer (cancel-timer timer)))))))) 2115 2116 (defmacro consult--async-transform (async &rest transform) 2117 "Use FUN to TRANSFORM candidates of ASYNC." 2118 (let ((async-var (make-symbol "async")) 2119 (action-var (make-symbol "action"))) 2120 `(let ((,async-var ,async)) 2121 (lambda (,action-var) 2122 (funcall ,async-var (if (consp ,action-var) (,@transform ,action-var) ,action-var)))))) 2123 2124 (defun consult--async-map (async fun) 2125 "Map candidates of ASYNC by FUN." 2126 (consult--async-transform async mapcar fun)) 2127 2128 (defun consult--async-filter (async fun) 2129 "Filter candidates of ASYNC by FUN." 2130 (consult--async-transform async seq-filter fun)) 2131 2132 (defun consult--dynamic-collection-source (async fun) 2133 "Dynamic collection source. 2134 ASYNC is the sink. 2135 FUN computes the candidates given the input." 2136 (let ((input "") current) 2137 (lambda (action) 2138 (pcase action 2139 ('nil 2140 (if (or (equal input "") (equal input current)) 2141 (funcall async nil) 2142 (funcall async (prog1 (funcall fun input) 2143 (funcall async 'flush) 2144 (setq current input))))) 2145 ((pred stringp) 2146 (setq input action) 2147 (funcall async 'refresh)) 2148 (_ (funcall async action)))))) 2149 2150 (defun consult--dynamic-collection (fun) 2151 "Dynamic collection with input splitting. 2152 FUN computes the candidates given the input." 2153 (thread-first 2154 (consult--async-sink) 2155 (consult--dynamic-collection-source fun) 2156 (consult--async-throttle) 2157 (consult--async-split))) 2158 2159 (defun consult--command-builder (builder) 2160 "Return command line builder given CMD. 2161 BUILDER is the command line builder function." 2162 (lambda (input) 2163 (setq input (funcall builder input)) 2164 (if (stringp (car input)) 2165 input 2166 (plist-get input :command)))) 2167 2168 (defmacro consult--async-command (builder &rest args) 2169 "Asynchronous command pipeline. 2170 ARGS is a list of `make-process' properties and transforms. BUILDER is the 2171 command line builder function, which takes the input string and must either 2172 return a list of command line arguments or a plist with the command line 2173 argument list :command and a highlighting function :highlight." 2174 (declare (indent 1)) 2175 `(thread-first 2176 (consult--async-sink) 2177 (consult--async-refresh-timer) 2178 ,@(seq-take-while (lambda (x) (not (keywordp x))) args) 2179 (consult--async-process 2180 (consult--command-builder ,builder) 2181 ,@(seq-drop-while (lambda (x) (not (keywordp x))) args)) 2182 (consult--async-throttle) 2183 (consult--async-split))) 2184 2185 ;;;; Special keymaps 2186 2187 (defvar-keymap consult-async-map 2188 :doc "Keymap added for commands with asynchronous candidates." 2189 ;; Async keys overwriting some unusable defaults for the default completion 2190 "<remap> <minibuffer-complete-word>" #'self-insert-command 2191 ;; Remap Emacs 29 history and default completion for now. 2192 ;; See https://github.com/minad/consult/issues/613 2193 "<remap> <minibuffer-complete-defaults>" #'ignore 2194 "<remap> <minibuffer-complete-history>" #'consult-history) 2195 2196 (defvar-keymap consult-narrow-map 2197 :doc "Narrowing keymap which is added to the local minibuffer map. 2198 Note that `consult-narrow-key' and `consult-widen-key' are bound dynamically." 2199 "SPC" consult--narrow-space 2200 "DEL" consult--narrow-delete) 2201 2202 ;;;; Internal API: consult--read 2203 2204 (defun consult--add-history (async items) 2205 "Add ITEMS to the minibuffer future history. 2206 ASYNC must be non-nil for async completion functions." 2207 (delete-dups 2208 (append 2209 ;; the defaults are at the beginning of the future history 2210 (ensure-list minibuffer-default) 2211 ;; then our custom items 2212 (remove "" (remq nil (ensure-list items))) 2213 ;; Add all the completions for non-async commands. For async commands this feature 2214 ;; is not useful, since if one selects a completion candidate, the async search is 2215 ;; restarted using that candidate string. This usually does not yield a desired 2216 ;; result since the async input uses a special format, e.g., `#grep#filter'. 2217 (unless async 2218 (all-completions "" 2219 minibuffer-completion-table 2220 minibuffer-completion-predicate))))) 2221 2222 (defun consult--setup-keymap (keymap async narrow preview-key) 2223 "Setup minibuffer keymap. 2224 2225 KEYMAP is a command-specific keymap. 2226 ASYNC must be non-nil for async completion functions. 2227 NARROW are the narrow settings. 2228 PREVIEW-KEY are the preview keys." 2229 (let ((old-map (current-local-map)) 2230 (map (make-sparse-keymap))) 2231 2232 ;; Add narrow keys 2233 (when narrow 2234 (consult--narrow-setup narrow map)) 2235 2236 ;; Preview trigger keys 2237 (when (and (consp preview-key) (memq :keys preview-key)) 2238 (setq preview-key (plist-get preview-key :keys))) 2239 (setq preview-key (mapcar #'car (consult--preview-key-normalize preview-key))) 2240 (when preview-key 2241 (dolist (key preview-key) 2242 (unless (or (eq key 'any) (lookup-key old-map key)) 2243 (define-key map key #'ignore)))) 2244 2245 ;; Put the keymap together 2246 (use-local-map 2247 (make-composed-keymap 2248 (delq nil (list keymap 2249 (and async consult-async-map) 2250 (and narrow consult-narrow-map) 2251 map)) 2252 old-map)))) 2253 2254 (defsubst consult--tofu-p (char) 2255 "Return non-nil if CHAR is a tofu." 2256 (<= consult--tofu-char char (+ consult--tofu-char consult--tofu-range -1))) 2257 2258 (defun consult--tofu-hide (str) 2259 "Hide the tofus in STR." 2260 (let* ((max (length str)) 2261 (end max)) 2262 (while (and (> end 0) (consult--tofu-p (aref str (1- end)))) 2263 (cl-decf end)) 2264 (when (< end max) 2265 (setq str (copy-sequence str)) 2266 (put-text-property end max 'invisible t str)) 2267 str)) 2268 2269 (defun consult--tofu-hide-in-minibuffer (&rest _) 2270 "Hide the tofus in the minibuffer." 2271 (let* ((min (minibuffer-prompt-end)) 2272 (max (point-max)) 2273 (pos max)) 2274 (while (and (> pos min) (consult--tofu-p (char-before pos))) 2275 (cl-decf pos)) 2276 (when (< pos max) 2277 (add-text-properties pos max '(invisible t rear-nonsticky t cursor-intangible t))))) 2278 2279 (defsubst consult--tofu-append (cand id) 2280 "Append tofu-encoded ID to CAND." 2281 (setq id (char-to-string (+ consult--tofu-char id))) 2282 (add-text-properties 0 1 '(invisible t consult-strip t) id) 2283 (concat cand id)) 2284 2285 (defsubst consult--tofu-get (cand) 2286 "Extract tofu-encoded ID from CAND." 2287 (- (aref cand (1- (length cand))) consult--tofu-char)) 2288 2289 ;; We must disambiguate the lines by adding a prefix such that two lines with 2290 ;; the same text can be distinguished. In order to avoid matching the line 2291 ;; number, such that the user can search for numbers with `consult-line', we 2292 ;; encode the line number as characters outside the unicode range. 2293 ;; By doing that, no accidential matching can occur. 2294 (defun consult--tofu-encode (n) 2295 "Return tofu-encoded number N." 2296 (let (str tofu) 2297 (while (progn 2298 (setq tofu (char-to-string 2299 (+ consult--tofu-char (% n consult--tofu-range))) 2300 str (if str (concat tofu str) tofu)) 2301 (and (>= n consult--tofu-range) 2302 (setq n (/ n consult--tofu-range))))) 2303 (add-text-properties 0 (length str) '(invisible t consult-strip t) str) 2304 str)) 2305 2306 (defun consult--read-annotate (fun cand) 2307 "Annotate CAND with annotation function FUN." 2308 (pcase (funcall fun cand) 2309 (`(,_ ,_ ,suffix) suffix) 2310 (ann ann))) 2311 2312 (defun consult--read-affixate (fun cands) 2313 "Affixate CANDS with annotation function FUN." 2314 (mapcar (lambda (cand) 2315 (let ((ann (funcall fun cand))) 2316 (if (consp ann) 2317 ann 2318 (setq ann (or ann "")) 2319 (list cand "" 2320 ;; The default completion UI adds the `completions-annotations' face 2321 ;; if no other faces are present. 2322 (if (text-property-not-all 0 (length ann) 'face nil ann) 2323 ann 2324 (propertize ann 'face 'completions-annotations)))))) 2325 cands)) 2326 2327 (cl-defun consult--read-1 (candidates &key 2328 prompt predicate require-match history default 2329 keymap category initial narrow add-history annotate 2330 state preview-key sort lookup group inherit-input-method) 2331 "See `consult--read' for the documentation of the arguments." 2332 (consult--minibuffer-with-setup-hook 2333 (:append (lambda () 2334 (add-hook 'after-change-functions #'consult--tofu-hide-in-minibuffer nil 'local) 2335 (consult--setup-keymap keymap (functionp candidates) narrow preview-key) 2336 (setq-local minibuffer-default-add-function 2337 (apply-partially #'consult--add-history (functionp candidates) add-history)))) 2338 (consult--with-async (async candidates) 2339 ;; NOTE: Do not unnecessarily let-bind the lambdas to avoid 2340 ;; overcapturing in the interpreter. This will make closures and the 2341 ;; lambda string representation larger, which makes debugging much worse. 2342 ;; Fortunately the overcapturing problem does not affect the bytecode 2343 ;; interpreter which does a proper scope analyis. 2344 (let* ((metadata `(metadata 2345 ,@(when category `((category . ,category))) 2346 ,@(when group `((group-function . ,group))) 2347 ,@(when annotate 2348 `((affixation-function 2349 . ,(apply-partially #'consult--read-affixate annotate)) 2350 (annotation-function 2351 . ,(apply-partially #'consult--read-annotate annotate)))) 2352 ,@(unless sort '((cycle-sort-function . identity) 2353 (display-sort-function . identity))))) 2354 (result 2355 (consult--with-preview 2356 preview-key state 2357 (lambda (narrow input cand) 2358 (funcall lookup cand (funcall async nil) input narrow)) 2359 (apply-partially #'run-hook-with-args-until-success 2360 'consult--completion-candidate-hook) 2361 (completing-read prompt 2362 (lambda (str pred action) 2363 (if (eq action 'metadata) 2364 metadata 2365 (complete-with-action action (funcall async nil) str pred))) 2366 predicate require-match initial 2367 (if (symbolp history) history (cadr history)) 2368 default 2369 inherit-input-method)))) 2370 (pcase-exhaustive history 2371 (`(:input ,var) 2372 (set var (cdr (symbol-value var))) 2373 (add-to-history var (cdr result))) 2374 ((pred symbolp))) 2375 (car result))))) 2376 2377 (cl-defun consult--read (candidates &rest options &key 2378 prompt predicate require-match history default 2379 keymap category initial narrow add-history annotate 2380 state preview-key sort lookup group inherit-input-method) 2381 "Enhanced completing read function selecting from CANDIDATES. 2382 2383 The function is a thin wrapper around `completing-read'. On top 2384 of `completing-read' it additionally supports asynchronous 2385 completion list computations, candidate preview and narrowing. 2386 2387 Keyword OPTIONS: 2388 2389 PROMPT is the string which is shown as prompt message in the minibuffer. 2390 PREDICATE is a filter function called for each candidate, returns nil or t. 2391 REQUIRE-MATCH equals t means that an exact match is required. 2392 HISTORY is the symbol of the history variable. 2393 DEFAULT is the default selected value. 2394 ADD-HISTORY is a list of items to add to the history. 2395 CATEGORY is the completion category. 2396 SORT should be set to nil if the candidates are already sorted. 2397 LOOKUP is a lookup function passed the selected candidate string, 2398 the list of candidates, the current input string and the current 2399 narrowing value. 2400 ANNOTATE is a function passed a candidate string. The function 2401 should either return an annotation string or a list of three 2402 strings (candidate prefix postfix). 2403 INITIAL is the initial input string. 2404 STATE is the state function, see `consult--with-preview'. 2405 GROUP is a completion metadata `group-function' as documented in 2406 the Elisp manual. 2407 PREVIEW-KEY are the preview keys. Can be nil, \\='any, a single 2408 key or a list of keys. 2409 NARROW is an alist of narrowing prefix strings and description. 2410 KEYMAP is a command-specific keymap. 2411 INHERIT-INPUT-METHOD, if non-nil the minibuffer inherits the input method." 2412 ;; supported types 2413 (cl-assert (or (functionp candidates) ;; async table 2414 (obarrayp candidates) ;; obarray 2415 (hash-table-p candidates) ;; hash table 2416 (not candidates) ;; empty list 2417 (stringp (car candidates)) ;; string list 2418 (and (consp (car candidates)) (stringp (caar candidates))) ;; string alist 2419 (and (consp (car candidates)) (symbolp (caar candidates))))) ;; symbol alist 2420 (ignore prompt predicate require-match history default 2421 keymap category initial narrow add-history annotate 2422 state preview-key sort lookup group inherit-input-method) 2423 (apply #'consult--read-1 candidates 2424 (append 2425 (consult--customize-get) 2426 options 2427 (list :prompt "Select: " 2428 :preview-key consult-preview-key 2429 :sort t 2430 :lookup (lambda (selected &rest _) selected))))) 2431 2432 ;;;; Internal API: consult--multi 2433 2434 (defsubst consult--multi-source (sources cand) 2435 "Lookup source for CAND in SOURCES list." 2436 (aref sources (consult--tofu-get cand))) 2437 2438 (defun consult--multi-predicate (sources cand) 2439 "Predicate function called for each candidate CAND given SOURCES." 2440 (let* ((src (consult--multi-source sources cand)) 2441 (narrow (plist-get src :narrow)) 2442 (type (or (car-safe narrow) narrow -1))) 2443 (or (eq consult--narrow type) 2444 (not (or consult--narrow (plist-get src :hidden)))))) 2445 2446 (defun consult--multi-narrow (sources) 2447 "Return narrow list from SOURCES." 2448 (thread-last sources 2449 (mapcar (lambda (src) 2450 (when-let (narrow (plist-get src :narrow)) 2451 (if (consp narrow) 2452 narrow 2453 (when-let (name (plist-get src :name)) 2454 (cons narrow name)))))) 2455 (delq nil) 2456 (delete-dups))) 2457 2458 (defun consult--multi-annotate (sources align cand) 2459 "Annotate candidate CAND with `consult--multi' type, given SOURCES and ALIGN." 2460 (let* ((src (consult--multi-source sources cand)) 2461 (annotate (plist-get src :annotate)) 2462 (ann (if annotate 2463 (funcall annotate (cdr (get-text-property 0 'multi-category cand))) 2464 (plist-get src :name)))) 2465 (and ann (concat align ann)))) 2466 2467 (defun consult--multi-group (sources cand transform) 2468 "Return title of candidate CAND or TRANSFORM the candidate given SOURCES." 2469 (if transform 2470 cand 2471 (plist-get (consult--multi-source sources cand) :name))) 2472 2473 (defun consult--multi-preview-key (sources) 2474 "Return preview keys from SOURCES." 2475 (list :predicate 2476 (lambda (cand) 2477 (if (plist-member (cdr cand) :preview-key) 2478 (plist-get (cdr cand) :preview-key) 2479 consult-preview-key)) 2480 :keys 2481 (delete-dups 2482 (seq-mapcat (lambda (src) 2483 (let ((key (if (plist-member src :preview-key) 2484 (plist-get src :preview-key) 2485 consult-preview-key))) 2486 (ensure-list key))) 2487 sources)))) 2488 2489 (defun consult--multi-lookup (sources selected candidates _input narrow &rest _) 2490 "Lookup SELECTED in CANDIDATES given SOURCES, with potential NARROW." 2491 (unless (string-blank-p selected) 2492 (if-let (found (member selected candidates)) 2493 (cons (cdr (get-text-property 0 'multi-category (car found))) 2494 (consult--multi-source sources selected)) 2495 (let* ((tofu (consult--tofu-p (aref selected (1- (length selected))))) 2496 (src (cond 2497 (tofu (consult--multi-source sources selected)) 2498 (narrow (seq-find (lambda (src) 2499 (let ((n (plist-get src :narrow))) 2500 (eq (or (car-safe n) n -1) narrow))) 2501 sources)) 2502 ((seq-find (lambda (src) (plist-get src :default)) sources)) 2503 ((aref sources 0))))) 2504 `(,(if tofu (substring selected 0 -1) selected) :match nil ,@src))))) 2505 2506 (defun consult--multi-candidates (sources) 2507 "Return `consult--multi' candidates from SOURCES." 2508 (let ((def) (idx 0) (max-width 0) (candidates)) 2509 (seq-doseq (src sources) 2510 (let* ((face (and (plist-member src :face) `(face ,(plist-get src :face)))) 2511 (cat (plist-get src :category)) 2512 (items (plist-get src :items)) 2513 (items (if (functionp items) (funcall items) items))) 2514 (when (and (not def) (plist-get src :default) items) 2515 (setq def (consult--tofu-append (car items) idx))) 2516 (dolist (item items) 2517 (let ((cand (consult--tofu-append item idx)) 2518 (width (consult--display-width item))) 2519 ;; Preserve existing `multi-category' datum of the candidate. 2520 (if (get-text-property 0 'multi-category cand) 2521 (when face (add-text-properties 0 (length item) face cand)) 2522 ;; Attach `multi-category' datum and face. 2523 (add-text-properties 0 (length item) 2524 `(multi-category (,cat . ,item) ,@face) cand)) 2525 (when (> width max-width) (setq max-width width)) 2526 (push cand candidates)))) 2527 (cl-incf idx)) 2528 (list def (+ 3 max-width) (nreverse candidates)))) 2529 2530 (defun consult--multi-enabled-sources (sources) 2531 "Return vector of enabled SOURCES." 2532 (vconcat 2533 (seq-filter (lambda (src) 2534 (if-let (pred (plist-get src :enabled)) 2535 (funcall pred) 2536 t)) 2537 (mapcar (lambda (src) 2538 (if (symbolp src) (symbol-value src) src)) 2539 sources)))) 2540 2541 (defun consult--multi-state (sources) 2542 "State function given SOURCES." 2543 (when-let (states (delq nil (mapcar (lambda (src) 2544 (when-let (fun (plist-get src :state)) 2545 (cons src (funcall fun)))) 2546 sources))) 2547 (let (last-fun) 2548 (pcase-lambda (action `(,cand . ,src)) 2549 (pcase action 2550 ('setup 2551 (pcase-dolist (`(,_ . ,fun) states) 2552 (funcall fun 'setup nil))) 2553 ('exit 2554 (pcase-dolist (`(,_ . ,fun) states) 2555 (funcall fun 'exit nil))) 2556 ('preview 2557 (let ((selected-fun (cdr (assq src states)))) 2558 ;; If the candidate source changed during preview communicate to 2559 ;; the last source, that none of its candidates is previewed anymore. 2560 (when (and last-fun (not (eq last-fun selected-fun))) 2561 (funcall last-fun 'preview nil)) 2562 (setq last-fun selected-fun) 2563 (when selected-fun 2564 (funcall selected-fun 'preview cand)))) 2565 ('return 2566 (let ((selected-fun (cdr (assq src states)))) 2567 ;; Finish all the sources, except the selected one. 2568 (pcase-dolist (`(,_ . ,fun) states) 2569 (unless (eq fun selected-fun) 2570 (funcall fun 'return nil))) 2571 ;; Finish the source with the selected candidate 2572 (when selected-fun 2573 (funcall selected-fun 'return cand))))))))) 2574 2575 (defun consult--multi (sources &rest options) 2576 "Select from candidates taken from a list of SOURCES. 2577 2578 OPTIONS is the plist of options passed to `consult--read'. The following 2579 options are supported: :require-match, :history, :keymap, :initial, 2580 :add-history, :sort and :inherit-input-method. The other options of 2581 `consult--read' are used by the implementation of `consult--multi' and 2582 should be overwritten only in special scenarios. 2583 2584 The function returns the selected candidate in the form (cons candidate 2585 source-plist). The plist has the key :match with a value nil if the 2586 candidate does not exist, t if the candidate exists and `new' if the 2587 candidate has been created. The sources of the source list can either be 2588 symbols of source variables or source values. Source values must be 2589 plists with the following fields: 2590 2591 Required source fields: 2592 * :category - Completion category. 2593 * :items - List of strings to select from or function returning list of strings. 2594 2595 Optional source fields: 2596 * :name - Name of the source, used for narrowing, group titles and annotations. 2597 * :narrow - Narrowing character or (character . string) pair. 2598 * :enabled - Function which must return t if the source is enabled. 2599 * :hidden - When t candidates of this source are hidden by default. 2600 * :face - Face used for highlighting the candidates. 2601 * :annotate - Annotation function called for each candidate, returns string. 2602 * :history - Name of history variable to add selected candidate. 2603 * :default - Must be t if the first item of the source is the default value. 2604 * :action - Function called with the selected candidate. 2605 * :new - Function called with new candidate name, only if :require-match is nil. 2606 * :state - State constructor for the source, must return the state function. 2607 * Other source fields can be added specifically to the use case." 2608 (let* ((sources (consult--multi-enabled-sources sources)) 2609 (candidates (consult--with-increased-gc 2610 (consult--multi-candidates sources))) 2611 (align (propertize 2612 " " 'display 2613 `(space :align-to (+ left ,(cadr candidates))))) 2614 (selected (apply #'consult--read 2615 (caddr candidates) 2616 (append 2617 options 2618 (list 2619 :default (car candidates) 2620 :category 'multi-category 2621 :predicate (apply-partially #'consult--multi-predicate sources) 2622 :annotate (apply-partially #'consult--multi-annotate sources align) 2623 :group (apply-partially #'consult--multi-group sources) 2624 :lookup (apply-partially #'consult--multi-lookup sources) 2625 :preview-key (consult--multi-preview-key sources) 2626 :narrow (consult--multi-narrow sources) 2627 :state (consult--multi-state sources)))))) 2628 (when-let (history (plist-get (cdr selected) :history)) 2629 (add-to-history history (car selected))) 2630 (if (plist-member (cdr selected) :match) 2631 (when-let (fun (plist-get (cdr selected) :new)) 2632 (funcall fun (car selected)) 2633 (plist-put (cdr selected) :match 'new)) 2634 (when-let (fun (plist-get (cdr selected) :action)) 2635 (funcall fun (car selected))) 2636 (setq selected `(,(car selected) :match t ,@(cdr selected)))) 2637 selected)) 2638 2639 ;;;; Internal API: consult--prompt 2640 2641 (cl-defun consult--prompt-1 (&key prompt history add-history initial default 2642 keymap state preview-key transform inherit-input-method) 2643 "See `consult--prompt' for documentation." 2644 (consult--minibuffer-with-setup-hook 2645 (:append (lambda () 2646 (consult--setup-keymap keymap nil nil preview-key) 2647 (setq-local minibuffer-default-add-function 2648 (apply-partially #'consult--add-history nil add-history)))) 2649 (car (consult--with-preview 2650 preview-key state 2651 (lambda (_narrow inp _cand) (funcall transform inp)) #'always 2652 (read-from-minibuffer prompt initial nil nil history default inherit-input-method))))) 2653 2654 (cl-defun consult--prompt (&rest options &key prompt history add-history initial default 2655 keymap state preview-key transform inherit-input-method) 2656 "Read from minibuffer. 2657 2658 Keyword OPTIONS: 2659 2660 PROMPT is the string to prompt with. 2661 TRANSFORM is a function which is applied to the current input string. 2662 HISTORY is the symbol of the history variable. 2663 INITIAL is initial input. 2664 DEFAULT is the default selected value. 2665 ADD-HISTORY is a list of items to add to the history. 2666 STATE is the state function, see `consult--with-preview'. 2667 PREVIEW-KEY are the preview keys (nil, \\='any, a single key or a list of keys). 2668 KEYMAP is a command-specific keymap." 2669 (ignore prompt history add-history initial default 2670 keymap state preview-key transform inherit-input-method) 2671 (apply #'consult--prompt-1 2672 (append 2673 (consult--customize-get) 2674 options 2675 (list :prompt "Input: " 2676 :preview-key consult-preview-key 2677 :transform #'identity)))) 2678 2679 ;;;; Commands 2680 2681 ;;;;; Command: consult-completion-in-region 2682 2683 (defun consult--insertion-preview (start end) 2684 "State function for previewing a candidate in a specific region. 2685 The candidates are previewed in the region from START to END. This function is 2686 used as the `:state' argument for `consult--read' in the `consult-yank' family 2687 of functions and in `consult-completion-in-region'." 2688 (unless (or (minibufferp) 2689 ;; XXX Disable preview if anything odd is going on with the markers. Otherwise we get 2690 ;; "Marker points into wrong buffer errors". See 2691 ;; https://github.com/minad/consult/issues/375, where Org mode source blocks are 2692 ;; completed in a different buffer than the original buffer. This completion is 2693 ;; probably also problematic in my Corfu completion package. 2694 (not (eq (window-buffer) (current-buffer))) 2695 (and (markerp start) (not (eq (marker-buffer start) (current-buffer)))) 2696 (and (markerp end) (not (eq (marker-buffer end) (current-buffer))))) 2697 (let (ov) 2698 (lambda (action cand) 2699 (cond 2700 ((and (not cand) ov) 2701 (delete-overlay ov) 2702 (setq ov nil)) 2703 ((and (eq action 'preview) cand) 2704 (unless ov 2705 (setq ov (consult--overlay start end 2706 'invisible t 2707 'window (selected-window)))) 2708 ;; Use `add-face-text-property' on a copy of "cand in order to merge face properties 2709 (setq cand (copy-sequence cand)) 2710 (add-face-text-property 0 (length cand) 'consult-preview-insertion t cand) 2711 ;; Use the `before-string' property since the overlay might be empty. 2712 (overlay-put ov 'before-string cand))))))) 2713 2714 ;;;###autoload 2715 (defun consult-completion-in-region (start end collection &optional predicate) 2716 "Use minibuffer completion as the UI for `completion-at-point'. 2717 2718 The function is called with 4 arguments: START END COLLECTION PREDICATE. 2719 The arguments and expected return value are as specified for 2720 `completion-in-region'. Use as a value for `completion-in-region-function'. 2721 2722 The function can be configured via `consult-customize'. 2723 2724 (consult-customize consult-completion-in-region 2725 :completion-styles (basic) 2726 :cycle-threshold 3) 2727 2728 These configuration options are supported: 2729 2730 * :cycle-threshold - Cycling threshold (def: `completion-cycle-threshold') 2731 * :completion-styles - Use completion styles (def: `completion-styles') 2732 * :require-match - Require matches when completing (def: nil) 2733 * :prompt - The prompt string shown in the minibuffer" 2734 (barf-if-buffer-read-only) 2735 (cl-letf* ((config (consult--customize-get #'consult-completion-in-region)) 2736 ;; Overwrite both the local and global value of `completion-styles', such that the 2737 ;; `completing-read' minibuffer sees the overwritten value in any case. This is 2738 ;; necessary if `completion-styles' is buffer-local. 2739 ;; NOTE: The completion-styles will be overwritten for recursive editing sessions! 2740 (cs (or (plist-get config :completion-styles) completion-styles)) 2741 (completion-styles cs) 2742 ((default-value 'completion-styles) cs) 2743 (prompt (or (plist-get config :prompt) "Completion: ")) 2744 (require-match (plist-get config :require-match)) 2745 (preview-key (if (plist-member config :preview-key) 2746 (plist-get config :preview-key) 2747 consult-preview-key)) 2748 (initial (buffer-substring-no-properties start end)) 2749 (metadata (completion-metadata initial collection predicate)) 2750 (threshold (or (plist-get config :cycle-threshold) (completion--cycle-threshold metadata))) 2751 (all (completion-all-completions initial collection predicate (length initial))) 2752 ;; Wrap all annotation functions to ensure that they are executed 2753 ;; in the original buffer. 2754 (exit-fun (plist-get completion-extra-properties :exit-function)) 2755 (ann-fun (plist-get completion-extra-properties :annotation-function)) 2756 (aff-fun (plist-get completion-extra-properties :affixation-function)) 2757 (docsig-fun (plist-get completion-extra-properties :company-docsig)) 2758 (completion-extra-properties 2759 `(,@(and ann-fun (list :annotation-function (consult--in-buffer ann-fun))) 2760 ,@(and aff-fun (list :affixation-function (consult--in-buffer aff-fun))) 2761 ;; Provide `:annotation-function' if `:company-docsig' is specified. 2762 ,@(and docsig-fun (not ann-fun) (not aff-fun) 2763 (list :annotation-function 2764 (consult--in-buffer 2765 (lambda (cand) 2766 (concat (propertize " " 'display '(space :align-to center)) 2767 (funcall docsig-fun cand))))))))) 2768 ;; error if `threshold' is t or the improper list `all' is too short 2769 (if (and threshold 2770 (or (not (consp (ignore-errors (nthcdr threshold all)))) 2771 (and completion-cycling completion-all-sorted-completions))) 2772 (completion--in-region start end collection predicate) 2773 (let* ((limit (car (completion-boundaries initial collection predicate ""))) 2774 (category (completion-metadata-get metadata 'category)) 2775 (completion 2776 (cond 2777 ((atom all) nil) 2778 ((and (consp all) (atom (cdr all))) 2779 (concat (substring initial 0 limit) (car all))) 2780 (t (car 2781 (consult--with-preview 2782 preview-key 2783 ;; preview state 2784 (consult--insertion-preview start end) 2785 ;; transformation function 2786 (if (eq category 'file) 2787 (cond 2788 ;; Transform absolute file names 2789 ((file-name-absolute-p initial) 2790 (lambda (_narrow _inp cand) 2791 (substitute-in-file-name cand))) 2792 ;; Ensure that ./ prefix is kept for the shell (#356) 2793 ((string-match-p "\\`\\.\\.?/" initial) 2794 (lambda (_narrow _inp cand) 2795 (setq cand (file-relative-name (substitute-in-file-name cand))) 2796 (if (string-match-p "\\`\\.\\.?/" cand) cand (concat "./" cand)))) 2797 ;; Simplify relative file names 2798 (t 2799 (lambda (_narrow _inp cand) 2800 (file-relative-name (substitute-in-file-name cand))))) 2801 (lambda (_narrow _inp cand) cand)) 2802 ;; candidate function 2803 (apply-partially #'run-hook-with-args-until-success 2804 'consult--completion-candidate-hook) 2805 (consult--local-let ((enable-recursive-minibuffers t)) 2806 (if (eq category 'file) 2807 ;; We use read-file-name, since many completion UIs make it nicer to 2808 ;; navigate the file system this way; and we insert the initial text 2809 ;; directly into the minibuffer to allow the user's completion 2810 ;; styles to expand it as appropriate (particularly useful for the 2811 ;; partial-completion and initials styles, which allow for very 2812 ;; condensed path specification). 2813 (consult--minibuffer-with-setup-hook 2814 (lambda () (insert initial)) 2815 (read-file-name prompt nil initial require-match nil predicate)) 2816 ;; Evaluate completion table in the original buffer. 2817 ;; This is a reasonable thing to do and required by 2818 ;; some completion tables in particular by lsp-mode. 2819 ;; See https://github.com/minad/vertico/issues/61. 2820 (completing-read prompt 2821 (consult--completion-table-in-buffer collection) 2822 predicate require-match initial))))))))) 2823 (if completion 2824 (progn 2825 ;; bug#55205: completion--replace removes properties! 2826 (completion--replace start end (setq completion (concat completion))) 2827 (when exit-fun 2828 (funcall exit-fun completion 2829 ;; If completion is finished and cannot be further completed, 2830 ;; return 'finished. Otherwise return 'exact. 2831 (if (eq (try-completion completion collection predicate) t) 2832 'finished 'exact))) 2833 t) 2834 (message "No completion") 2835 nil))))) 2836 2837 ;;;;; Command: consult-outline 2838 2839 (defun consult--outline-candidates () 2840 "Return alist of outline headings and positions." 2841 (consult--forbid-minibuffer) 2842 (let* ((line (line-number-at-pos (point-min) consult-line-numbers-widen)) 2843 (heading-regexp (concat "^\\(?:" 2844 ;; default definition from outline.el 2845 (or (bound-and-true-p outline-regexp) "[*\^L]+") 2846 "\\)")) 2847 (heading-alist (bound-and-true-p outline-heading-alist)) 2848 (level-fun (or (bound-and-true-p outline-level) 2849 (lambda () ;; as in the default from outline.el 2850 (or (cdr (assoc (match-string 0) heading-alist)) 2851 (- (match-end 0) (match-beginning 0)))))) 2852 (inhibit-field-text-motion t) 2853 (buffer (current-buffer)) 2854 candidates) 2855 (save-excursion 2856 (goto-char (point-min)) 2857 (while (save-excursion 2858 (if-let (fun (bound-and-true-p outline-search-function)) 2859 (funcall fun) 2860 (re-search-forward heading-regexp nil t))) 2861 (cl-incf line (consult--count-lines (match-beginning 0))) 2862 (push (consult--location-candidate 2863 (consult--buffer-substring (line-beginning-position) 2864 (line-end-position) 2865 'fontify) 2866 (cons buffer (point)) line 2867 'consult--outline-level (funcall level-fun)) 2868 candidates) 2869 (unless (eobp) (forward-char 1)))) 2870 (unless candidates 2871 (user-error "No headings")) 2872 (nreverse candidates))) 2873 2874 ;;;###autoload 2875 (defun consult-outline () 2876 "Jump to an outline heading, obtained by matching against `outline-regexp'. 2877 2878 This command supports narrowing to a heading level and candidate preview. 2879 The symbol at point is added to the future history." 2880 (interactive) 2881 (let* ((candidates (consult--outline-candidates)) 2882 (min-level (- (apply #'min (mapcar 2883 (lambda (cand) 2884 (get-text-property 0 'consult--outline-level cand)) 2885 candidates)) 2886 ?1)) 2887 (narrow-pred (lambda (cand) 2888 (<= (get-text-property 0 'consult--outline-level cand) 2889 (+ consult--narrow min-level)))) 2890 (narrow-keys (mapcar (lambda (c) (cons c (format "Level %c" c))) 2891 (number-sequence ?1 ?9)))) 2892 (consult--read 2893 candidates 2894 :prompt "Go to heading: " 2895 :annotate (consult--line-prefix) 2896 :category 'consult-location 2897 :sort nil 2898 :require-match t 2899 :lookup #'consult--line-match 2900 :narrow `(:predicate ,narrow-pred :keys ,narrow-keys) 2901 :history '(:input consult--line-history) 2902 :add-history (thing-at-point 'symbol) 2903 :state (consult--location-state candidates)))) 2904 2905 ;;;;; Command: consult-mark 2906 2907 (defun consult--mark-candidates (markers) 2908 "Return list of candidates strings for MARKERS." 2909 (consult--forbid-minibuffer) 2910 (let ((candidates) 2911 (current-buf (current-buffer))) 2912 (save-excursion 2913 (dolist (marker markers) 2914 (when-let ((pos (marker-position marker)) 2915 (buf (marker-buffer marker))) 2916 (when (and (eq buf current-buf) 2917 (consult--in-range-p pos)) 2918 (goto-char pos) 2919 ;; `line-number-at-pos' is a very slow function, which should be replaced everywhere. 2920 ;; However in this case the slow line-number-at-pos does not hurt much, since 2921 ;; the mark ring is usually small since it is limited by `mark-ring-max'. 2922 (push (consult--location-candidate 2923 (consult--line-with-cursor marker) marker 2924 (line-number-at-pos pos consult-line-numbers-widen)) 2925 candidates))))) 2926 (unless candidates 2927 (user-error "No marks")) 2928 (nreverse (delete-dups candidates)))) 2929 2930 ;;;###autoload 2931 (defun consult-mark (&optional markers) 2932 "Jump to a marker in MARKERS list (defaults to buffer-local `mark-ring'). 2933 2934 The command supports preview of the currently selected marker position. 2935 The symbol at point is added to the future history." 2936 (interactive) 2937 (consult--read 2938 (consult--mark-candidates 2939 (or markers (cons (mark-marker) mark-ring))) 2940 :prompt "Go to mark: " 2941 :annotate (consult--line-prefix) 2942 :category 'consult-location 2943 :sort nil 2944 :require-match t 2945 :lookup #'consult--lookup-location 2946 :history '(:input consult--line-history) 2947 :add-history (thing-at-point 'symbol) 2948 :state (consult--jump-state))) 2949 2950 ;;;;; Command: consult-global-mark 2951 2952 (defun consult--global-mark-candidates (markers) 2953 "Return list of candidates strings for MARKERS." 2954 (consult--forbid-minibuffer) 2955 (let ((candidates)) 2956 (save-excursion 2957 (dolist (marker markers) 2958 (when-let ((pos (marker-position marker)) 2959 (buf (marker-buffer marker))) 2960 (unless (minibufferp buf) 2961 (with-current-buffer buf 2962 (when (consult--in-range-p pos) 2963 (goto-char pos) 2964 ;; `line-number-at-pos' is slow, see comment in `consult--mark-candidates'. 2965 (let ((line (line-number-at-pos pos consult-line-numbers-widen))) 2966 (push (concat 2967 (propertize (consult--format-location (buffer-name buf) line "") 2968 'consult-location (cons marker line) 2969 'consult-strip t) 2970 (consult--line-with-cursor marker) 2971 (consult--tofu-encode marker)) 2972 candidates)))))))) 2973 (unless candidates 2974 (user-error "No global marks")) 2975 (nreverse (delete-dups candidates)))) 2976 2977 ;;;###autoload 2978 (defun consult-global-mark (&optional markers) 2979 "Jump to a marker in MARKERS list (defaults to `global-mark-ring'). 2980 2981 The command supports preview of the currently selected marker position. 2982 The symbol at point is added to the future history." 2983 (interactive) 2984 (consult--read 2985 (consult--global-mark-candidates 2986 (or markers global-mark-ring)) 2987 :prompt "Go to global mark: " 2988 ;; Despite `consult-global-mark' formating the candidates in grep-like 2989 ;; style, we are not using the 'consult-grep category, since the candidates 2990 ;; have location markers attached. 2991 :category 'consult-location 2992 :sort nil 2993 :require-match t 2994 :lookup #'consult--lookup-location 2995 :history '(:input consult--line-history) 2996 :add-history (thing-at-point 'symbol) 2997 :state (consult--jump-state))) 2998 2999 ;;;;; Command: consult-line 3000 3001 (defun consult--line-candidates (top curr-line) 3002 "Return list of line candidates. 3003 Start from top if TOP non-nil. 3004 CURR-LINE is the current line number." 3005 (consult--forbid-minibuffer) 3006 (consult--fontify-all) 3007 (let* (default-cand candidates 3008 (buffer (current-buffer)) 3009 (line (line-number-at-pos (point-min) consult-line-numbers-widen))) 3010 (consult--each-line beg end 3011 (let ((str (consult--buffer-substring beg end))) 3012 (unless (string-blank-p str) 3013 (push (consult--location-candidate str (cons buffer (point)) line) candidates) 3014 (when (and (not default-cand) (>= line curr-line)) 3015 (setq default-cand candidates))) 3016 (cl-incf line))) 3017 (when candidates 3018 (nreverse 3019 (if (or top (not default-cand)) 3020 candidates 3021 (let ((before (cdr default-cand))) 3022 (setcdr default-cand nil) 3023 (nconc before candidates))))))) 3024 3025 (defun consult--line-point-placement (selected candidates highlighted &rest ignored-faces) 3026 "Find point position on matching line. 3027 SELECTED is the currently selected candidate. 3028 CANDIDATES is the list of candidates. 3029 HIGHLIGHTED is the highlighted string to determine the match position. 3030 IGNORED-FACES are ignored when determining the match position." 3031 (when-let (pos (consult--lookup-location selected candidates)) 3032 (if highlighted 3033 (let* ((matches (apply #'consult--point-placement highlighted 0 ignored-faces)) 3034 (dest (+ pos (car matches)))) 3035 ;; Only create a new marker when jumping across buffers (for example 3036 ;; `consult-line-multi'). Avoid creating unnecessary markers, when 3037 ;; scrolling through candidates, since creating markers is not free. 3038 (when (and (markerp pos) (not (eq (marker-buffer pos) (current-buffer)))) 3039 (setq dest (move-marker (make-marker) dest (marker-buffer pos)))) 3040 (cons dest (cdr matches))) 3041 pos))) 3042 3043 (defun consult--line-match (selected candidates input &rest _) 3044 "Lookup position of match. 3045 SELECTED is the currently selected candidate. 3046 CANDIDATES is the list of candidates. 3047 INPUT is the input string entered by the user." 3048 (consult--line-point-placement selected candidates 3049 (and (not (string-blank-p input)) 3050 (car (consult--completion-filter 3051 input 3052 (list (substring-no-properties selected)) 3053 'consult-location 'highlight))) 3054 'completions-first-difference)) 3055 3056 ;;;###autoload 3057 (defun consult-line (&optional initial start) 3058 "Search for a matching line. 3059 3060 Depending on the setting `consult-point-placement' the command jumps to the 3061 beginning or the end of the first match on the line or the line beginning. The 3062 default candidate is the non-empty line next to point. This command obeys 3063 narrowing. Optional INITIAL input can be provided. The search starting point is 3064 changed if the START prefix argument is set. The symbol at point and the last 3065 `isearch-string' is added to the future history." 3066 (interactive (list nil (not (not current-prefix-arg)))) 3067 (let* ((curr-line (line-number-at-pos (point) consult-line-numbers-widen)) 3068 (top (not (eq start consult-line-start-from-top))) 3069 (candidates (or (consult--with-increased-gc 3070 (consult--line-candidates top curr-line)) 3071 (user-error "No lines")))) 3072 (consult--read 3073 candidates 3074 :prompt (if top "Go to line from top: " "Go to line: ") 3075 :annotate (consult--line-prefix curr-line) 3076 :category 'consult-location 3077 :sort nil 3078 :require-match t 3079 ;; Always add last isearch string to future history 3080 :add-history (list (thing-at-point 'symbol) isearch-string) 3081 :history '(:input consult--line-history) 3082 :lookup #'consult--line-match 3083 :default (car candidates) 3084 ;; Add isearch-string as initial input if starting from isearch 3085 :initial (or initial 3086 (and isearch-mode 3087 (prog1 isearch-string (isearch-done)))) 3088 :state (consult--location-state candidates)))) 3089 3090 ;;;;; Command: consult-line-multi 3091 3092 (defun consult--line-multi-match (selected candidates &rest _) 3093 "Lookup position of match. 3094 SELECTED is the currently selected candidate. 3095 CANDIDATES is the list of candidates." 3096 (consult--line-point-placement selected candidates 3097 (car (member selected candidates)))) 3098 3099 (defun consult--line-multi-group (cand transform) 3100 "Group function used by `consult-line-multi'. 3101 If TRANSFORM non-nil, return transformed CAND, otherwise return title." 3102 (if transform 3103 cand 3104 (let ((marker (car (get-text-property 0 'consult-location cand)))) 3105 (buffer-name 3106 ;; Handle cheap marker 3107 (if (consp marker) 3108 (car marker) 3109 (marker-buffer marker)))))) 3110 3111 (defun consult--line-multi-candidates (buffers input) 3112 "Collect matching candidates from multiple buffers. 3113 INPUT is the user input which should be matched. 3114 BUFFERS is the list of buffers." 3115 (pcase-let ((`(,regexps . ,hl) 3116 (funcall consult--regexp-compiler 3117 input 'emacs completion-ignore-case)) 3118 (candidates nil) 3119 (inhibit-field-text-motion t)) 3120 (setq regexps (mapcar (lambda (x) (format "^.*?\\(?:%s\\)" x)) regexps)) 3121 (dolist (buf buffers (nreverse candidates)) 3122 (with-current-buffer buf 3123 (save-excursion 3124 (save-match-data 3125 (let ((line (line-number-at-pos (point-min) consult-line-numbers-widen))) 3126 (goto-char (point-min)) 3127 (while (save-excursion (re-search-forward (car regexps) nil t)) 3128 (cl-incf line (consult--count-lines (match-beginning 0))) 3129 (let ((beg (line-beginning-position)) 3130 (end (line-end-position))) 3131 (when (seq-every-p 3132 (lambda (x) (save-excursion (re-search-forward x end t))) 3133 (cdr regexps)) 3134 (let ((cand (buffer-substring-no-properties beg end))) 3135 (funcall hl cand) 3136 (push (consult--location-candidate cand (cons buf beg) line) 3137 candidates)))) 3138 (unless (eobp) (forward-char 1)))))))))) 3139 3140 ;;;###autoload 3141 (defun consult-line-multi (query &optional initial) 3142 "Search for a matching line in multiple buffers. 3143 3144 By default search across all project buffers. If the prefix 3145 argument QUERY is non-nil, all buffers are searched. Optional 3146 INITIAL input can be provided. The symbol at point and the last 3147 `isearch-string' is added to the future history.In order to 3148 search a subset of buffers, QUERY can be set to a plist according 3149 to `consult--buffer-query'." 3150 (interactive "P") 3151 (unless (keywordp (car-safe query)) 3152 (setq query (list :sort 'alpha-current :directory (and (not query) 'project)))) 3153 (pcase-let* ((`(,prompt . ,buffers) (consult--buffer-query-prompt "Go to line" query)) 3154 (collection (consult--dynamic-collection 3155 (apply-partially #'consult--line-multi-candidates 3156 buffers)))) 3157 (consult--read 3158 collection 3159 :prompt prompt 3160 :annotate (consult--line-prefix) 3161 :category 'consult-location 3162 :sort nil 3163 :require-match t 3164 ;; Always add last isearch string to future history 3165 :add-history (mapcar #'consult--async-split-initial 3166 (delq nil (list (thing-at-point 'symbol) 3167 isearch-string))) 3168 :history '(:input consult--line-multi-history) 3169 :lookup #'consult--line-multi-match 3170 ;; Add isearch-string as initial input if starting from isearch 3171 :initial (consult--async-split-initial 3172 (or initial 3173 (and isearch-mode 3174 (prog1 isearch-string (isearch-done))))) 3175 :state (consult--location-state (lambda () (funcall collection nil))) 3176 :group #'consult--line-multi-group))) 3177 3178 ;;;;; Command: consult-keep-lines 3179 3180 (defun consult--keep-lines-state (filter) 3181 "State function for `consult-keep-lines' with FILTER function." 3182 (let ((font-lock-orig font-lock-mode) 3183 (hl-line-orig (bound-and-true-p hl-line-mode)) 3184 (point-orig (point)) 3185 lines content-orig replace last-input) 3186 (if (use-region-p) 3187 (save-restriction 3188 ;; Use the same behavior as `keep-lines'. 3189 (let ((rbeg (region-beginning)) 3190 (rend (save-excursion 3191 (goto-char (region-end)) 3192 (unless (or (bolp) (eobp)) 3193 (forward-line 0)) 3194 (point)))) 3195 (consult--fontify-region rbeg rend) 3196 (narrow-to-region rbeg rend) 3197 (consult--each-line beg end 3198 (push (consult--buffer-substring beg end) lines)) 3199 (setq content-orig (buffer-string) 3200 replace (lambda (content &optional pos) 3201 (delete-region rbeg rend) 3202 (insert-before-markers content) 3203 (goto-char (or pos rbeg)) 3204 (setq rend (+ rbeg (length content))) 3205 (add-face-text-property rbeg rend 'region t))))) 3206 (consult--fontify-all) 3207 (setq content-orig (buffer-string) 3208 replace (lambda (content &optional pos) 3209 (delete-region (point-min) (point-max)) 3210 (insert content) 3211 (goto-char (or pos (point-min))))) 3212 (consult--each-line beg end 3213 (push (consult--buffer-substring beg end) lines))) 3214 (setq lines (nreverse lines)) 3215 (lambda (action input) 3216 ;; Restoring content and point position 3217 (when (and (eq action 'return) last-input) 3218 ;; No undo recording, modification hooks, buffer modified-status 3219 (with-silent-modifications (funcall replace content-orig point-orig))) 3220 ;; Committing or new input provided -> Update 3221 (when (and input ;; Input has been povided 3222 (or 3223 ;; Committing, but not with empty input 3224 (and (eq action 'return) (not (string-match-p "\\`!? ?\\'" input))) 3225 ;; Input has changed 3226 (not (equal input last-input)))) 3227 (let ((filtered-content 3228 (if (string-match-p "\\`!? ?\\'" input) 3229 ;; Special case the empty input for performance. 3230 ;; Otherwise it could happen that the minibuffer is empty, 3231 ;; but the buffer has not been updated. 3232 content-orig 3233 (if (eq action 'return) 3234 (apply #'concat (mapcan (lambda (x) (list x "\n")) 3235 (funcall filter input lines))) 3236 (while-no-input 3237 ;; Heavy computation is interruptible if *not* committing! 3238 ;; Allocate new string candidates since the matching function mutates! 3239 (apply #'concat (mapcan (lambda (x) (list x "\n")) 3240 (funcall filter input (mapcar #'copy-sequence lines))))))))) 3241 (when (stringp filtered-content) 3242 (when font-lock-mode (font-lock-mode -1)) 3243 (when (bound-and-true-p hl-line-mode) (hl-line-mode -1)) 3244 (if (eq action 'return) 3245 (atomic-change-group 3246 ;; Disable modification hooks for performance 3247 (let ((inhibit-modification-hooks t)) 3248 (funcall replace filtered-content))) 3249 ;; No undo recording, modification hooks, buffer modified-status 3250 (with-silent-modifications 3251 (funcall replace filtered-content) 3252 (setq last-input input)))))) 3253 ;; Restore modes 3254 (when (eq action 'return) 3255 (when hl-line-orig (hl-line-mode 1)) 3256 (when font-lock-orig (font-lock-mode 1)))))) 3257 3258 ;;;###autoload 3259 (defun consult-keep-lines (&optional filter initial) 3260 "Select a subset of the lines in the current buffer with live preview. 3261 3262 The selected lines are kept and the other lines are deleted. When called 3263 interactively, the lines selected are those that match the minibuffer input. In 3264 order to match the inverse of the input, prefix the input with `! '. When 3265 called from elisp, the filtering is performed by a FILTER function. This 3266 command obeys narrowing. 3267 3268 FILTER is the filter function. 3269 INITIAL is the initial input." 3270 (interactive 3271 (list (lambda (pattern cands) 3272 ;; Use consult-location completion category when filtering lines 3273 (consult--completion-filter-dispatch 3274 pattern cands 'consult-location 'highlight)))) 3275 (consult--forbid-minibuffer) 3276 (let ((ro buffer-read-only)) 3277 (unwind-protect 3278 (consult--minibuffer-with-setup-hook 3279 (lambda () 3280 (when ro 3281 (minibuffer-message 3282 (substitute-command-keys 3283 " [Unlocked read-only buffer. \\[minibuffer-keyboard-quit] to quit.]")))) 3284 (setq buffer-read-only nil) 3285 (consult--with-increased-gc 3286 (consult--prompt 3287 :prompt "Keep lines: " 3288 :initial initial 3289 :history 'consult--keep-lines-history 3290 :state (consult--keep-lines-state filter)))) 3291 (setq buffer-read-only ro)))) 3292 3293 ;;;;; Command: consult-focus-lines 3294 3295 (defun consult--focus-lines-state (filter) 3296 "State function for `consult-focus-lines' with FILTER function." 3297 (let (lines overlays last-input pt-orig pt-min pt-max) 3298 (save-excursion 3299 (save-restriction 3300 (if (not (use-region-p)) 3301 (consult--fontify-all) 3302 (consult--fontify-region (region-beginning) (region-end)) 3303 (narrow-to-region 3304 (region-beginning) 3305 ;; Behave the same as `keep-lines'. 3306 ;; Move to the next line. 3307 (save-excursion 3308 (goto-char (region-end)) 3309 (unless (or (bolp) (eobp)) 3310 (forward-line 0)) 3311 (point)))) 3312 (setq pt-orig (point) pt-min (point-min) pt-max (point-max)) 3313 (let ((i 0)) 3314 (consult--each-line beg end 3315 ;; NOTE: Use "\n" for empty lines, since we need 3316 ;; a string to attach the text property to. 3317 (let ((line (if (eq beg end) (char-to-string ?\n) 3318 (buffer-substring-no-properties beg end)))) 3319 (put-text-property 0 1 'consult--focus-line (cons (cl-incf i) beg) line) 3320 (push line lines))) 3321 (setq lines (nreverse lines))))) 3322 (lambda (action input) 3323 ;; New input provided -> Update 3324 (when (and input (not (equal input last-input))) 3325 (let (new-overlays) 3326 (pcase (while-no-input 3327 (unless (string-match-p "\\`!? ?\\'" input) ;; empty input. 3328 (let* ((inhibit-quit (eq action 'return)) ;; Non interruptible, when quitting! 3329 (not (string-prefix-p "! " input)) 3330 (stripped (string-remove-prefix "! " input)) 3331 (matches (funcall filter stripped lines)) 3332 (old-ind 0) 3333 (block-beg pt-min) 3334 (block-end pt-min)) 3335 (while old-ind 3336 (let ((match (pop matches)) (ind nil) (beg pt-max) (end pt-max) prop) 3337 (when match 3338 (setq prop (get-text-property 0 'consult--focus-line match) 3339 ind (car prop) 3340 beg (cdr prop) 3341 ;; NOTE: Check for empty lines, see above! 3342 end (+ 1 beg (if (equal match "\n") 0 (length match))))) 3343 (unless (eq ind (1+ old-ind)) 3344 (let ((a (if not block-beg block-end)) 3345 (b (if not block-end beg))) 3346 (when (/= a b) 3347 (push (consult--overlay a b 'invisible t) new-overlays))) 3348 (setq block-beg beg)) 3349 (setq block-end end old-ind ind))))) 3350 'commit) 3351 ('commit 3352 (mapc #'delete-overlay overlays) 3353 (setq last-input input overlays new-overlays)) 3354 (_ (mapc #'delete-overlay new-overlays))))) 3355 (when (eq action 'return) 3356 (cond 3357 ((not input) 3358 (mapc #'delete-overlay overlays) 3359 (goto-char pt-orig)) 3360 ((equal input "") 3361 (consult-focus-lines 'show) 3362 (goto-char pt-orig)) 3363 (t 3364 ;; Sucessfully terminated -> Remember invisible overlays 3365 (setq consult--focus-lines-overlays 3366 (nconc consult--focus-lines-overlays overlays)) 3367 ;; move point past invisible 3368 (goto-char (if-let (ov (and (invisible-p pt-orig) 3369 (seq-find (lambda (ov) (overlay-get ov 'invisible)) 3370 (overlays-at pt-orig)))) 3371 (overlay-end ov) 3372 pt-orig)))))))) 3373 3374 ;;;###autoload 3375 (defun consult-focus-lines (&optional show filter initial) 3376 "Hide or show lines using overlays. 3377 3378 The selected lines are shown and the other lines hidden. When called 3379 interactively, the lines selected are those that match the minibuffer input. In 3380 order to match the inverse of the input, prefix the input with `! '. With 3381 optional prefix argument SHOW reveal the hidden lines. Alternatively the 3382 command can be restarted to reveal the lines. When called from elisp, the 3383 filtering is performed by a FILTER function. This command obeys narrowing. 3384 3385 FILTER is the filter function. 3386 INITIAL is the initial input." 3387 (interactive 3388 (list current-prefix-arg 3389 (lambda (pattern cands) 3390 ;; Use consult-location completion category when filtering lines 3391 (consult--completion-filter-dispatch 3392 pattern cands 'consult-location nil)))) 3393 (if show 3394 (progn 3395 (mapc #'delete-overlay consult--focus-lines-overlays) 3396 (setq consult--focus-lines-overlays nil) 3397 (message "All lines revealed")) 3398 (consult--forbid-minibuffer) 3399 (consult--with-increased-gc 3400 (consult--prompt 3401 :prompt 3402 (if consult--focus-lines-overlays 3403 "Focus on lines (RET to reveal): " 3404 "Focus on lines: ") 3405 :initial initial 3406 :history 'consult--keep-lines-history 3407 :state (consult--focus-lines-state filter))))) 3408 3409 ;;;;; Command: consult-goto-line 3410 3411 (defun consult--goto-line-position (str msg) 3412 "Transform input STR to line number. 3413 Print an error message with MSG function." 3414 (if-let (line (and str 3415 (string-match-p "\\`[[:digit:]]+\\'" str) 3416 (string-to-number str))) 3417 (let ((pos (save-excursion 3418 (save-restriction 3419 (when consult-line-numbers-widen 3420 (widen)) 3421 (goto-char (point-min)) 3422 (forward-line (1- line)) 3423 (point))))) 3424 (if (consult--in-range-p pos) 3425 pos 3426 (funcall msg "Line number out of range.") 3427 nil)) 3428 (when (and str (not (string= str ""))) 3429 (funcall msg "Please enter a number.")) 3430 nil)) 3431 3432 ;;;###autoload 3433 (defun consult-goto-line (&optional arg) 3434 "Read line number and jump to the line with preview. 3435 3436 Jump directly if a line number is given as prefix ARG. The command respects 3437 narrowing and the settings `consult-goto-line-numbers' and 3438 `consult-line-numbers-widen'." 3439 (interactive "P") 3440 (if arg 3441 (call-interactively #'goto-line) 3442 (consult--forbid-minibuffer) 3443 (consult--local-let ((display-line-numbers consult-goto-line-numbers) 3444 (display-line-numbers-widen consult-line-numbers-widen)) 3445 (while (if-let (pos (consult--goto-line-position 3446 (consult--prompt 3447 :prompt "Go to line: " 3448 ;; goto-line-history is available on Emacs 28 3449 :history 3450 (and (boundp 'goto-line-history) 'goto-line-history) 3451 :state 3452 (let ((preview (consult--jump-preview))) 3453 (lambda (action str) 3454 (funcall preview action 3455 (consult--goto-line-position str #'ignore))))) 3456 #'minibuffer-message)) 3457 (consult--jump pos) 3458 t))))) 3459 3460 ;;;;; Command: consult-recent-file 3461 3462 (defun consult--file-preview () 3463 "Create preview function for files." 3464 (let ((open (consult--temporary-files)) 3465 (preview (consult--buffer-preview))) 3466 (lambda (action cand) 3467 (unless cand 3468 (funcall open)) 3469 (funcall preview action 3470 (and cand 3471 (eq action 'preview) 3472 (funcall open cand)))))) 3473 3474 (defun consult--file-action (file) 3475 "Open FILE via `consult--buffer-action'." 3476 (consult--buffer-action (find-file-noselect file))) 3477 3478 (consult--define-state file) 3479 3480 ;;;###autoload 3481 (defun consult-recent-file () 3482 "Find recent file using `completing-read'." 3483 (interactive) 3484 (find-file 3485 (consult--read 3486 (or 3487 (let (file-name-handler-alist) ;; No Tramp slowdown please 3488 (mapcar #'abbreviate-file-name recentf-list)) 3489 (user-error "No recent files, `recentf-mode' is %s" 3490 (if recentf-mode "on" "off"))) 3491 :prompt "Find recent file: " 3492 :sort nil 3493 :require-match t 3494 :category 'file 3495 :state (consult--file-preview) 3496 :history 'file-name-history))) 3497 3498 ;;;;; Command: consult-mode-command 3499 3500 (defun consult--mode-name (mode) 3501 "Return name part of MODE." 3502 (replace-regexp-in-string 3503 "global-\\(.*\\)-mode" "\\1" 3504 (replace-regexp-in-string 3505 "\\(-global\\)?-mode\\'" "" 3506 (if (eq mode 'c-mode) 3507 "cc" 3508 (symbol-name mode)) 3509 'fixedcase) 3510 'fixedcase)) 3511 3512 (defun consult--mode-command-candidates (modes) 3513 "Extract commands from MODES. 3514 3515 The list of features is searched for files belonging to the modes. 3516 From these files, the commands are extracted." 3517 (let* ((buffer (current-buffer)) 3518 (command-filter (consult--regexp-filter (seq-filter #'stringp consult-mode-command-filter))) 3519 (feature-filter (seq-filter #'symbolp consult-mode-command-filter)) 3520 (minor-hash (consult--string-hash minor-mode-list)) 3521 (minor-local-modes (seq-filter (lambda (m) 3522 (and (gethash m minor-hash) 3523 (local-variable-if-set-p m))) 3524 modes)) 3525 (minor-global-modes (seq-filter (lambda (m) 3526 (and (gethash m minor-hash) 3527 (not (local-variable-if-set-p m)))) 3528 modes)) 3529 (major-modes (seq-remove (lambda (m) 3530 (gethash m minor-hash)) 3531 modes)) 3532 (major-paths-hash (consult--string-hash (mapcar #'symbol-file major-modes))) 3533 (minor-local-paths-hash (consult--string-hash (mapcar #'symbol-file minor-local-modes))) 3534 (minor-global-paths-hash (consult--string-hash (mapcar #'symbol-file minor-global-modes))) 3535 (major-name-regexp (regexp-opt (mapcar #'consult--mode-name major-modes))) 3536 (minor-local-name-regexp (regexp-opt (mapcar #'consult--mode-name minor-local-modes))) 3537 (minor-global-name-regexp (regexp-opt (mapcar #'consult--mode-name minor-global-modes))) 3538 (commands)) 3539 (dolist (feature load-history commands) 3540 (when-let (name (alist-get 'provide feature)) 3541 (let* ((path (car feature)) 3542 (file (file-name-nondirectory path)) 3543 (key (cond 3544 ((memq name feature-filter) nil) 3545 ((or (gethash path major-paths-hash) 3546 (string-match-p major-name-regexp file)) 3547 ?m) 3548 ((or (gethash path minor-local-paths-hash) 3549 (string-match-p minor-local-name-regexp file)) 3550 ?l) 3551 ((or (gethash path minor-global-paths-hash) 3552 (string-match-p minor-global-name-regexp file)) 3553 ?g)))) 3554 (when key 3555 (dolist (cmd (cdr feature)) 3556 (let ((sym (cdr-safe cmd))) 3557 (when (and (consp cmd) 3558 (eq (car cmd) 'defun) 3559 (commandp sym) 3560 (not (get sym 'byte-obsolete-info)) 3561 ;; Emacs 28 has a `read-extended-command-predicate' 3562 (if (bound-and-true-p read-extended-command-predicate) 3563 (funcall read-extended-command-predicate sym buffer) 3564 t)) 3565 (let ((name (symbol-name sym))) 3566 (unless (string-match-p command-filter name) 3567 (push (propertize name 3568 'consult--candidate sym 3569 'consult--type key) 3570 commands)))))))))))) 3571 3572 ;;;###autoload 3573 (defun consult-mode-command (&rest modes) 3574 "Run a command from any of the given MODES. 3575 3576 If no MODES are specified, use currently active major and minor modes." 3577 (interactive) 3578 (unless modes 3579 (setq modes (cons major-mode 3580 (seq-filter (lambda (m) 3581 (and (boundp m) (symbol-value m))) 3582 minor-mode-list)))) 3583 (let ((narrow `((?m . ,(format "Major: %s" major-mode)) 3584 (?l . "Local Minor") 3585 (?g . "Global Minor")))) 3586 (command-execute 3587 (consult--read 3588 (consult--mode-command-candidates modes) 3589 :prompt "Mode command: " 3590 :predicate 3591 (lambda (cand) 3592 (let ((key (get-text-property 0 'consult--type cand))) 3593 (if consult--narrow 3594 (= key consult--narrow) 3595 (/= key ?g)))) 3596 :lookup #'consult--lookup-candidate 3597 :group (consult--type-group narrow) 3598 :narrow narrow 3599 :require-match t 3600 :history 'extended-command-history 3601 :category 'command)))) 3602 3603 ;;;;; Command: consult-yank 3604 3605 (defun consult--read-from-kill-ring () 3606 "Open kill ring menu and return selected string." 3607 ;; `current-kill' updates `kill-ring' with a possible interprogram-paste (#443) 3608 (current-kill 0) 3609 ;; Do not specify a :lookup function in order to preserve completion-styles 3610 ;; highlighting of the current candidate. We have to perform a final lookup 3611 ;; to obtain the original candidate which may be propertized with 3612 ;; yank-specific properties, like 'yank-handler. 3613 (consult--lookup-member 3614 (consult--read 3615 (consult--remove-dups 3616 (or (if consult-yank-rotate 3617 (append kill-ring-yank-pointer 3618 (butlast kill-ring (length kill-ring-yank-pointer))) 3619 kill-ring) 3620 (user-error "Kill ring is empty"))) 3621 :prompt "Yank from kill-ring: " 3622 :history t ;; disable history 3623 :sort nil 3624 :category 'kill-ring 3625 :require-match t 3626 :state 3627 (consult--insertion-preview 3628 (point) 3629 ;; If previous command is yank, hide previously yanked string 3630 (or (and (eq last-command 'yank) (mark t)) (point)))) 3631 kill-ring)) 3632 3633 ;; Adapted from the Emacs `yank-from-kill-ring' function. 3634 ;;;###autoload 3635 (defun consult-yank-from-kill-ring (string &optional arg) 3636 "Select STRING from the kill ring and insert it. 3637 With prefix ARG, put point at beginning, and mark at end, like `yank' does. 3638 3639 This command behaves like `yank-from-kill-ring' in Emacs 28, which also offers 3640 a `completing-read' interface to the `kill-ring'. Additionally the Consult 3641 version supports preview of the selected string." 3642 (interactive (list (consult--read-from-kill-ring) current-prefix-arg)) 3643 (when string 3644 (setq yank-window-start (window-start)) 3645 (push-mark) 3646 (insert-for-yank string) 3647 (setq this-command 'yank) 3648 (when consult-yank-rotate 3649 (if-let (pos (seq-position kill-ring string)) 3650 (setq kill-ring-yank-pointer (nthcdr pos kill-ring)) 3651 (kill-new string))) 3652 (when (consp arg) 3653 ;; Swap point and mark like in `yank'. 3654 (goto-char (prog1 (mark t) 3655 (set-marker (mark-marker) (point) (current-buffer))))))) 3656 3657 (put 'consult-yank-replace 'delete-selection 'yank) 3658 (put 'consult-yank-pop 'delete-selection 'yank) 3659 (put 'consult-yank-from-kill-ring 'delete-selection 'yank) 3660 3661 ;;;###autoload 3662 (defun consult-yank-pop (&optional arg) 3663 "If there is a recent yank act like `yank-pop'. 3664 3665 Otherwise select string from the kill ring and insert it. 3666 See `yank-pop' for the meaning of ARG. 3667 3668 This command behaves like `yank-pop' in Emacs 28, which also offers a 3669 `completing-read' interface to the `kill-ring'. Additionally the Consult 3670 version supports preview of the selected string." 3671 (interactive "*p") 3672 (if (eq last-command 'yank) 3673 (yank-pop (or arg 1)) 3674 (call-interactively #'consult-yank-from-kill-ring))) 3675 3676 ;; Adapted from the Emacs yank-pop function. 3677 ;;;###autoload 3678 (defun consult-yank-replace (string) 3679 "Select STRING from the kill ring. 3680 3681 If there was no recent yank, insert the string. 3682 Otherwise replace the just-yanked string with the selected string. 3683 3684 There exists no equivalent of this command in Emacs 28." 3685 (interactive (list (consult--read-from-kill-ring))) 3686 (when string 3687 (if (not (eq last-command 'yank)) 3688 (consult-yank-from-kill-ring string) 3689 (let ((inhibit-read-only t) 3690 (pt (point)) 3691 (mk (mark t))) 3692 (setq this-command 'yank) 3693 (funcall (or yank-undo-function 'delete-region) (min pt mk) (max pt mk)) 3694 (setq yank-undo-function nil) 3695 (set-marker (mark-marker) pt (current-buffer)) 3696 (insert-for-yank string) 3697 (set-window-start (selected-window) yank-window-start t) 3698 (if (< pt mk) 3699 (goto-char (prog1 (mark t) 3700 (set-marker (mark-marker) (point) (current-buffer))))))))) 3701 3702 ;;;;; Command: consult-bookmark 3703 3704 (defun consult--bookmark-preview () 3705 "Create preview function for bookmarks." 3706 (let ((preview (consult--jump-preview)) 3707 (open (consult--temporary-files))) 3708 (lambda (action cand) 3709 (unless cand 3710 (funcall open)) 3711 (funcall 3712 preview action 3713 ;; Only preview bookmarks with the default handler. 3714 (when-let* ((bm (and cand (eq action 'preview) (assoc cand bookmark-alist))) 3715 (handler (bookmark-get-handler bm)) 3716 (file (and (or (not handler) 3717 (eq handler #'bookmark-default-handler)) 3718 (bookmark-get-filename bm))) 3719 (pos (bookmark-get-position bm)) 3720 (buf (funcall open file))) 3721 (set-marker (make-marker) pos buf)))))) 3722 3723 (defun consult--bookmark-action (bm) 3724 "Open BM via `consult--buffer-action'." 3725 (bookmark-jump bm consult--buffer-display)) 3726 3727 (consult--define-state bookmark) 3728 3729 (defun consult--bookmark-candidates () 3730 "Return bookmark candidates." 3731 (bookmark-maybe-load-default-file) 3732 (let ((narrow (mapcar (pcase-lambda (`(,y ,_ ,x)) (cons x y)) 3733 consult-bookmark-narrow))) 3734 (mapcar (lambda (cand) 3735 (propertize (car cand) 3736 'consult--type 3737 (alist-get 3738 (or (bookmark-get-handler cand) #'bookmark-default-handler) 3739 narrow))) 3740 bookmark-alist))) 3741 3742 ;;;###autoload 3743 (defun consult-bookmark (name) 3744 "If bookmark NAME exists, open it, otherwise create a new bookmark with NAME. 3745 3746 The command supports preview of file bookmarks and narrowing. See the 3747 variable `consult-bookmark-narrow' for the narrowing configuration." 3748 (interactive 3749 (list 3750 (let ((narrow (mapcar (pcase-lambda (`(,x ,y ,_)) (cons x y)) 3751 consult-bookmark-narrow))) 3752 (consult--read 3753 (consult--bookmark-candidates) 3754 :prompt "Bookmark: " 3755 :state (consult--bookmark-preview) 3756 :category 'bookmark 3757 :history 'bookmark-history 3758 ;; Add default names to future history. 3759 ;; Ignore errors such that `consult-bookmark' can be used in 3760 ;; buffers which are not backed by a file. 3761 :add-history (ignore-errors (bookmark-prop-get (bookmark-make-record) 'defaults)) 3762 :group (consult--type-group narrow) 3763 :narrow (consult--type-narrow narrow))))) 3764 (bookmark-maybe-load-default-file) 3765 (if (assoc name bookmark-alist) 3766 (bookmark-jump name) 3767 (bookmark-set name))) 3768 3769 ;;;;; Command: consult-complex-command 3770 3771 ;;;###autoload 3772 (defun consult-complex-command () 3773 "Select and evaluate command from the command history. 3774 3775 This command can act as a drop-in replacement for `repeat-complex-command'." 3776 (interactive) 3777 (let* ((history (or (delete-dups (mapcar #'prin1-to-string command-history)) 3778 (user-error "There are no previous complex commands"))) 3779 (cmd (read (consult--read 3780 history 3781 :prompt "Command: " 3782 :default (car history) 3783 :sort nil 3784 :history t ;; disable history 3785 :category 'expression)))) 3786 ;; Taken from `repeat-complex-command' 3787 (add-to-history 'command-history cmd) 3788 (apply #'funcall-interactively 3789 (car cmd) 3790 (mapcar (lambda (e) (eval e t)) (cdr cmd))))) 3791 3792 ;;;;; Command: consult-history 3793 3794 (declare-function ring-elements "ring") 3795 3796 (defun consult--current-history () 3797 "Return the history and index variable relevant to the current buffer. 3798 If the minibuffer is active, the minibuffer history is returned, 3799 otherwise the history corresponding to the mode. There is a 3800 special case for `repeat-complex-command', for which the command 3801 history is used." 3802 (cond 3803 ;; In the minibuffer we use the current minibuffer history, 3804 ;; which can be configured by setting `minibuffer-history-variable'. 3805 ((minibufferp) 3806 (when (eq minibuffer-history-variable t) 3807 (user-error "Minibuffer history is disabled for `%s'" this-command)) 3808 (list (mapcar #'consult--tofu-hide 3809 (if (eq minibuffer-history-variable 'command-history) 3810 ;; If pressing "C-x M-:", i.e., `repeat-complex-command', 3811 ;; we are instead querying the `command-history' and get a 3812 ;; full s-expression. Alternatively you might want to use 3813 ;; `consult-complex-command', which can also be bound to 3814 ;; "C-x M-:"! 3815 (mapcar #'prin1-to-string command-history) 3816 (symbol-value minibuffer-history-variable))))) 3817 ;; Otherwise we use a mode-specific history, see `consult-mode-histories'. 3818 (t (let ((found (seq-find (lambda (h) 3819 (and (derived-mode-p (car h)) 3820 (boundp (if (consp (cdr h)) (cadr h) (cdr h))))) 3821 consult-mode-histories))) 3822 (unless found 3823 (user-error "No history configured for `%s', see `consult-mode-histories'" 3824 major-mode)) 3825 (unless (consp (cdr found)) 3826 (user-error "Obsolete mode history entry: %S" found)) 3827 (cons (symbol-value (cadr found)) (cddr found)))))) 3828 3829 ;;;###autoload 3830 (defun consult-history (&optional history index bol) 3831 "Insert string from HISTORY of current buffer. 3832 In order to select from a specific HISTORY, pass the history 3833 variable as argument. INDEX is the name of the index variable to 3834 update, if any. BOL is the function which jumps to the beginning 3835 of the prompt. See also `cape-history' from the Cape package." 3836 (interactive) 3837 (pcase-let* ((`(,history ,index ,bol) (if history 3838 (list history index bol) 3839 (consult--current-history))) 3840 (history (if (ring-p history) (ring-elements history) history)) 3841 (`(,beg . ,end) 3842 (if (minibufferp) 3843 (cons (minibuffer-prompt-end) (point-max)) 3844 (if bol 3845 (save-excursion 3846 (funcall bol) 3847 (cons 3848 (point) 3849 (let ((inhibit-field-text-motion t)) 3850 (line-end-position)))) 3851 (cons (point) (point))))) 3852 (str (consult--local-let ((enable-recursive-minibuffers t)) 3853 (consult--read 3854 (or (consult--remove-dups history) 3855 (user-error "History is empty")) 3856 :prompt "History: " 3857 :history t ;; disable history 3858 :category ;; Report category depending on history variable 3859 (and (minibufferp) 3860 (pcase minibuffer-history-variable 3861 ('extended-command-history 'command) 3862 ('buffer-name-history 'buffer) 3863 ('face-name-history 'face) 3864 ('read-envvar-name-history 'environment-variable) 3865 ('bookmark-history 'bookmark) 3866 ('file-name-history 'file))) 3867 :sort nil 3868 :initial (buffer-substring-no-properties beg end) 3869 :state (consult--insertion-preview beg end))))) 3870 (delete-region beg end) 3871 (when index 3872 (set index (seq-position history str))) 3873 (insert (substring-no-properties str)))) 3874 3875 ;;;;; Command: consult-isearch-history 3876 3877 (defun consult-isearch-forward (&optional reverse) 3878 "Continue isearch forward optionally in REVERSE." 3879 (interactive) 3880 (consult--require-minibuffer) 3881 (setq isearch-new-forward (not reverse) isearch-new-nonincremental nil) 3882 (funcall (or (command-remapping #'exit-minibuffer) #'exit-minibuffer))) 3883 3884 (defun consult-isearch-backward (&optional reverse) 3885 "Continue isearch backward optionally in REVERSE." 3886 (interactive) 3887 (consult-isearch-forward (not reverse))) 3888 3889 ;; Emacs 28: hide in M-X 3890 (put #'consult-isearch-backward 'completion-predicate #'ignore) 3891 (put #'consult-isearch-forward 'completion-predicate #'ignore) 3892 3893 (defvar-keymap consult-isearch-history-map 3894 :doc "Additional keymap used by `consult-isearch-history'." 3895 "<remap> <isearch-forward>" #'consult-isearch-forward 3896 "<remap> <isearch-backward>" #'consult-isearch-backward) 3897 3898 (defun consult--isearch-history-candidates () 3899 "Return isearch history candidates." 3900 ;; NOTE: Do not throw an error on empty history, 3901 ;; in order to allow starting a search. 3902 ;; We do not :require-match here! 3903 (let ((history (if (eq t search-default-mode) 3904 (append regexp-search-ring search-ring) 3905 (append search-ring regexp-search-ring)))) 3906 (cons 3907 (delete-dups 3908 (mapcar 3909 (lambda (cand) 3910 ;; The search type can be distinguished via text properties. 3911 (let* ((props (plist-member (text-properties-at 0 cand) 3912 'isearch-regexp-function)) 3913 (type (pcase (cadr props) 3914 ((and 'nil (guard (not props))) ?r) 3915 ('nil ?l) 3916 ('word-search-regexp ?w) 3917 ('isearch-symbol-regexp ?s) 3918 ('char-fold-to-regexp ?c) 3919 (_ ?u)))) 3920 ;; Disambiguate history items. The same string could 3921 ;; occur with different search types. 3922 (consult--tofu-append cand type))) 3923 history)) 3924 (if history 3925 (+ 4 (apply #'max (mapcar #'length history))) 3926 0)))) 3927 3928 (defconst consult--isearch-history-narrow 3929 '((?c . "Char") 3930 (?u . "Custom") 3931 (?l . "Literal") 3932 (?r . "Regexp") 3933 (?s . "Symbol") 3934 (?w . "Word"))) 3935 3936 ;;;###autoload 3937 (defun consult-isearch-history () 3938 "Read a search string with completion from the Isearch history. 3939 3940 This replaces the current search string if Isearch is active, and 3941 starts a new Isearch session otherwise." 3942 (interactive) 3943 (consult--forbid-minibuffer) 3944 (let* ((isearch-message-function 'ignore) ;; Avoid flicker in echo area 3945 (inhibit-redisplay t) ;; Avoid flicker in mode line 3946 (candidates (consult--isearch-history-candidates)) 3947 (align (propertize " " 'display `(space :align-to (+ left ,(cdr candidates)))))) 3948 (unless isearch-mode (isearch-mode t)) 3949 (with-isearch-suspended 3950 (setq isearch-new-string 3951 (consult--read 3952 (car candidates) 3953 :prompt "I-search: " 3954 :category 'consult-isearch 3955 :history t ;; disable history 3956 :sort nil 3957 :initial isearch-string 3958 :keymap consult-isearch-history-map 3959 :annotate 3960 (lambda (cand) 3961 (concat align (alist-get (consult--tofu-get cand) consult--isearch-history-narrow))) 3962 :group 3963 (lambda (cand transform) 3964 (if transform 3965 cand 3966 (alist-get (consult--tofu-get cand) consult--isearch-history-narrow))) 3967 :lookup 3968 (lambda (selected candidates &rest _) 3969 (if-let (found (member selected candidates)) 3970 (substring (car found) 0 -1) 3971 selected)) 3972 :state 3973 (lambda (action cand) 3974 (when (and (eq action 'preview) cand) 3975 (setq isearch-string cand) 3976 (isearch-update-from-string-properties cand) 3977 (isearch-update))) 3978 :narrow 3979 (list :predicate 3980 (lambda (cand) (= (consult--tofu-get cand) consult--narrow)) 3981 :keys consult--isearch-history-narrow)) 3982 isearch-new-message 3983 (mapconcat 'isearch-text-char-description isearch-new-string ""))) 3984 ;; Setting `isearch-regexp' etc only works outside of `with-isearch-suspended'. 3985 (unless (plist-member (text-properties-at 0 isearch-string) 'isearch-regexp-function) 3986 (setq isearch-regexp t 3987 isearch-regexp-function nil)))) 3988 3989 ;;;;; Command: consult-minor-mode-menu 3990 3991 (defun consult--minor-mode-candidates () 3992 "Return list of minor-mode candidate strings." 3993 (mapcar 3994 (pcase-lambda (`(,name . ,sym)) 3995 (propertize 3996 name 3997 'consult--candidate sym 3998 'consult--minor-mode-narrow 3999 (logior 4000 (ash (if (local-variable-if-set-p sym) ?l ?g) 8) 4001 (if (and (boundp sym) (symbol-value sym)) ?i ?o)) 4002 'consult--minor-mode-group 4003 (concat 4004 (if (local-variable-if-set-p sym) "Local " "Global ") 4005 (if (and (boundp sym) (symbol-value sym)) "On" "Off")))) 4006 (nconc 4007 ;; according to describe-minor-mode-completion-table-for-symbol 4008 ;; the minor-mode-list contains *all* minor modes 4009 (mapcar (lambda (sym) (cons (symbol-name sym) sym)) minor-mode-list) 4010 ;; take the lighters from minor-mode-alist 4011 (delq nil 4012 (mapcar (pcase-lambda (`(,sym ,lighter)) 4013 (when (and lighter (not (equal "" lighter))) 4014 (setq lighter (string-trim (format-mode-line lighter))) 4015 (unless (string-blank-p lighter) 4016 (cons lighter sym)))) 4017 minor-mode-alist))))) 4018 4019 (defconst consult--minor-mode-menu-narrow 4020 '((?l . "Local") 4021 (?g . "Global") 4022 (?i . "On") 4023 (?o . "Off"))) 4024 4025 ;;;###autoload 4026 (defun consult-minor-mode-menu () 4027 "Enable or disable minor mode. 4028 4029 This is an alternative to `minor-mode-menu-from-indicator'." 4030 (interactive) 4031 (call-interactively 4032 (consult--read 4033 (consult--minor-mode-candidates) 4034 :prompt "Minor mode: " 4035 :require-match t 4036 :category 'minor-mode 4037 :group 4038 (lambda (cand transform) 4039 (if transform cand (get-text-property 0 'consult--minor-mode-group cand))) 4040 :narrow 4041 (list :predicate 4042 (lambda (cand) 4043 (let ((narrow (get-text-property 0 'consult--minor-mode-narrow cand))) 4044 (or (= (logand narrow 255) consult--narrow) 4045 (= (ash narrow -8) consult--narrow)))) 4046 :keys 4047 consult--minor-mode-menu-narrow) 4048 :lookup #'consult--lookup-candidate 4049 :history 'consult--minor-mode-menu-history))) 4050 4051 ;;;;; Command: consult-theme 4052 4053 ;;;###autoload 4054 (defun consult-theme (theme) 4055 "Disable current themes and enable THEME from `consult-themes'. 4056 4057 The command supports previewing the currently selected theme." 4058 (interactive 4059 (list 4060 (let* ((regexp (consult--regexp-filter 4061 (mapcar (lambda (x) (if (stringp x) x (format "\\`%s\\'" x))) 4062 consult-themes))) 4063 (avail-themes (seq-filter 4064 (lambda (x) (string-match-p regexp (symbol-name x))) 4065 (cons 'default (custom-available-themes)))) 4066 (saved-theme (car custom-enabled-themes))) 4067 (consult--read 4068 (mapcar #'symbol-name avail-themes) 4069 :prompt "Theme: " 4070 :require-match t 4071 :category 'theme 4072 :history 'consult--theme-history 4073 :lookup (lambda (selected &rest _) 4074 (setq selected (and selected (intern-soft selected))) 4075 (or (and selected (car (memq selected avail-themes))) 4076 saved-theme)) 4077 :state (lambda (action theme) 4078 (pcase action 4079 ('return (consult-theme (or theme saved-theme))) 4080 ((and 'preview (guard theme)) (consult-theme theme)))) 4081 :default (symbol-name (or saved-theme 'default)))))) 4082 (when (eq theme 'default) (setq theme nil)) 4083 (unless (eq theme (car custom-enabled-themes)) 4084 (mapc #'disable-theme custom-enabled-themes) 4085 (when theme 4086 (if (custom-theme-p theme) 4087 (enable-theme theme) 4088 (load-theme theme :no-confirm))))) 4089 4090 ;;;;; Command: consult-buffer 4091 4092 (defun consult--buffer-sort-alpha (buffers) 4093 "Sort BUFFERS alphabetically, put starred buffers at the end." 4094 (sort buffers 4095 (lambda (x y) 4096 (setq x (buffer-name x) y (buffer-name y)) 4097 (let ((a (and (length> x 0) (eq (aref x 0) ?*))) 4098 (b (and (length> y 0) (eq (aref y 0) ?*)))) 4099 (if (eq a b) 4100 (string< x y) 4101 (not a)))))) 4102 4103 (defun consult--buffer-sort-alpha-current (buffers) 4104 "Sort BUFFERS alphabetically, put current at the beginning." 4105 (let ((buffers (consult--buffer-sort-alpha buffers)) 4106 (current (current-buffer))) 4107 (if (memq current buffers) 4108 (cons current (delq current buffers)) 4109 buffers))) 4110 4111 (defun consult--buffer-sort-visibility (buffers) 4112 "Sort BUFFERS by visibility." 4113 (let ((hidden) 4114 (current (current-buffer))) 4115 (consult--keep! buffers 4116 (unless (eq it current) 4117 (if (get-buffer-window it 'visible) 4118 it 4119 (push it hidden) 4120 nil))) 4121 (nconc (nreverse hidden) buffers (list (current-buffer))))) 4122 4123 (defun consult--normalize-directory (dir) 4124 "Normalize directory DIR. 4125 DIR can be project, nil or a path." 4126 (cond 4127 ((eq dir 'project) (consult--project-root)) 4128 (dir (expand-file-name dir)))) 4129 4130 (defun consult--buffer-query-prompt (prompt query) 4131 "Buffer query function returning a scope description. 4132 PROMPT is the prompt format string. 4133 QUERY is passed to `consult--buffer-query'." 4134 (let* ((dir (plist-get query :directory)) 4135 (ndir (consult--normalize-directory dir)) 4136 (buffers (apply #'consult--buffer-query :directory ndir query)) 4137 (count (length buffers))) 4138 (cons (format "%s (%d buffer%s%s): " prompt count 4139 (if (= count 1) "" "s") 4140 (cond 4141 ((and ndir (eq dir 'project)) 4142 (format ", Project %s" (consult--project-name ndir))) 4143 (ndir (concat ", " (consult--abbreviate-directory ndir))) 4144 (t ""))) 4145 buffers))) 4146 4147 (cl-defun consult--buffer-query (&key sort directory mode as predicate (filter t) 4148 include (exclude consult-buffer-filter)) 4149 "Buffer query function. 4150 DIRECTORY can either be project or a path. 4151 SORT can be visibility, alpha or nil. 4152 FILTER can be either t, nil or invert. 4153 EXCLUDE is a list of regexps. 4154 INCLUDE is a list of regexps. 4155 MODE can be a mode or a list of modes to restrict the returned buffers. 4156 PREDICATE is a predicate function. 4157 AS is a conversion function." 4158 ;; This function is the backbone of most `consult-buffer' source. The 4159 ;; function supports filtering by various criteria which are used throughout 4160 ;; Consult. 4161 (let ((root (consult--normalize-directory directory)) 4162 (buffers (buffer-list))) 4163 (when sort 4164 (setq buffers (funcall (intern (format "consult--buffer-sort-%s" sort)) buffers))) 4165 (when (or filter mode as root) 4166 (let ((mode (ensure-list mode)) 4167 (exclude-re (consult--regexp-filter exclude)) 4168 (include-re (consult--regexp-filter include))) 4169 (consult--keep! buffers 4170 (and 4171 (or (not mode) 4172 (apply #'provided-mode-derived-p 4173 (buffer-local-value 'major-mode it) mode)) 4174 (pcase-exhaustive filter 4175 ('nil t) 4176 ((or 't 'invert) 4177 (eq (eq filter t) 4178 (and 4179 (or (not exclude) 4180 (not (string-match-p exclude-re (buffer-name it)))) 4181 (or (not include) 4182 (not (not (string-match-p include-re (buffer-name it))))))))) 4183 (or (not root) 4184 (when-let (dir (buffer-local-value 'default-directory it)) 4185 (string-prefix-p root 4186 (if (and (/= 0 (length dir)) (eq (aref dir 0) ?/)) 4187 dir 4188 (expand-file-name dir))))) 4189 (or (not predicate) (funcall predicate it)) 4190 (if as (funcall as it) it))))) 4191 buffers)) 4192 4193 (defun consult--buffer-file-hash () 4194 "Return hash table of all buffer file names." 4195 (consult--string-hash (consult--buffer-query :as #'buffer-file-name))) 4196 4197 (defun consult--buffer-preview () 4198 "Buffer preview function." 4199 (let ((orig-buf (current-buffer)) other-win) 4200 (lambda (action cand) 4201 (when (eq action 'preview) 4202 (when (and (eq consult--buffer-display #'switch-to-buffer-other-window) 4203 (not other-win)) 4204 (switch-to-buffer-other-window orig-buf) 4205 (setq other-win (selected-window))) 4206 (let ((win (or other-win (selected-window)))) 4207 (when (window-live-p win) 4208 (with-selected-window win 4209 (cond 4210 ((and cand (get-buffer cand)) 4211 (switch-to-buffer cand 'norecord)) 4212 ((buffer-live-p orig-buf) 4213 (switch-to-buffer orig-buf 'norecord)))))))))) 4214 4215 (defun consult--buffer-action (buffer &optional norecord) 4216 "Switch to BUFFER via `consult--buffer-display' function. 4217 If NORECORD is non-nil, do not record the buffer switch in the buffer list." 4218 (funcall consult--buffer-display buffer norecord)) 4219 4220 (consult--define-state buffer) 4221 4222 (defvar consult--source-bookmark 4223 `(:name "Bookmark" 4224 :narrow ?m 4225 :category bookmark 4226 :face consult-bookmark 4227 :history bookmark-history 4228 :items ,#'bookmark-all-names 4229 :state ,#'consult--bookmark-state) 4230 "Bookmark candidate source for `consult-buffer'.") 4231 4232 (defvar consult--source-project-buffer 4233 `(:name "Project Buffer" 4234 :narrow (?p . "Project") 4235 :hidden t 4236 :category buffer 4237 :face consult-buffer 4238 :history buffer-name-history 4239 :state ,#'consult--buffer-state 4240 :enabled ,(lambda () consult-project-function) 4241 :items 4242 ,(lambda () 4243 (when-let (root (consult--project-root)) 4244 (consult--buffer-query :sort 'visibility 4245 :directory root 4246 :as #'buffer-name)))) 4247 "Project buffer candidate source for `consult-buffer'.") 4248 4249 (defvar consult--source-project-recent-file 4250 `(:name "Project File" 4251 :narrow (?p . "Project") 4252 :hidden t 4253 :category file 4254 :face consult-file 4255 :history file-name-history 4256 :state ,#'consult--file-state 4257 :new 4258 ,(lambda (file) 4259 (consult--file-action 4260 (expand-file-name file (consult--project-root)))) 4261 :enabled 4262 ,(lambda () 4263 (and consult-project-function 4264 recentf-mode)) 4265 :items 4266 ,(lambda () 4267 (when-let (root (consult--project-root)) 4268 (let ((len (length root)) 4269 (ht (consult--buffer-file-hash)) 4270 file-name-handler-alist ;; No Tramp slowdown please. 4271 items) 4272 (dolist (file recentf-list (nreverse items)) 4273 ;; Emacs 29 abbreviates file paths by default, see 4274 ;; `recentf-filename-handlers'. 4275 (unless (eq (aref file 0) ?/) 4276 (setq file (expand-file-name file))) 4277 (when (and (not (gethash file ht)) (string-prefix-p root file)) 4278 (let ((part (substring file len))) 4279 (when (equal part "") (setq part "./")) 4280 (put-text-property 0 (length part) 4281 'multi-category `(file . ,file) part) 4282 (push part items)))))))) 4283 "Project file candidate source for `consult-buffer'.") 4284 4285 (defvar consult--source-hidden-buffer 4286 `(:name "Hidden Buffer" 4287 :narrow 32 4288 :hidden t 4289 :category buffer 4290 :face consult-buffer 4291 :history buffer-name-history 4292 :action ,#'consult--buffer-action 4293 :items 4294 ,(lambda () (consult--buffer-query :sort 'visibility 4295 :filter 'invert 4296 :as #'buffer-name))) 4297 "Hidden buffer candidate source for `consult-buffer'.") 4298 4299 (defvar consult--source-modified-buffer 4300 `(:name "Modified Buffer" 4301 :narrow ?* 4302 :hidden t 4303 :category buffer 4304 :face consult-buffer 4305 :history buffer-name-history 4306 :state ,#'consult--buffer-state 4307 :items 4308 ,(lambda () (consult--buffer-query :sort 'visibility 4309 :as #'buffer-name 4310 :predicate 4311 (lambda (buf) 4312 (and (buffer-modified-p buf) 4313 (buffer-file-name buf)))))) 4314 "Modified buffer candidate source for `consult-buffer'.") 4315 4316 (defvar consult--source-buffer 4317 `(:name "Buffer" 4318 :narrow ?b 4319 :category buffer 4320 :face consult-buffer 4321 :history buffer-name-history 4322 :state ,#'consult--buffer-state 4323 :default t 4324 :items 4325 ,(lambda () (consult--buffer-query :sort 'visibility 4326 :as #'buffer-name))) 4327 "Buffer candidate source for `consult-buffer'.") 4328 4329 (defun consult--file-register-p (reg) 4330 "Return non-nil if REG is a file register." 4331 (memq (car-safe (cdr reg)) '(file-query file))) 4332 4333 (autoload 'consult-register--candidates "consult-register") 4334 (defvar consult--source-file-register 4335 `(:name "File Register" 4336 :narrow (?r . "Register") 4337 :category file 4338 :state ,#'consult--file-state 4339 :enabled ,(lambda () (seq-some #'consult--file-register-p register-alist)) 4340 :items ,(lambda () (consult-register--candidates #'consult--file-register-p))) 4341 "File register source.") 4342 4343 (defvar consult--source-recent-file 4344 `(:name "File" 4345 :narrow ?f 4346 :category file 4347 :face consult-file 4348 :history file-name-history 4349 :state ,#'consult--file-state 4350 :new ,#'consult--file-action 4351 :enabled ,(lambda () recentf-mode) 4352 :items 4353 ,(lambda () 4354 (let ((ht (consult--buffer-file-hash)) 4355 file-name-handler-alist ;; No Tramp slowdown please. 4356 items) 4357 (dolist (file recentf-list (nreverse items)) 4358 ;; Emacs 29 abbreviates file paths by default, see 4359 ;; `recentf-filename-handlers'. 4360 (unless (eq (aref file 0) ?/) 4361 (setq file (expand-file-name file))) 4362 (unless (gethash file ht) 4363 (push (abbreviate-file-name file) items)))))) 4364 "Recent file candidate source for `consult-buffer'.") 4365 4366 ;;;###autoload 4367 (defun consult-buffer (&optional sources) 4368 "Enhanced `switch-to-buffer' command with support for virtual buffers. 4369 4370 The command supports recent files, bookmarks, views and project files as 4371 virtual buffers. Buffers are previewed. Narrowing to buffers (b), files (f), 4372 bookmarks (m) and project files (p) is supported via the corresponding 4373 keys. In order to determine the project-specific files and buffers, the 4374 `consult-project-function' is used. The virtual buffer SOURCES 4375 default to `consult-buffer-sources'. See `consult--multi' for the 4376 configuration of the virtual buffer sources." 4377 (interactive) 4378 (let ((selected (consult--multi (or sources consult-buffer-sources) 4379 :require-match 4380 (confirm-nonexistent-file-or-buffer) 4381 :prompt "Switch to: " 4382 :history 'consult--buffer-history 4383 :sort nil))) 4384 ;; For non-matching candidates, fall back to buffer creation. 4385 (unless (plist-get (cdr selected) :match) 4386 (consult--buffer-action (car selected))))) 4387 4388 ;; Populate `consult-project-buffer-sources'. 4389 (setq consult-project-buffer-sources 4390 (list 4391 `(:hidden nil :narrow ?b ,@consult--source-project-buffer) 4392 `(:hidden nil :narrow ?f ,@consult--source-project-recent-file))) 4393 4394 (defmacro consult--with-project (&rest body) 4395 "Ensure that BODY is executed with a project root." 4396 ;; We have to work quite hard here to ensure that the project root is 4397 ;; only overriden at the current recursion level. When entering a 4398 ;; recursive minibuffer session, we should be able to still switch the 4399 ;; project. But who does that? Working on the first level on project A 4400 ;; and on the second level on project B and on the third level on project C? 4401 ;; You mustn't be afraid to dream a little bigger, darling. 4402 `(let ((consult-project-function 4403 (let ((root (or (consult--project-root t) (user-error "No project found"))) 4404 (depth (recursion-depth)) 4405 (orig consult-project-function)) 4406 (lambda (may-prompt) 4407 (if (= depth (recursion-depth)) 4408 root 4409 (funcall orig may-prompt)))))) 4410 ,@body)) 4411 4412 ;;;###autoload 4413 (defun consult-project-buffer () 4414 "Enhanced `project-switch-to-buffer' command with support for virtual buffers. 4415 The command may prompt you for a project directory if it is invoked from 4416 outside a project. See `consult-buffer' for more details." 4417 (interactive) 4418 (consult--with-project 4419 (consult-buffer consult-project-buffer-sources))) 4420 4421 ;;;###autoload 4422 (defun consult-buffer-other-window () 4423 "Variant of `consult-buffer' which opens in other window." 4424 (interactive) 4425 (let ((consult--buffer-display #'switch-to-buffer-other-window)) 4426 (consult-buffer))) 4427 4428 ;;;###autoload 4429 (defun consult-buffer-other-frame () 4430 "Variant of `consult-buffer' which opens in other frame." 4431 (interactive) 4432 (let ((consult--buffer-display #'switch-to-buffer-other-frame)) 4433 (consult-buffer))) 4434 4435 ;;;;; Command: consult-kmacro 4436 4437 (declare-function kmacro--keys "kmacro") 4438 (declare-function kmacro--counter "kmacro") 4439 (declare-function kmacro--format "kmacro") 4440 4441 (defun consult--kmacro-candidates () 4442 "Return alist of kmacros and indices." 4443 (thread-last 4444 ;; List of macros 4445 (append (and last-kbd-macro (list (kmacro-ring-head))) kmacro-ring) 4446 ;; Emacs 29 uses OClosures. I like OClosures but it would have been better 4447 ;; if public APIs wouldn't change like that. 4448 (mapcar (lambda (x) 4449 (if (> emacs-major-version 28) 4450 (list (kmacro--keys x) (kmacro--counter x) (kmacro--format x) x) 4451 `(,@x ,x)))) 4452 ;; Filter mouse clicks 4453 (seq-remove (lambda (x) (seq-some #'mouse-event-p (car x)))) 4454 ;; Format macros 4455 (mapcar (pcase-lambda (`(,keys ,counter ,format ,km)) 4456 (propertize 4457 (format-kbd-macro keys 1) 4458 'consult--candidate km 4459 'consult--kmacro-annotation 4460 ;; If the counter is 0 and the counter format is its default, 4461 ;; then there is a good chance that the counter isn't actually 4462 ;; being used. This can only be wrong when a user 4463 ;; intentionally starts the counter with a negative value and 4464 ;; then increments it to 0. 4465 (cond 4466 ((not (string= format "%d")) ;; show counter for non-default format 4467 (format " (counter=%d, format=%s) " counter format)) 4468 ((/= counter 0) ;; show counter if non-zero 4469 (format " (counter=%d)" counter)))))) 4470 (delete-dups))) 4471 4472 ;;;###autoload 4473 (defun consult-kmacro (arg) 4474 "Run a chosen keyboard macro. 4475 4476 With prefix ARG, run the macro that many times. 4477 Macros containing mouse clicks are omitted." 4478 (interactive "p") 4479 (let ((km (consult--read 4480 (or (consult--kmacro-candidates) 4481 (user-error "No keyboard macros defined")) 4482 :prompt "Keyboard macro: " 4483 :category 'consult-kmacro 4484 :require-match t 4485 :sort nil 4486 :history 'consult--kmacro-history 4487 :annotate 4488 (lambda (cand) 4489 (get-text-property 0 'consult--kmacro-annotation cand)) 4490 :lookup #'consult--lookup-candidate))) 4491 (unless km (user-error "No kmacro selected")) 4492 (funcall 4493 ;; Kmacros are lambdas (oclosures) on Emacs 29 4494 (if (fboundp 'kmacro-lambda-form) (kmacro-lambda-form km) km) 4495 arg))) 4496 4497 ;;;;; Command: consult-grep 4498 4499 (defun consult--grep-format (async builder) 4500 "Return ASYNC function highlighting grep match results. 4501 BUILDER is the command argument builder." 4502 (let ((highlight)) 4503 (lambda (action) 4504 (cond 4505 ((stringp action) 4506 (setq highlight (plist-get (funcall builder action) :highlight)) 4507 (funcall async action)) 4508 ((consp action) 4509 (let (result) 4510 (save-match-data 4511 (dolist (str action) 4512 (when (and (string-match consult--grep-match-regexp str) 4513 ;; Filter out empty context lines 4514 (or (/= (aref str (match-beginning 3)) ?-) 4515 (/= (match-end 0) (length str)))) 4516 (let* ((file (match-string 1 str)) 4517 (line (match-string 2 str)) 4518 (ctx (= (aref str (match-beginning 3)) ?-)) 4519 (sep (if ctx "-" ":")) 4520 (content (substring str (match-end 0))) 4521 (file-len (length file)) 4522 (line-len (length line))) 4523 (when (length> content consult-grep-max-columns) 4524 (setq content (substring content 0 consult-grep-max-columns))) 4525 (when highlight 4526 (funcall highlight content)) 4527 (setq str (concat file sep line sep content)) 4528 ;; Store file name in order to avoid allocations in `consult--grep-group' 4529 (add-text-properties 0 file-len `(face consult-file consult--grep-file ,file) str) 4530 (put-text-property (1+ file-len) (+ 1 file-len line-len) 'face 'consult-line-number str) 4531 (when ctx 4532 (add-face-text-property (+ 2 file-len line-len) (length str) 'consult-grep-context 'append str)) 4533 (push str result))))) 4534 (funcall async (nreverse result)))) 4535 (t (funcall async action)))))) 4536 4537 (defun consult--grep-position (cand &optional find-file) 4538 "Return the grep position marker for CAND. 4539 FIND-FILE is the file open function, defaulting to `find-file'." 4540 (when cand 4541 (let* ((file-end (next-single-property-change 0 'face cand)) 4542 (line-end (next-single-property-change (1+ file-end) 'face cand)) 4543 (matches (consult--point-placement cand (1+ line-end) 'consult-grep-context)) 4544 (file (substring-no-properties cand 0 file-end)) 4545 (line (string-to-number (substring-no-properties cand (+ 1 file-end) line-end)))) 4546 (when-let (pos (consult--position-marker 4547 (funcall (or find-file #'find-file) file) 4548 line (or (car matches) 0))) 4549 (cons pos (cdr matches)))))) 4550 4551 (defun consult--grep-state () 4552 "Grep state function." 4553 (let ((open (consult--temporary-files)) 4554 (jump (consult--jump-state))) 4555 (lambda (action cand) 4556 (unless cand 4557 (funcall open)) 4558 (funcall jump action (consult--grep-position 4559 cand 4560 (and (not (eq action 'return)) open)))))) 4561 4562 (defun consult--grep-group (cand transform) 4563 "Return title for CAND or TRANSFORM the candidate." 4564 (if transform 4565 (substring cand (1+ (length (get-text-property 0 'consult--grep-file cand)))) 4566 (get-text-property 0 'consult--grep-file cand))) 4567 4568 (defun consult--grep-exclude-args () 4569 "Produce grep exclude arguments. 4570 Take the variables `grep-find-ignored-directories' and 4571 `grep-find-ignored-files' into account." 4572 (unless (boundp 'grep-find-ignored-files) (require 'grep)) 4573 (nconc (mapcar (lambda (s) (concat "--exclude=" s)) 4574 (bound-and-true-p grep-find-ignored-files)) 4575 (mapcar (lambda (s) (concat "--exclude-dir=" s)) 4576 (bound-and-true-p grep-find-ignored-directories)))) 4577 4578 (defun consult--grep (prompt builder dir initial) 4579 "Run grep in DIR. 4580 4581 BUILDER is the command builder. 4582 PROMPT is the prompt string. 4583 INITIAL is inital input." 4584 (let* ((prompt-dir (consult--directory-prompt prompt dir)) 4585 (default-directory (cdr prompt-dir))) 4586 (consult--read 4587 (consult--async-command builder 4588 (consult--grep-format builder) 4589 :file-handler t) ;; allow tramp 4590 :prompt (car prompt-dir) 4591 :lookup #'consult--lookup-member 4592 :state (consult--grep-state) 4593 :initial (consult--async-split-initial initial) 4594 :add-history (consult--async-split-thingatpt 'symbol) 4595 :require-match t 4596 :category 'consult-grep 4597 :group #'consult--grep-group 4598 :history '(:input consult--grep-history) 4599 :sort nil))) 4600 4601 (defun consult--grep-lookahead-p (&rest cmd) 4602 "Return t if grep CMD supports lookahead." 4603 (with-temp-buffer 4604 (insert "xaxbx") 4605 (eq 0 (apply #'call-process-region (point-min) (point-max) 4606 (car cmd) nil nil nil `(,@(cdr cmd) "^(?=.*b)(?=.*a)"))))) 4607 4608 (defun consult--grep-make-builder () 4609 "Create grep command line builder." 4610 (let* ((cmd (consult--build-args consult-grep-args)) 4611 (type (if (consult--grep-lookahead-p (car cmd) "-P") 'pcre 'extended))) 4612 (lambda (input) 4613 (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) 4614 (flags (append cmd opts)) 4615 (ignore-case (or (member "-i" flags) (member "--ignore-case" flags)))) 4616 (if (or (member "-F" flags) (member "--fixed-strings" flags)) 4617 `(:command (,@cmd "-e" ,arg ,@opts) :highlight 4618 ,(apply-partially #'consult--highlight-regexps 4619 (list (regexp-quote arg)) ignore-case)) 4620 (pcase-let ((`(,re . ,hl) (funcall consult--regexp-compiler arg type ignore-case))) 4621 (when re 4622 `(:command 4623 (,@cmd 4624 ,(if (eq type 'pcre) "-P" "-E") ;; perl or extended 4625 "-e" ,(consult--join-regexps re type) 4626 ,@opts) 4627 :highlight ,hl)))))))) 4628 4629 ;;;###autoload 4630 (defun consult-grep (&optional dir initial) 4631 "Search with `grep' for files in DIR where the content matches a regexp. 4632 4633 The initial input is given by the INITIAL argument. 4634 4635 The input string is split, the first part of the string (grep input) is 4636 passed to the asynchronous grep process and the second part of the string is 4637 passed to the completion-style filtering. 4638 4639 The input string is split at a punctuation character, which is given as the 4640 first character of the input string. The format is similar to Perl-style 4641 regular expressions, e.g., /regexp/. Furthermore command line options can be 4642 passed to grep, specified behind --. The overall prompt input has the form 4643 `#async-input -- grep-opts#filter-string'. 4644 4645 Note that the grep input string is transformed from Emacs regular expressions 4646 to Posix regular expressions. Always enter Emacs regular expressions at the 4647 prompt. `consult-grep' behaves like builtin Emacs search commands, e.g., 4648 Isearch, which take Emacs regular expressions. Furthermore the asynchronous 4649 input split into words, each word must match separately and in any order. See 4650 `consult--regexp-compiler' for the inner workings. In order to disable 4651 transformations of the grep input, adjust `consult--regexp-compiler' 4652 accordingly. 4653 4654 Here we give a few example inputs: 4655 4656 #alpha beta : Search for alpha and beta in any order. 4657 #alpha.*beta : Search for alpha before beta. 4658 #\\(alpha\\|beta\\) : Search for alpha or beta (Note Emacs syntax!) 4659 #word -- -C3 : Search for word, include 3 lines as context 4660 #first#second : Search for first, quick filter for second. 4661 4662 The symbol at point is added to the future history. If `consult-grep' 4663 is called interactively with a prefix argument, the user can specify 4664 the directory to search in. By default the project directory is used 4665 if `consult-project-function' is defined and returns non-nil. 4666 Otherwise the `default-directory' is searched." 4667 (interactive "P") 4668 (consult--grep "Grep" (consult--grep-make-builder) dir initial)) 4669 4670 ;;;;; Command: consult-git-grep 4671 4672 (defun consult--git-grep-builder (input) 4673 "Build command line given CONFIG and INPUT." 4674 (pcase-let* ((cmd (consult--build-args consult-git-grep-args)) 4675 (`(,arg . ,opts) (consult--command-split input)) 4676 (flags (append cmd opts)) 4677 (ignore-case (or (member "-i" flags) (member "--ignore-case" flags)))) 4678 (if (or (member "-F" flags) (member "--fixed-strings" flags)) 4679 `(:command (,@cmd "-e" ,arg ,@opts) :highlight 4680 ,(apply-partially #'consult--highlight-regexps 4681 (list (regexp-quote arg)) ignore-case)) 4682 (pcase-let ((`(,re . ,hl) (funcall consult--regexp-compiler arg 'extended ignore-case))) 4683 (when re 4684 `(:command 4685 (,@cmd ,@(cdr (mapcan (lambda (x) (list "--and" "-e" x)) re)) ,@opts) 4686 :highlight ,hl)))))) 4687 4688 ;;;###autoload 4689 (defun consult-git-grep (&optional dir initial) 4690 "Search with `git grep' for files in DIR where the content matches a regexp. 4691 The initial input is given by the INITIAL argument. See `consult-grep' 4692 for more details." 4693 (interactive "P") 4694 (consult--grep "Git-grep" #'consult--git-grep-builder dir initial)) 4695 4696 ;;;;; Command: consult-ripgrep 4697 4698 (defun consult--ripgrep-make-builder () 4699 "Create ripgrep command line builder." 4700 (let* ((cmd (consult--build-args consult-ripgrep-args)) 4701 (type (if (consult--grep-lookahead-p (car cmd) "-P") 'pcre 'extended))) 4702 (lambda (input) 4703 (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) 4704 (flags (append cmd opts)) 4705 (ignore-case (if (or (member "-S" flags) (member "--smart-case" flags)) 4706 (let (case-fold-search) 4707 ;; Case insensitive if there are no uppercase letters 4708 (not (string-match-p "[[:upper:]]" arg))) 4709 (or (member "-i" flags) (member "--ignore-case" flags))))) 4710 (if (or (member "-F" flags) (member "--fixed-strings" flags)) 4711 `(:command (,@cmd "-e" ,arg ,@opts) :highlight 4712 ,(apply-partially #'consult--highlight-regexps 4713 (list (regexp-quote arg)) ignore-case)) 4714 (pcase-let ((`(,re . ,hl) (funcall consult--regexp-compiler arg type ignore-case))) 4715 (when re 4716 `(:command 4717 (,@cmd ,@(and (eq type 'pcre) '("-P")) 4718 "-e" ,(consult--join-regexps re type) 4719 ,@opts) 4720 :highlight ,hl)))))))) 4721 4722 ;;;###autoload 4723 (defun consult-ripgrep (&optional dir initial) 4724 "Search with `rg' for files in DIR where the content matches a regexp. 4725 The initial input is given by the INITIAL argument. See `consult-grep' 4726 for more details." 4727 (interactive "P") 4728 (consult--grep "Ripgrep" (consult--ripgrep-make-builder) dir initial)) 4729 4730 ;;;;; Command: consult-find 4731 4732 (defun consult--find (prompt builder initial) 4733 "Run find command in current directory. 4734 4735 The function returns the selected file. 4736 The filename at point is added to the future history. 4737 4738 BUILDER is the command builder. 4739 PROMPT is the prompt. 4740 INITIAL is inital input." 4741 (consult--read 4742 (consult--async-command builder 4743 (consult--async-map (lambda (x) (string-remove-prefix "./" x))) 4744 (consult--async-highlight builder) 4745 :file-handler t) ;; allow tramp 4746 :prompt prompt 4747 :sort nil 4748 :require-match t 4749 :initial (consult--async-split-initial initial) 4750 :add-history (consult--async-split-thingatpt 'filename) 4751 :category 'file 4752 :history '(:input consult--find-history))) 4753 4754 (defun consult--find-make-builder () 4755 "Create find command line builder." 4756 (let* ((cmd (consult--build-args consult-find-args)) 4757 (type (if (eq 0 (call-process-shell-command 4758 (concat (car cmd) " -regextype emacs -version"))) 4759 'emacs 'basic))) 4760 (lambda (input) 4761 (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) 4762 ;; ignore-case=t since -iregex is used below 4763 (`(,re . ,hl) (funcall consult--regexp-compiler arg type t))) 4764 (when re 4765 (list :command 4766 (append cmd 4767 (cdr (mapcan 4768 (lambda (x) 4769 `("-and" "-iregex" 4770 ,(format ".*%s.*" 4771 ;; HACK Replace non-capturing groups with capturing groups. 4772 ;; GNU find does not support non-capturing groups. 4773 (replace-regexp-in-string 4774 "\\\\(\\?:" "\\(" x 'fixedcase 'literal)))) 4775 re)) 4776 opts) 4777 :highlight hl)))))) 4778 4779 ;;;###autoload 4780 (defun consult-find (&optional dir initial) 4781 "Search for files in DIR matching input regexp given INITIAL input. 4782 4783 The find process is started asynchronously, similar to `consult-grep'. 4784 See `consult-grep' for more details regarding the asynchronous search." 4785 (interactive "P") 4786 (let* ((prompt-dir (consult--directory-prompt "Find" dir)) 4787 (default-directory (cdr prompt-dir))) 4788 (find-file (consult--find (car prompt-dir) (consult--find-make-builder) initial)))) 4789 4790 ;;;;; Command: consult-locate 4791 4792 (defun consult--locate-builder (input) 4793 "Build command line given CONFIG and INPUT." 4794 (pcase-let ((`(,arg . ,opts) (consult--command-split input))) 4795 (unless (string-blank-p arg) 4796 (list :command (append (consult--build-args consult-locate-args) 4797 (list arg) opts) 4798 :highlight (cdr (consult--default-regexp-compiler input 'basic t)))))) 4799 4800 ;;;###autoload 4801 (defun consult-locate (&optional initial) 4802 "Search with `locate' for files which match input given INITIAL input. 4803 4804 The input is treated literally such that locate can take advantage of 4805 the locate database index. Regular expressions would often force a slow 4806 linear search through the entire database. The locate process is started 4807 asynchronously, similar to `consult-grep'. See `consult-grep' for more 4808 details regarding the asynchronous search." 4809 (interactive) 4810 (find-file (consult--find "Locate: " #'consult--locate-builder initial))) 4811 4812 ;;;;; Command: consult-man 4813 4814 (defun consult--man-builder (input) 4815 "Build command line given CONFIG and INPUT." 4816 (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) 4817 (`(,re . ,hl) (funcall consult--regexp-compiler arg 'basic t))) 4818 (when re 4819 (list :command (append (consult--build-args consult-man-args) 4820 (list (consult--join-regexps re 'basic)) 4821 opts) 4822 :highlight hl)))) 4823 4824 (defun consult--man-format (lines) 4825 "Format man candidates from LINES." 4826 (let ((candidates)) 4827 (save-match-data 4828 (dolist (str lines) 4829 (when (string-match "\\`\\(.*?\\([^ ]+\\) *(\\([^,)]+\\)[^)]*).*?\\) +- +\\(.*\\)\\'" str) 4830 (let ((names (match-string 1 str)) 4831 (name (match-string 2 str)) 4832 (section (match-string 3 str)) 4833 (desc (match-string 4 str))) 4834 (add-face-text-property 0 (length names) 'consult-file nil names) 4835 (push (cons 4836 (format "%s - %s" names desc) 4837 (concat section " " name)) 4838 candidates))))) 4839 (nreverse candidates))) 4840 4841 ;;;###autoload 4842 (defun consult-man (&optional initial) 4843 "Search for man page given INITIAL input. 4844 4845 The input string is not preprocessed and passed literally to the 4846 underlying man commands. The man process is started asynchronously, 4847 similar to `consult-grep'. See `consult-grep' for more details regarding 4848 the asynchronous search." 4849 (interactive) 4850 (man (consult--read 4851 (consult--async-command #'consult--man-builder 4852 (consult--async-transform consult--man-format) 4853 (consult--async-highlight #'consult--man-builder)) 4854 :prompt "Manual entry: " 4855 :require-match t 4856 :lookup #'consult--lookup-cdr 4857 :initial (consult--async-split-initial initial) 4858 :add-history (consult--async-split-thingatpt 'symbol) 4859 :history '(:input consult--man-history)))) 4860 4861 ;;;; Obsolete commands 4862 4863 ;;;###autoload 4864 (defun consult-apropos () 4865 "Select pattern and call `apropos'. 4866 4867 The default value of the completion is the symbol at point. As a better 4868 alternative, you can run `embark-export' from commands like `M-x' and 4869 `describe-symbol'." 4870 (interactive) 4871 (let ((pattern 4872 (consult--read 4873 obarray 4874 :prompt "consult-apropos (obsolete): " 4875 :predicate (lambda (x) (or (fboundp x) (boundp x) (facep x) (symbol-plist x))) 4876 :category 'symbol 4877 :default (thing-at-point 'symbol)))) 4878 (when (string= pattern "") 4879 (user-error "No pattern given")) 4880 (apropos pattern))) 4881 4882 (make-obsolete 4883 'consult-apropos 4884 "consult-apropos has been deprecated in favor of Embark actions: 4885 M-x describe-symbol <regexp> M-x embark-export 4886 M-x describe-symbol <regexp> M-x embark-act a" 4887 "0.20") 4888 4889 ;;;###autoload 4890 (defun consult-file-externally (file) 4891 "Open FILE externally using the default application of the system." 4892 (interactive "fOpen externally: ") 4893 (if (and (eq system-type 'windows-nt) 4894 (fboundp 'w32-shell-execute)) 4895 (w32-shell-execute "open" file) 4896 (call-process (pcase system-type 4897 ('darwin "open") 4898 ('cygwin "cygstart") 4899 (_ "xdg-open")) 4900 nil 0 nil 4901 (expand-file-name file)))) 4902 4903 (make-obsolete 'consult-file-externally 'embark-open-externally "0.29") 4904 4905 ;;;###autoload 4906 (defun consult-multi-occur (bufs regexp &optional nlines) 4907 "Improved version of `multi-occur' based on `completing-read-multiple'. 4908 4909 See `multi-occur' for the meaning of the arguments BUFS, REGEXP and NLINES." 4910 (interactive (cons 4911 (mapcar #'get-buffer 4912 (completing-read-multiple "Buffer: " 4913 #'internal-complete-buffer)) 4914 (occur-read-primary-args))) 4915 (occur-1 regexp nlines bufs)) 4916 4917 (make-obsolete 'consult-multi-occur 'consult-line-multi "0.29") 4918 4919 ;;;; Preview at point in completions buffers 4920 4921 (define-minor-mode consult-preview-at-point-mode 4922 "Preview minor mode for *Completions* buffers. 4923 When moving around in the *Completions* buffer, the candidate at point is 4924 automatically previewed." 4925 :init-value nil :group 'consult 4926 (if consult-preview-at-point-mode 4927 (add-hook 'post-command-hook #'consult-preview-at-point nil 'local) 4928 (remove-hook 'post-command-hook #'consult-preview-at-point 'local))) 4929 4930 (defun consult-preview-at-point () 4931 "Preview candidate at point in *Completions* buffer." 4932 (interactive) 4933 (when-let* ((win (active-minibuffer-window)) 4934 (buf (window-buffer win)) 4935 (fun (buffer-local-value 'consult--preview-function buf))) 4936 (funcall fun))) 4937 4938 ;;;; Integration with the default completion system 4939 4940 (defun consult--default-completion-minibuffer-candidate () 4941 "Return current minibuffer candidate from default completion system or Icomplete." 4942 (when (and (minibufferp) 4943 (eq completing-read-function #'completing-read-default)) 4944 (let ((content (minibuffer-contents-no-properties))) 4945 ;; When the current minibuffer content matches a candidate, return it! 4946 (if (test-completion content 4947 minibuffer-completion-table 4948 minibuffer-completion-predicate) 4949 content 4950 ;; Return the full first candidate of the sorted completion list. 4951 (when-let ((completions (completion-all-sorted-completions))) 4952 (concat 4953 (substring content 0 (or (cdr (last completions)) 0)) 4954 (car completions))))))) 4955 4956 (defun consult--default-completion-list-candidate () 4957 "Return current candidate at point from completions buffer." 4958 (let (beg end) 4959 (when (and 4960 (derived-mode-p 'completion-list-mode) 4961 ;; Logic taken from `choose-completion'. 4962 ;; TODO Upstream a `completion-list-get-candidate' function. 4963 (cond 4964 ((and (not (eobp)) (get-text-property (point) 'mouse-face)) 4965 (setq end (point) beg (1+ (point)))) 4966 ((and (not (bobp)) (get-text-property (1- (point)) 'mouse-face)) 4967 (setq end (1- (point)) beg (point))))) 4968 (setq beg (previous-single-property-change beg 'mouse-face) 4969 end (or (next-single-property-change end 'mouse-face) (point-max))) 4970 (or (get-text-property beg 'completion--string) 4971 (buffer-substring-no-properties beg end))))) 4972 4973 ;; Announce now that consult has been loaded 4974 (provide 'consult) 4975 4976 ;;;; Integration with other completion systems 4977 4978 (with-eval-after-load 'icomplete (require 'consult-icomplete)) 4979 (with-eval-after-load 'vertico (require 'consult-vertico)) 4980 (with-eval-after-load 'mct (add-hook 'consult--completion-refresh-hook 4981 'mct--live-completions-refresh)) 4982 (with-eval-after-load 'selectrum 4983 (warn (propertize "Consult: Selectrum has been deprecated in favor of Vertico" 'face 'warning))) 4984 4985 ;;; consult.el ends here