summaryrefslogtreecommitdiff
path: root/emacs
diff options
context:
space:
mode:
authornoa2025-02-17 00:01:51 +0800
committernoa2025-02-17 00:01:51 +0800
commit3b8b726ced8d5008147a7da336ce6f2f86e1fe2d (patch)
tree6c0b1e88b508ceb7d0abad968222358fe3dbe95d /emacs
parent91e3f9bb49169f70b92847e18029bb50e964b00e (diff)
Add some helper packages to site-lisp
Diffstat (limited to 'emacs')
-rw-r--r--emacs/site-lisp/consult-recoll.el333
-rw-r--r--emacs/site-lisp/consult.el5551
2 files changed, 5884 insertions, 0 deletions
diff --git a/emacs/site-lisp/consult-recoll.el b/emacs/site-lisp/consult-recoll.el
new file mode 100644
index 0000000..5410b5e
--- /dev/null
+++ b/emacs/site-lisp/consult-recoll.el
@@ -0,0 +1,333 @@
+;;; consult-recoll.el --- Recoll queries using consult -*- lexical-binding: t; -*-
+
+;; Author: Jose A Ortega Ruiz <jao@gnu.org>
+;; Maintainer: Jose A Ortega Ruiz <jao@gnu.org>
+;; Keywords: docs, convenience
+;; License: GPL-3.0-or-later
+;; Version: 1.0.0
+;; Package-Requires: ((emacs "26.1") (consult "2.0"))
+;; Homepage: https://codeberg.org/jao/consult-recoll
+
+;; Copyright (C) 2021-2025 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; A `consult-recoll' command to perform interactive queries (including life
+;; previews of documment snippets) over your Recoll
+;; (https://www.lesbonscomptes.com/recoll/) index, using consult.
+;;
+;; Use
+;;
+;; M-x consult-recoll
+;;
+;; to get started, and check the corresponding customization group for ways to
+;; tweak its behaviour to your needs.
+
+;;; Code:
+
+(require 'seq)
+(require 'subr-x)
+(require 'files)
+
+(eval-when-compile (require 'cl-lib))
+
+(require 'consult)
+
+(declare-function eww-open-file "eww")
+
+(defgroup consult-recoll nil
+ "Options for consult recoll."
+ :group 'consult)
+
+(defcustom consult-recoll-prompt "Recoll search: "
+ "Prompt used by `consult-recoll'."
+ :type 'string)
+
+(defcustom consult-recoll-program "recollq"
+ "Program (or full path to program) used to perform text searches.
+
+This is typically recollq if you have a standard recoll distribution,
+but can be also be set to recoll, or the full path to it if it's
+not in your PATH. In the latter case, you'll want to add -t to
+`consult-recoll-search-flags'."
+ :type 'string)
+
+(defcustom consult-recoll-search-flags 'query
+ "List of flags used to perform queries via recollq.
+
+The special values query and terms will select for you flags
+adequated to perform searches using recoll's query language or
+simply search for all provided terms, respectively.
+
+If you don't care about snippets and need speedier searches, you
+can also set this variable to the special values no-snippets or
+terms-no-snippets for query/all-terms searches that will return
+no snippets.."
+ :type '(choice (const :tag "Query language" query)
+ (const :tag "All terms" terms)
+ (const :tag "Query language sans snippets" no-snippets)
+ (const :tag "All terms sans snippets" terms-no-snippets)
+ (list string)))
+
+(defcustom consult-recoll-open-fn nil
+ "Default function used to open candidate URLs.
+It receives the full path to the file to open and (if
+`consult-recoll-inline-snippets' is set, a page number for the
+snippet at hand. If set to nil, find-file is used. See also
+`consult-recoll-open-fns'"
+ :type '(choice (const nil) function))
+
+(defcustom consult-recoll-open-fns ()
+ "Alist mapping mime types to functions to open a selected candidate.
+If you are setting `consult-list-snippets' to t, these functions
+will be called with two arguments (a file path and a page
+number), otherwise just with one."
+ :type '(alist :key-type string :value-type function))
+
+(defcustom consult-recoll-inline-snippets nil
+ "Show snippets as completion candidates in the minibuffer."
+ :type 'boolean)
+
+(defcustom consult-recoll-group-by-mime t
+ "When set, list search results grouped by mime type."
+ :type 'boolean)
+
+(defcustom consult-recoll-format-candidate nil
+ "A function taking title, path and mime type, and formatting them for display.
+Set to nil to use the default `title (path)' format."
+ :type '(choice (const nil) function))
+
+(defface consult-recoll-url-face '((t :inherit link))
+ "Face used to display URLs of candidates.")
+
+(defface consult-recoll-title-face '((t :inherit italic))
+ "Face used to display titles of candidates.")
+
+(defface consult-recoll-mime-face '((t :inherit font-lock-comment-face))
+ "Face used to display MIME type of candidates.")
+
+(defvar consult-recoll-history nil "History for `consult-recoll'.")
+(defvar consult-recoll--current nil)
+(defvar consult-recoll--index 0)
+(defvar consult-recoll--snippets nil)
+
+(defun consult-recoll--search-flags ()
+ "Compute search flags according to `consult-recoll-search-flags'."
+ (cond ((listp consult-recoll-search-flags)
+ consult-recoll-search-flags)
+ ((symbolp consult-recoll-search-flags)
+ (cl-case consult-recoll-search-flags
+ (terms '("-A" "-p" "5" "-a"))
+ (no-snippets '())
+ (terms-no-snippets '("-a"))
+ (t '("-A" "-p" "5"))))
+ (t (user-error "Invalid value of `consult-recoll-search-flags'"))))
+
+(defun consult-recoll--command (text)
+ "Command used to perform queries for TEXT."
+ (setq consult-recoll--current nil)
+ (setq consult-recoll--index 0)
+ (setq consult-recoll--snippets nil)
+ `(,consult-recoll-program ,@(consult-recoll--search-flags) ,text))
+
+(defun consult-recoll--format (title urln mime)
+ (if consult-recoll-format-candidate
+ (funcall consult-recoll-format-candidate title urln mime)
+ (format "%s (%s)"
+ (propertize title 'face 'consult-recoll-title-face)
+ (propertize urln 'face 'consult-recoll-url-face))))
+
+(defsubst consult-recoll--candidate-title (candidate)
+ (get-text-property 0 'title candidate))
+
+(defsubst consult-recoll--candidate-mime (candidate)
+ (get-text-property 0 'mime-type candidate))
+
+(defsubst consult-recoll--candidate-url (candidate)
+ (get-text-property 0 'url candidate))
+
+(defsubst consult-recoll--candidate-size (candidate)
+ (get-text-property 0 'size candidate))
+
+(defsubst consult-recoll--candidate-page (candidate)
+ (get-text-property 0 'page candidate))
+
+(defsubst consult-recoll--candidate-index (candidate)
+ (get-text-property 0 'index candidate))
+
+(defsubst consult-recoll--snippets (candidate)
+ (let* ((len (length consult-recoll--snippets))
+ (idx (or (consult-recoll--candidate-index candidate) 0))
+ (pos (- len idx)))
+ (if (>= pos len)
+ ""
+ (mapconcat 'identity (reverse (elt consult-recoll--snippets pos)) "\n"))))
+
+(defun consult-recoll--search-snippet (candidate _mime)
+ "When CANDIDATE is the text of a snippet, search for it in current buffer."
+ (when (string-match "^\s+0 : " candidate)
+ (let ((txt (replace-match "" nil nil candidate)))
+ (goto-char (point-min))
+ (when (or (search-forward txt nil t)
+ (and (derived-mode-p 'org-mode)
+ (let ((txt (replace-regexp-in-string "\\]\\].+" "" txt)))
+ (search-forward txt nil t)))
+ (let ((mid (/ (length txt) 2)))
+ (or (search-forward (substring txt 0 mid) nil t)
+ (search-forward (substring txt mid) nil t))))
+ (goto-char (match-beginning 0))
+ (when (derived-mode-p 'org-mode) (org-reveal))))))
+
+(declare-function doc-view-goto-page "doc-view")
+(declare-function pdf-view-goto-page "ext:pdf-view")
+
+(defun consult-recoll--open-file (filename &optional page)
+ "Default function for opening result files."
+ (find-file filename)
+ (when page
+ (cond ((derived-mode-p 'doc-view-mode) (doc-view-goto-page page))
+ ((derived-mode-p 'pdf-view-mode) (pdf-view-goto-page page)))))
+
+(defun consult-recoll--open (candidate)
+ "Open file of corresponding completion CANDIDATE."
+ (when candidate
+ (let* ((url (consult-recoll--candidate-url candidate))
+ (mime (consult-recoll--candidate-mime candidate))
+ (open (cond ((cdr (assoc mime consult-recoll-open-fns)))
+ (consult-recoll-open-fn)
+ ((string= mime "text/html")
+ (lambda (f &optional _ignored) (eww-open-file f)))
+ (t #'consult-recoll--open-file))))
+ (if (not consult-recoll-inline-snippets)
+ (funcall open url)
+ (funcall open url (consult-recoll--candidate-page candidate))
+ (when (or (string-prefix-p "text/" mime)
+ (string-prefix-p "message/" mime))
+ (consult-recoll--search-snippet candidate mime))))))
+
+(defconst consult-recoll--line-rx
+ "^\\(.*?\\)\t\\[\\(.*?\\)\\]\t\\[\\(.*\\)\\]\\(\t\\([0-9]+\\)\\)?"
+ "Regular expression decomposing result lines returned by recollq")
+
+(defun consult-recoll--transformer (str)
+ "Decode STR, as returned by recollq."
+ (cond ((string-match consult-recoll--line-rx str)
+ (let* ((mime (match-string 1 str))
+ (url (match-string 2 str))
+ (title (match-string 3 str))
+ (size (match-string 5 str))
+ (urln (if (string-prefix-p "file://" url) (substring url 7) url))
+ (idx (setq consult-recoll--index (1+ consult-recoll--index)))
+ (cand (consult-recoll--format title url mime))
+ (cand (propertize cand
+ 'mime-type mime
+ 'url urln
+ 'title title
+ 'index idx
+ 'size size)))
+ (push () consult-recoll--snippets)
+ (setq consult-recoll--current cand)))
+ ((string-match-p "^/?SNIPPETS$" str) nil)
+ ((and consult-recoll-inline-snippets consult-recoll--current)
+ (when-let* ((page (and (string-match "^\\([0-9]+\\) :" str)
+ (match-string 1 str)))
+ (pageno (and page (string-to-number page)))
+ (props (text-properties-at 0 consult-recoll--current)))
+ (apply #'propertize (concat " " str) 'page pageno props)))
+ (consult-recoll--current
+ (push str (car consult-recoll--snippets))
+ nil)))
+
+(defvar consult-recoll--preview-buffer "*consult-recoll preview*")
+
+(defun consult-recoll--preview (action candidate)
+ "Preview search result CANDIDATE when ACTION is \\='preview."
+ (cond ((or (eq action 'setup) (null candidate))
+ (with-current-buffer (get-buffer-create consult-recoll--preview-buffer)
+ (setq-local cursor-in-non-selected-windows nil)
+ (delete-region (point-min) (point-max))))
+ ((and (eq action 'preview) candidate)
+ (when-let* ((url (consult-recoll--candidate-url candidate))
+ (buff (get-buffer consult-recoll--preview-buffer)))
+ (with-current-buffer buff
+ (delete-region (point-min) (point-max))
+ (when-let (title (consult-recoll--candidate-title candidate))
+ (insert (propertize title 'face 'consult-recoll-title-face) "\n"))
+ (insert (propertize url 'face 'consult-recoll-url-face) "\n")
+ (insert (propertize (consult-recoll--candidate-mime candidate)
+ 'face 'consult-recoll-mime-face))
+ (when-let (s (consult-recoll--snippets candidate))
+ (insert "\n\n" s))
+ (goto-char (point-min)))
+ (pop-to-buffer buff)))
+ ((eq action 'exit)
+ (when (get-buffer consult-recoll--preview-buffer)
+ (kill-buffer consult-recoll--preview-buffer)))))
+
+(defun consult-recoll--group (candidate transform)
+ "If TRANSFORM return candidate, othewise extract mime-type."
+ (if transform candidate (consult-recoll--candidate-mime candidate)))
+
+(defun consult-recoll--format-size (bytes)
+ "Format the given size with adaptive units."
+ (file-size-human-readable (string-to-number bytes) nil " " "B"))
+
+(defun consult-recoll--annotation (candidate)
+ "Annotation for the given CANDIDATE (its size by default)"
+ (and (not (consult-recoll--candidate-page candidate))
+ (format " (%s)" (consult-recoll--format-size
+ (consult-recoll--candidate-size candidate)))))
+
+(defun consult-recoll--search (&optional initial)
+ "Perform an asynchronous recoll search via `consult--read'.
+If given, use INITIAL as the starting point of the query."
+ (consult--read (consult--async-pipeline
+ (consult--process-collection #'consult-recoll--command)
+ (consult--async-map #'consult-recoll--transformer)
+ (consult--async-filter #'identity))
+ :annotate #'consult-recoll--annotation
+ :prompt consult-recoll-prompt
+ :require-match t
+ :lookup #'consult--lookup-member
+ :sort nil
+ :state (and (not consult-recoll-inline-snippets)
+ #'consult-recoll--preview)
+ :group (and consult-recoll-group-by-mime
+ #'consult-recoll--group)
+ :initial initial
+ :history '(:input consult-recoll-history)
+ :category 'recoll-result))
+
+;;;###autoload
+(defun consult-recoll (ask)
+ "Consult recoll's local index.
+With prefix argument ASK, the user is prompted for an initial query string."
+ (interactive "P")
+ (let ((initial (when ask
+ (if (stringp ask) ask (read-string "Initial query: ")))))
+ (consult-recoll--open (consult-recoll--search initial))))
+
+;;;###autoload
+(defun consult-recoll-embark-setup ()
+ "Set up integration with embark.
+In particular, allow opening candidates from embark-collect
+buffers."
+ (add-to-list 'embark-default-action-overrides
+ '(recoll-result . consult-recoll--open)))
+
+
+(provide 'consult-recoll)
+;;; consult-recoll.el ends here
diff --git a/emacs/site-lisp/consult.el b/emacs/site-lisp/consult.el
new file mode 100644
index 0000000..310b523
--- /dev/null
+++ b/emacs/site-lisp/consult.el
@@ -0,0 +1,5551 @@
+;;; consult.el --- Consulting completing-read -*- lexical-binding: t -*-
+
+;; Copyright (C) 2021-2025 Free Software Foundation, Inc.
+
+;; Author: Daniel Mendler and Consult contributors
+;; Maintainer: Daniel Mendler <mail@daniel-mendler.de>
+;; Created: 2020
+;; Version: 2.0
+;; Package-Requires: ((emacs "28.1") (compat "30"))
+;; URL: https://github.com/minad/consult
+;; Keywords: matching, files, completion
+
+;; This file is part of GNU Emacs.
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Consult implements a set of `consult-<thing>' commands, which aim to
+;; improve the way you use Emacs. The commands are founded on
+;; `completing-read', which selects from a list of candidate strings.
+;; Consult provides an enhanced buffer switcher `consult-buffer' and
+;; search and navigation commands like `consult-imenu' and
+;; `consult-line'. Searching through multiple files is supported by the
+;; asynchronous `consult-grep' command. Many Consult commands support
+;; previewing candidates. If a candidate is selected in the completion
+;; view, the buffer shows the candidate immediately.
+
+;; The Consult commands are compatible with multiple completion systems
+;; based on the Emacs `completing-read' API, including the default
+;; completion system, Vertico, Mct and Icomplete.
+
+;; See the README for an overview of the available Consult commands and
+;; the documentation of the configuration and installation of the
+;; package.
+
+;; The full list of contributors can be found in the acknowledgments
+;; section of the README.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'cl-lib)
+ (require 'subr-x))
+(require 'compat)
+(require 'bookmark)
+
+(defgroup consult nil
+ "Consulting `completing-read'."
+ :link '(info-link :tag "Info Manual" "(consult)")
+ :link '(url-link :tag "Website" "https://github.com/minad/consult")
+ :link '(url-link :tag "Wiki" "https://github.com/minad/consult/wiki")
+ :link '(emacs-library-link :tag "Library Source" "consult.el")
+ :group 'files
+ :group 'outlines
+ :group 'minibuffer
+ :prefix "consult-")
+
+;;;; Customization
+
+(defcustom consult-narrow-key nil
+ "Prefix key for narrowing during completion.
+
+Good choices for this key are \"<\" and \"C-+\" for example. The
+key must be a string accepted by `key-valid-p'."
+ :type '(choice key (const :tag "None" nil)))
+
+(defcustom consult-widen-key nil
+ "Key used for widening during completion.
+
+If this key is unset, defaults to twice the `consult-narrow-key'.
+The key must be a string accepted by `key-valid-p'."
+ :type '(choice key (const :tag "None" nil)))
+
+(defcustom consult-project-function
+ #'consult--default-project-function
+ "Function which returns project root directory.
+The function takes one boolean argument MAY-PROMPT. If
+MAY-PROMPT is non-nil, the function may ask the prompt the user
+for a project directory. The root directory is used by
+`consult-buffer' and `consult-grep'."
+ :type `(choice
+ (const :tag "Default project function" ,#'consult--default-project-function)
+ (function :tag "Custom function")
+ (const :tag "No project integration" nil)))
+
+(defcustom consult-async-refresh-delay 0.2
+ "Refreshing delay of the completion UI for asynchronous commands.
+
+The completion UI is only updated every
+`consult-async-refresh-delay' seconds. This applies to
+asynchronous commands like for example `consult-grep'."
+ :type '(float :tag "Delay in seconds"))
+
+(defcustom consult-async-input-throttle 0.5
+ "Input throttle for asynchronous commands.
+
+The asynchronous process is started only every
+`consult-async-input-throttle' seconds. This applies to asynchronous
+commands, e.g., `consult-grep'."
+ :type '(float :tag "Delay in seconds"))
+
+(defcustom consult-async-input-debounce 0.2
+ "Input debounce for asynchronous commands.
+
+The asynchronous process is started only when there has not been new
+input for `consult-async-input-debounce' seconds. This applies to
+asynchronous commands, e.g., `consult-grep'."
+ :type '(float :tag "Delay in seconds"))
+
+(defcustom consult-async-min-input 3
+ "Minimum number of characters needed, before asynchronous process is called.
+
+This applies to asynchronous commands, e.g., `consult-grep'."
+ :type '(natnum :tag "Number of characters"))
+
+(defcustom consult-async-split-style 'perl
+ "Async splitting style, see `consult-async-split-styles-alist'."
+ :type '(choice (const :tag "No splitting" nil)
+ (const :tag "Comma" comma)
+ (const :tag "Semicolon" semicolon)
+ (const :tag "Perl" perl)))
+
+(defcustom consult-async-split-styles-alist
+ `((none :function ,#'consult--split-none)
+ (comma :separator ?, :function ,#'consult--split-separator)
+ (semicolon :separator ?\; :function ,#'consult--split-separator)
+ (perl :initial ?# :function ,#'consult--split-perl))
+ "Async splitting styles."
+ :type '(alist :key-type symbol :value-type plist))
+
+(defcustom consult-async-indicator
+ '((running ?* consult-async-running)
+ (finished ?: consult-async-finished)
+ (killed ?\; consult-async-failed)
+ (failed ?! consult-async-failed))
+ "Async indicator characters and faces.
+Set to nil to disable."
+ :type '(alist :key-type symbol :value-type (list character face)))
+
+(defcustom consult-mode-histories
+ '((eshell-mode eshell-history-ring eshell-history-index eshell-bol)
+ (comint-mode comint-input-ring comint-input-ring-index comint-bol)
+ (term-mode term-input-ring term-input-ring-index term-bol))
+ "Alist of mode histories (mode history index bol).
+The histories can be rings or lists. Index, if provided, is a
+variable to set to the index of the selection within the ring or
+list. Bol, if provided is a function which jumps to the beginning
+of the line after the prompt."
+ :type '(alist :key-type symbol
+ :value-type (group :tag "Include Index"
+ (symbol :tag "List/Ring")
+ (symbol :tag "Index Variable")
+ (symbol :tag "Bol Function"))))
+
+(defcustom consult-themes nil
+ "List of themes (symbols or regexps) to be presented for selection.
+nil shows all `custom-available-themes'."
+ :type '(repeat (choice symbol regexp)))
+
+(defcustom consult-after-jump-hook (list #'recenter)
+ "Function called after jumping to a location.
+
+Commonly used functions for this hook are `recenter' and
+`reposition-window'. You may want to add a function which pulses the
+current line, e.g., `pulse-momentary-highlight-one-line'. The hook
+called during preview and for the jump after selection."
+ :type 'hook)
+
+(defcustom consult-line-start-from-top nil
+ "Start search from the top if non-nil.
+Otherwise start the search at the current line and wrap around."
+ :type 'boolean)
+
+(defcustom consult-point-placement 'match-beginning
+ "Where to leave point when jumping to a match.
+This setting affects the command `consult-line' and the `consult-grep' variants."
+ :type '(choice (const :tag "Beginning of the line" line-beginning)
+ (const :tag "Beginning of the match" match-beginning)
+ (const :tag "End of the match" match-end)))
+
+(defcustom consult-line-numbers-widen t
+ "Show absolute line numbers when narrowing is active.
+
+See also `display-line-numbers-widen'."
+ :type 'boolean)
+
+(defcustom consult-goto-line-numbers t
+ "Show line numbers for `consult-goto-line'."
+ :type 'boolean)
+
+(defcustom consult-fontify-preserve t
+ "Preserve fontification for line-based commands."
+ :type 'boolean)
+
+(defcustom consult-fontify-max-size 1048576
+ "Buffers larger than this byte limit are not fontified.
+
+This is necessary in order to prevent a large startup time
+for navigation commands like `consult-line'."
+ :type '(natnum :tag "Buffer size in bytes"))
+
+(defcustom consult-buffer-filter
+ '("\\` "
+ "\\`\\*Completions\\*\\'"
+ "\\`\\*Multiple Choice Help\\*\\'"
+ "\\`\\*Flymake log\\*\\'"
+ "\\`\\*Semantic SymRef\\*\\'"
+ "\\`\\*vc\\*\\'"
+ "\\`newsrc-dribble\\'" ;; Gnus
+ "\\`\\*tramp/.*\\*\\'")
+ "Filter regexps for `consult-buffer'.
+
+The default setting is to filter ephemeral buffer names beginning
+with a space character, the *Completions* buffer and a few log
+buffers. The regular expressions are matched case sensitively."
+ :type '(repeat regexp))
+
+(defcustom consult-buffer-sources
+ '(consult--source-hidden-buffer
+ consult--source-modified-buffer
+ consult--source-buffer
+ consult--source-recent-file
+ consult--source-file-register
+ consult--source-bookmark
+ consult--source-project-buffer-hidden
+ consult--source-project-recent-file-hidden
+ consult--source-project-root-hidden)
+ "Sources used by `consult-buffer'.
+See also `consult-project-buffer-sources'.
+See `consult--multi' for a description of the source data structure."
+ :type '(repeat symbol))
+
+(defcustom consult-project-buffer-sources
+ '(consult--source-project-buffer
+ consult--source-project-recent-file
+ consult--source-project-root)
+ "Sources used by `consult-project-buffer'.
+See also `consult-buffer-sources'.
+See `consult--multi' for a description of the source data structure."
+ :type '(repeat symbol))
+
+(defcustom consult-mode-command-filter
+ '(;; Filter commands
+ "-mode\\'" "--"
+ ;; Filter whole features
+ simple mwheel time so-long recentf tab-bar tab-line)
+ "Filter commands for `consult-mode-command'."
+ :type '(repeat (choice symbol regexp)))
+
+(defcustom consult-grep-max-columns 300
+ "Maximal number of columns of grep output.
+If set to nil, do not truncate candidates. This can have negative
+performance implications but helps if you want to export long lines via
+`embark-export'."
+ :type '(choice natnum (const nil)))
+
+(defconst consult--grep-match-regexp
+ "\\`\\(?:\\./\\)?\\([^\n\0]+\\)\0\\([0-9]+\\)\\([-:\0]\\)"
+ "Regexp used to match file and line of grep output.")
+
+(defcustom consult-grep-args
+ '("grep" (consult--grep-exclude-args)
+ "--null --line-buffered --color=never --ignore-case\
+ --with-filename --line-number -I -r")
+ "Command line arguments for grep, see `consult-grep'.
+The dynamically computed arguments are appended.
+Can be either a string, or a list of strings or expressions."
+ :type '(choice string (repeat (choice string sexp))))
+
+(defcustom consult-git-grep-args
+ "git --no-pager grep --null --color=never --ignore-case\
+ --extended-regexp --line-number -I"
+ "Command line arguments for git-grep, see `consult-git-grep'.
+The dynamically computed arguments are appended.
+Can be either a string, or a list of strings or expressions."
+ :type '(choice string (repeat (choice string sexp))))
+
+(defcustom consult-ripgrep-args
+ "rg --null --line-buffered --color=never --max-columns=1000 --path-separator /\
+ --smart-case --no-heading --with-filename --line-number --search-zip"
+ "Command line arguments for ripgrep, see `consult-ripgrep'.
+The dynamically computed arguments are appended.
+Can be either a string, or a list of strings or expressions."
+ :type '(choice string (repeat (choice string sexp))))
+
+(defcustom consult-find-args
+ "find . -not ( -path */.[A-Za-z]* -prune )"
+ "Command line arguments for find, see `consult-find'.
+The dynamically computed arguments are appended.
+Can be either a string, or a list of strings or expressions."
+ :type '(choice string (repeat (choice string sexp))))
+
+(defcustom consult-fd-args
+ '((if (executable-find "fdfind" 'remote) "fdfind" "fd")
+ "--full-path --color=never")
+ "Command line arguments for fd, see `consult-fd'.
+The dynamically computed arguments are appended.
+Can be either a string, or a list of strings or expressions."
+ :type '(choice string (repeat (choice string sexp))))
+
+(defcustom consult-locate-args
+ "locate --ignore-case" ;; --existing not supported by Debian plocate
+ "Command line arguments for locate, see `consult-locate'.
+The dynamically computed arguments are appended.
+Can be either a string, or a list of strings or expressions."
+ :type '(choice string (repeat (choice string sexp))))
+
+(defcustom consult-man-args
+ "man -k"
+ "Command line arguments for man, see `consult-man'.
+The dynamically computed arguments are appended.
+Can be either a string, or a list of strings or expressions."
+ :type '(choice string (repeat (choice string sexp))))
+
+(defcustom consult-preview-key 'any
+ "Preview trigger keys, can be nil, `any', a single key or a list of keys.
+Debouncing can be specified via the `:debounce' attribute. The
+individual keys must be strings accepted by `key-valid-p'."
+ :type '(choice (const :tag "Any key" any)
+ (list :tag "Debounced"
+ (const :debounce)
+ (float :tag "Seconds" 0.1)
+ (const any))
+ (const :tag "No preview" nil)
+ (key :tag "Key")
+ (repeat :tag "List of keys" key)))
+
+(defcustom consult-preview-partial-size 1048576
+ "Files larger than this byte limit are previewed partially."
+ :type '(natnum :tag "File size in bytes"))
+
+(defcustom consult-preview-partial-chunk 102400
+ "Partial preview chunk size in bytes.
+If a file is larger than `consult-preview-partial-size' only the
+chunk from the beginning of the file is previewed."
+ :type '(natnum :tag "Chunk size in bytes"))
+
+(defcustom consult-preview-max-count 10
+ "Number of file buffers to keep open temporarily during preview."
+ :type '(natnum :tag "Number of buffers"))
+
+(defcustom consult-preview-excluded-buffers nil
+ "Buffers excluded from preview.
+The value should conform to the predicate format demanded by the
+function `buffer-match-p'."
+ :type 'sexp)
+
+(defcustom consult-preview-excluded-files
+ ;; Do not preview remote and gpg files
+ '("\\`/[^/|:]+:" "\\.gpg\\'")
+ "List of regexps matched against names of files, which are not previewed."
+ :type '(repeat regexp))
+
+(defcustom consult-preview-allowed-hooks
+ '(global-font-lock-mode
+ save-place-find-file-hook)
+ "List of hooks, which should be executed during file preview.
+This variable applies to `find-file-hook', `change-major-mode-hook' and
+mode hooks, e.g., `prog-mode-hook'."
+ :type '(repeat symbol))
+
+(defcustom consult-preview-variables
+ '((inhibit-message . t)
+ (enable-dir-local-variables . nil)
+ (enable-local-variables . :safe)
+ (non-essential . t)
+ (delay-mode-hooks . t))
+ "Variables which are bound for file preview."
+ :type '(alist :key-type symbol))
+
+(defcustom consult-bookmark-narrow
+ `((?f "File" bookmark-default-handler)
+ (?h "Help" help-bookmark-jump Info-bookmark-jump
+ Man-bookmark-jump woman-bookmark-jump)
+ (?p "Picture" image-bookmark-jump)
+ (?d "Docview" doc-view-bookmark-jump)
+ (?m "Mail" gnus-summary-bookmark-jump)
+ (?s "Eshell" eshell-bookmark-jump)
+ (?w "Web" eww-bookmark-jump xwidget-webkit-bookmark-jump-handler)
+ (?v "VC Directory" vc-dir-bookmark-jump)
+ (nil "Other"))
+ "Bookmark narrowing configuration.
+
+Each element of the list must have the form (char name handlers...)."
+ :type '(alist :key-type character :value-type (cons string (repeat function))))
+
+;;;; Faces
+
+(defgroup consult-faces nil
+ "Faces used by Consult."
+ :group 'consult
+ :group 'faces)
+
+(defface consult-preview-line
+ '((t :inherit consult-preview-insertion :extend t))
+ "Face used for line previews.")
+
+(defface consult-highlight-match
+ '((t :inherit match))
+ "Face used to highlight matches in the completion candidates.
+Used for example by `consult-grep'.")
+
+(defface consult-highlight-mark
+ '((t :inherit consult-highlight-match))
+ "Face used for mark positions in completion candidates.
+Used for example by `consult-mark'. The face should be different
+than the `cursor' face to avoid confusion.")
+
+(defface consult-preview-match
+ '((t :inherit isearch))
+ "Face used for match previews, e.g., in `consult-line'.")
+
+(defface consult-preview-insertion
+ '((t :inherit region))
+ "Face used for previews of text to be inserted.
+Used by `consult-completion-in-region', `consult-yank' and `consult-history'.")
+
+(defface consult-narrow-indicator
+ '((t :inherit warning))
+ "Face used for the narrowing indicator.")
+
+(defface consult-async-running
+ '((t :inherit consult-narrow-indicator))
+ "Face used if asynchronous process is running.")
+
+(defface consult-async-finished
+ '((t :inherit success))
+ "Face used if asynchronous process has finished.")
+
+(defface consult-async-failed
+ '((t :inherit error))
+ "Face used if asynchronous process has failed.")
+
+(defface consult-async-split
+ '((t :inherit font-lock-negation-char-face))
+ "Face used to highlight punctuation character.")
+
+(defface consult-help
+ '((t :inherit shadow))
+ "Face used to highlight help, e.g., in `consult-register-store'.")
+
+(defface consult-key
+ '((t :inherit font-lock-keyword-face))
+ "Face used to highlight keys, e.g., in `consult-register'.")
+
+(defface consult-line-number
+ '((t :inherit consult-key))
+ "Face used to highlight location line in `consult-global-mark'.")
+
+(defface consult-file
+ '((t :inherit font-lock-function-name-face))
+ "Face used to highlight files in `consult-buffer'.")
+
+(defface consult-grep-context
+ '((t :inherit shadow))
+ "Face used to highlight grep context in `consult-grep'.")
+
+(defface consult-bookmark
+ '((t :inherit font-lock-constant-face))
+ "Face used to highlight bookmarks in `consult-buffer'.")
+
+(defface consult-buffer
+ '((t))
+ "Face used to highlight buffers in `consult-buffer'.")
+
+(defface consult-line-number-prefix
+ '((t :inherit line-number))
+ "Face used to highlight line number prefixes.")
+
+(defface consult-line-number-wrapped
+ '((t :inherit consult-line-number-prefix :inherit font-lock-warning-face))
+ "Face used to highlight line number prefixes after wrap around.")
+
+(defface consult-separator
+ '((((class color) (min-colors 88) (background light))
+ :foreground "#ccc")
+ (((class color) (min-colors 88) (background dark))
+ :foreground "#333"))
+ "Face used for thin line separators in `consult-register-window'.")
+
+;;;; Input history variables
+
+(defvar consult--path-history nil)
+(defvar consult--grep-history nil)
+(defvar consult--find-history nil)
+(defvar consult--man-history nil)
+(defvar consult--line-history nil)
+(defvar consult--line-multi-history nil)
+(defvar consult--theme-history nil)
+(defvar consult--minor-mode-menu-history nil)
+(defvar consult--buffer-history nil)
+
+;;;; Internal variables
+
+(defvar consult--regexp-compiler
+ #'consult--default-regexp-compiler
+ "Regular expression compiler used by `consult-grep' and other commands.
+The function must return a list of regular expressions and a highlighter
+function.")
+
+(defvar consult--customize-alist
+ ;; Disable preview in frames, since `consult--jump-preview' does not properly
+ ;; clean up. See gh:minad/consult#593. This issue should better be fixed in
+ ;; `consult--jump-preview'.
+ `((,#'consult-buffer-other-frame :preview-key nil)
+ (,#'consult-buffer-other-tab :preview-key nil))
+ "Command configuration alist for fine-grained configuration.
+
+Each element of the list must have the form (command-name plist...). The
+options set here will be evaluated and passed to `consult--read', when
+called from the corresponding command. Note that the options depend on
+the private `consult--read' API and should not be considered as stable
+as the public API.")
+
+(defvar consult--buffer-display #'switch-to-buffer
+ "Buffer display function.")
+
+(defvar consult--completion-candidate-hook
+ (list #'consult--default-completion-minibuffer-candidate
+ #'consult--default-completion-list-candidate)
+ "Get candidate from completion system.")
+
+;; Redisplay such that the updated completion UI will be displayed, even when
+;; the update happened due to `accept-process-output' inside a loop of a dynamic
+;; collection. See `consult--async-dynamic'.
+(defvar consult--completion-refresh-hook '(redisplay)
+ "Refresh completion system.")
+
+(defvar-local consult--preview-function nil
+ "Minibuffer-local variable which exposes the current preview function.
+This function can be called by custom completion systems from
+outside the minibuffer.")
+
+(defvar consult--annotate-align-step 10
+ "Round candidate width.")
+
+(defvar consult--annotate-align-width 0
+ "Maximum candidate width used for annotation alignment.")
+
+(defconst consult--tofu-char #x200000
+ "Special character used to encode line prefixes for disambiguation.
+We use invalid characters outside the Unicode range.")
+
+(defconst consult--tofu-range #x100000
+ "Special character range.")
+
+(defconst consult--tofu-regexp
+ (format "[%c-%c]" consult--tofu-char
+ (+ consult--tofu-char consult--tofu-range -1))
+ "Special character regexp.")
+
+(defvar-local consult--narrow nil
+ "Current narrowing key.")
+
+(defvar-local consult--narrow-config nil
+ "Narrowing config of the current completion.")
+
+(defvar-local consult--narrow-overlay nil
+ "Narrowing indicator overlay.")
+
+(defvar consult--gc-threshold (* 64 1024 1024)
+ "Large GC threshold for temporary increase.")
+
+(defvar consult--gc-percentage 0.5
+ "Large GC percentage for temporary increase.")
+
+(defvar consult--process-chunk (* 1024 1024)
+ "Increase process output chunk size.")
+
+(defvar consult--async-log
+ " *consult-async*"
+ "Buffer for async logging output used by `consult--async-process'.")
+
+(defvar-local consult--focus-lines-overlays nil
+ "Overlays used by `consult-focus-lines'.")
+
+;;;; Miscellaneous helper functions
+
+(defun consult--plist-remove (keys plist)
+ "Remove list of KEYS from PLIST."
+ (let (result)
+ (while plist
+ (unless (memq (car plist) keys)
+ (push (car plist) result)
+ (push (cadr plist) result))
+ (setq plist (cddr plist)))
+ (nreverse result)))
+
+(defun consult--key-parse (key)
+ "Parse KEY or signal error if invalid."
+ (unless (key-valid-p key)
+ (error "%S is not a valid key definition; see `key-valid-p'" key))
+ (key-parse key))
+
+(defun consult--in-buffer (fun &optional buffer)
+ "Ensure that FUN is executed inside BUFFER."
+ (unless buffer (setq buffer (current-buffer)))
+ (lambda (&rest args)
+ (with-current-buffer buffer
+ (apply fun args))))
+
+(defun consult--completion-table-in-buffer (table &optional buffer)
+ "Ensure that completion TABLE is executed inside BUFFER."
+ (if (functionp table)
+ (consult--in-buffer
+ (lambda (str pred action)
+ (let ((result (funcall table str pred action)))
+ (pcase action
+ ('metadata
+ (setq result
+ (mapcar
+ (lambda (x)
+ (if (and (string-suffix-p "-function" (symbol-name (car-safe x))) (cdr x))
+ (cons (car x) (consult--in-buffer (cdr x)))
+ x))
+ result)))
+ ((and 'completion--unquote (guard (functionp (cadr result))))
+ (cl-callf consult--in-buffer (cadr result) buffer)
+ (cl-callf consult--in-buffer (cadddr result) buffer)))
+ result))
+ buffer)
+ table))
+
+(defun consult--build-args (arg)
+ "Return ARG as a flat list of split strings.
+
+Turn ARG into a list, and for each element either:
+- split it if it a string.
+- eval it if it is an expression."
+ (seq-mapcat (lambda (x)
+ (if (stringp x)
+ (split-string-and-unquote x)
+ (ensure-list (eval x 'lexical))))
+ (ensure-list arg)))
+
+(defun consult--command-split (str)
+ "Return command argument and options list given input STR."
+ (save-match-data
+ (let ((opts (when (string-match " +--\\( +\\|\\'\\)" str)
+ (prog1 (substring str (match-end 0))
+ (setq str (substring str 0 (match-beginning 0)))))))
+ ;; split-string-and-unquote fails if the quotes are invalid. Ignore it.
+ (cons str (and opts (ignore-errors (split-string-and-unquote opts)))))))
+
+(defmacro consult--keep! (list form)
+ "Evaluate FORM for every element of LIST and keep the non-nil results."
+ (declare (indent 1))
+ (cl-with-gensyms (head prev result)
+ `(let* ((,head (cons nil ,list))
+ (,prev ,head))
+ (while (cdr ,prev)
+ (if-let (,result (let ((it (cadr ,prev))) ,form))
+ (progn
+ (pop ,prev)
+ (setcar ,prev ,result))
+ (setcdr ,prev (cddr ,prev))))
+ (setq ,list (cdr ,head))
+ nil)))
+
+(defun consult--completion-filter (pattern cands category highlight)
+ "Filter CANDS with PATTERN.
+
+CATEGORY is the completion category, used to find the completion style via
+`completion-category-defaults' and `completion-category-overrides'.
+HIGHLIGHT must be non-nil if the resulting strings should be highlighted."
+ ;; Ensure that the global completion style settings are used for
+ ;; `consult-line', `consult-focus-lines' and `consult-keep-lines' filtering.
+ ;; This override is necessary since users may want to override the settings
+ ;; buffer-locally for in-buffer completion via Corfu.
+ (dlet ((completion-lazy-hilit (not highlight))
+ (completion-styles (default-value 'completion-styles))
+ (completion-category-defaults (default-value 'completion-category-defaults))
+ (completion-category-overrides (default-value 'completion-category-overrides)))
+ ;; `completion-all-completions' returns an improper list where the last link
+ ;; is not necessarily nil.
+ (nconc (completion-all-completions pattern cands nil (length pattern)
+ `(metadata (category . ,category)))
+ nil)))
+
+(defun consult--completion-filter-complement (pattern cands category)
+ "Filter CANDS with complement of PATTERN given completion CATEGORY."
+ (let ((ht (consult--string-hash (consult--completion-filter pattern cands category nil))))
+ (seq-remove (lambda (x) (gethash x ht)) cands)))
+
+(defun consult--completion-filter-dispatch (pattern cands category highlight)
+ "Filter CANDS with PATTERN with optional complement.
+Either using `consult--completion-filter' or
+`consult--completion-filter-complement', depending on if the pattern starts
+with a bang. See `consult--completion-filter' for the arguments CATEGORY and
+HIGHLIGHT."
+ (cond
+ ((string-match-p "\\`!? ?\\'" pattern) cands) ;; empty pattern
+ ((string-prefix-p "! " pattern) (consult--completion-filter-complement
+ (substring pattern 2) cands category))
+ (t (consult--completion-filter pattern cands category highlight))))
+
+(defmacro consult--each-line (beg end &rest body)
+ "Iterate over each line.
+
+The line beginning/ending BEG/END is bound in BODY."
+ (declare (indent 2))
+ (cl-with-gensyms (max)
+ `(save-excursion
+ (let ((,beg (point-min)) (,max (point-max)) ,end)
+ (while (< ,beg ,max)
+ (goto-char ,beg)
+ (setq ,end (pos-eol))
+ ,@body
+ (setq ,beg (1+ ,end)))))))
+
+(defun consult--display-width (string)
+ "Compute width of STRING taking display and invisible properties into account."
+ (let ((pos 0) (width 0) (end (length string)))
+ (while (< pos end)
+ (let ((nextd (next-single-property-change pos 'display string end))
+ (display (get-text-property pos 'display string)))
+ (if (stringp display)
+ (setq width (+ width (string-width display))
+ pos nextd)
+ (while (< pos nextd)
+ (let ((nexti (next-single-property-change pos 'invisible string nextd)))
+ (unless (get-text-property pos 'invisible string)
+ (setq width (+ width (string-width string pos nexti))))
+ (setq pos nexti))))))
+ width))
+
+(defun consult--string-hash (strings)
+ "Create hash table from STRINGS."
+ (let ((ht (make-hash-table :test #'equal :size (length strings))))
+ (dolist (str strings)
+ (puthash str t ht))
+ ht))
+
+(defmacro consult--local-let (binds &rest body)
+ "Buffer local let BINDS of dynamic variables in BODY."
+ (declare (indent 1))
+ (let ((buffer (gensym "buffer"))
+ (local (mapcar (lambda (x) (cons (gensym "local") (car x))) binds)))
+ `(let ((,buffer (current-buffer))
+ ,@(mapcar (lambda (x) `(,(car x) (local-variable-p ',(cdr x)))) local))
+ (unwind-protect
+ (progn
+ ,@(mapcar (lambda (x) `(make-local-variable ',(car x))) binds)
+ (let (,@binds)
+ ,@body))
+ (when (buffer-live-p ,buffer)
+ (with-current-buffer ,buffer
+ ,@(mapcar (lambda (x)
+ `(unless ,(car x)
+ (kill-local-variable ',(cdr x))))
+ local)))))))
+
+(defvar consult--fast-abbreviate-file-name nil)
+(defun consult--fast-abbreviate-file-name (name)
+ "Return abbreviate file NAME.
+This function is a pure variant of `abbreviate-file-name', which
+does not access the file system. This is important if we require
+that the operation is fast, even for remote paths or paths on
+network file systems."
+ (save-match-data
+ (let (case-fold-search) ;; Assume that file system is case sensitive.
+ (setq name (directory-abbrev-apply name))
+ (if (string-match (with-memoization consult--fast-abbreviate-file-name
+ (directory-abbrev-make-regexp (expand-file-name "~")))
+ name)
+ (concat "~" (substring name (match-beginning 1)))
+ name))))
+
+(defun consult--left-truncate-file (file)
+ "Return abbreviated file name of FILE for use in `completing-read' prompt."
+ (save-match-data
+ (let ((file (directory-file-name (abbreviate-file-name file)))
+ (prefix nil))
+ (when (string-match "\\`/\\([^/|:]+:\\)" file)
+ (setq prefix (propertize (match-string 1 file) 'face 'error)
+ file (substring file (match-end 0))))
+ (when (string-match "/\\([^/]+\\)/\\([^/]+\\)\\'" file)
+ (let* ((fst (truncate-string-to-width (match-string 1 file) 20 nil nil "…"))
+ (snd (truncate-string-to-width (match-string 2 file) 20 nil nil "…"))
+ (trunc (format "…/%s/%s" fst snd)))
+ (setq file (if (< (length trunc) (length file)) trunc file))))
+ (concat prefix file))))
+
+(defun consult--directory-prompt (prompt dir)
+ "Return prompt, paths and default directory.
+
+PROMPT is the prompt prefix. The directory is appended to the
+prompt prefix. For projects only the project name is shown. The
+`default-directory' is not shown. Other directories are
+abbreviated and only the last two path components are shown.
+
+If DIR is a string, it is returned as default directory. If DIR
+is a list of strings, the list is returned as search paths. If
+DIR is nil the `consult-project-function' is tried to retrieve
+the default directory. If no project is found the
+`default-directory' is returned as is. Otherwise the user is
+asked for the directories or files to search via
+`completing-read-multiple'."
+ (let* ((paths nil)
+ (dir
+ (pcase dir
+ ((pred stringp) dir)
+ ((or 'nil '(16)) (or (consult--project-root dir) default-directory))
+ (_
+ (pcase (if (stringp (car-safe dir))
+ dir
+ ;; Preserve this-command across `completing-read-multiple' call,
+ ;; such that `consult-customize' continues to work.
+ (let ((this-command this-command)
+ (def (abbreviate-file-name default-directory))
+ ;; bug#75910: category instead of `minibuffer-completing-file-name'
+ (minibuffer-completing-file-name t)
+ (ignore-case read-file-name-completion-ignore-case))
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (setq-local completion-ignore-case ignore-case)
+ (set-syntax-table minibuffer-local-filename-syntax))
+ (completing-read-multiple "Directories or files: "
+ #'completion-file-name-table
+ nil t def 'consult--path-history def))))
+ ((and `(,p) (guard (file-directory-p p))) p)
+ (ps (setq paths (mapcar (lambda (p)
+ (file-relative-name (expand-file-name p)))
+ ps))
+ default-directory)))))
+ (edir (file-name-as-directory (expand-file-name dir)))
+ (pdir (let ((default-directory edir))
+ ;; Bind default-directory in order to find the project
+ (consult--project-root))))
+ (list
+ (format "%s (%s): " prompt
+ (pcase paths
+ ((guard (<= 1 (length paths) 2))
+ (string-join (mapcar #'consult--left-truncate-file paths) ", "))
+ (`(,p . ,_)
+ (format "%d paths, %s, …" (length paths) (consult--left-truncate-file p)))
+ ((guard (equal edir pdir)) (concat "Project " (consult--project-name pdir)))
+ (_ (consult--left-truncate-file edir))))
+ (or paths '("."))
+ edir)))
+
+(defun consult--default-project-function (may-prompt)
+ "Return project root directory.
+When no project is found and MAY-PROMPT is non-nil ask the user."
+ (declare-function project-root "project")
+ (when-let (proj (project-current may-prompt))
+ (project-root proj)))
+
+(defun consult--project-root (&optional may-prompt)
+ "Return project root as absolute path.
+When no project is found and MAY-PROMPT is non-nil ask the user."
+ ;; Preserve this-command across project selection,
+ ;; such that `consult-customize' continues to work.
+ (let ((this-command this-command))
+ (when-let (root (and consult-project-function
+ (funcall consult-project-function may-prompt)))
+ (expand-file-name root))))
+
+(defun consult--project-known-roots ()
+ "Return list of known project roots."
+ (let ((root (consult--project-root))
+ (dirs (sort (project-known-project-roots) #'string<)))
+ (when root
+ (setq root (abbreviate-file-name root)
+ dirs (cons root (delete root dirs))))
+ dirs))
+
+(defun consult--project-name (dir)
+ "Return the project name for DIR."
+ (if (string-match "/\\([^/]+\\)/\\'" dir)
+ (propertize (match-string 1 dir) 'help-echo (abbreviate-file-name dir))
+ dir))
+
+(defun consult--format-file-line-match (file line match)
+ "Format string FILE:LINE:MATCH with faces."
+ (setq line (number-to-string line)
+ match (concat file ":" line ":" match)
+ file (length file))
+ (put-text-property 0 file 'face 'consult-file match)
+ (put-text-property (1+ file) (+ 1 file (length line)) 'face 'consult-line-number match)
+ match)
+
+(defun consult--make-overlay (beg end &rest props)
+ "Make consult overlay between BEG and END with PROPS."
+ (let ((ov (make-overlay beg end)))
+ (while props
+ (overlay-put ov (car props) (cadr props))
+ (setq props (cddr props)))
+ ov))
+
+(defun consult--remove-dups (list)
+ "Remove duplicate strings from LIST."
+ (delete-dups (copy-sequence list)))
+
+(defsubst consult--in-range-p (pos)
+ "Return t if position POS lies in range `point-min' to `point-max'."
+ (<= (point-min) pos (point-max)))
+
+(defun consult--completion-window-p ()
+ "Return non-nil if the selected window belongs to the completion UI."
+ (or (eq (selected-window) (active-minibuffer-window))
+ (eq #'completion-list-mode (buffer-local-value 'major-mode (window-buffer)))))
+
+(defun consult--original-window ()
+ "Return window which was just selected just before the minibuffer was entered.
+In contrast to `minibuffer-selected-window' never return nil and
+always return an appropriate non-minibuffer window."
+ (or (minibuffer-selected-window)
+ (if (window-minibuffer-p (selected-window))
+ (next-window)
+ (selected-window))))
+
+(defun consult--forbid-minibuffer ()
+ "Raise an error if executed from the minibuffer."
+ (when (minibufferp)
+ (user-error "`%s' called inside the minibuffer" this-command)))
+
+(defun consult--require-minibuffer ()
+ "Raise an error if executed outside the minibuffer."
+ (unless (minibufferp)
+ (user-error "`%s' must be called inside the minibuffer" this-command)))
+
+(defun consult--fontify-all ()
+ "Ensure that the whole buffer is fontified."
+ ;; Font-locking is lazy, i.e., if a line has not been looked at yet, the line
+ ;; is not font-locked. We would observe this if consulting an unfontified
+ ;; line. Therefore we have to enforce font-locking now, which is slow. In
+ ;; order to prevent is hang-up we check the buffer size against
+ ;; `consult-fontify-max-size'.
+ (when (and consult-fontify-preserve jit-lock-mode
+ (< (buffer-size) consult-fontify-max-size))
+ (jit-lock-fontify-now)))
+
+(defun consult--fontify-region (start end)
+ "Ensure that region between START and END is fontified."
+ (when (and consult-fontify-preserve jit-lock-mode)
+ (jit-lock-fontify-now start end)))
+
+(defmacro consult--with-increased-gc (&rest body)
+ "Temporarily increase the GC limit in BODY to optimize for throughput."
+ (cl-with-gensyms (overwrite)
+ `(let* ((,overwrite (> consult--gc-threshold gc-cons-threshold))
+ (gc-cons-threshold (if ,overwrite consult--gc-threshold gc-cons-threshold))
+ (gc-cons-percentage (if ,overwrite consult--gc-percentage gc-cons-percentage)))
+ ,@body)))
+
+(defmacro consult--slow-operation (message &rest body)
+ "Show delayed MESSAGE if BODY takes too long.
+Also temporarily increase the GC limit via `consult--with-increased-gc'."
+ (declare (indent 1))
+ `(with-delayed-message (1 ,message)
+ (consult--with-increased-gc ,@body)))
+
+(defun consult--count-lines (pos)
+ "Move to position POS and return number of lines."
+ (let ((line 1))
+ (while (< (point) pos)
+ (forward-line)
+ (when (<= (point) pos)
+ (cl-incf line)))
+ (goto-char pos)
+ line))
+
+(defun consult--marker-from-line-column (buffer line column)
+ "Get marker in BUFFER from LINE and COLUMN."
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (save-excursion
+ (without-restriction
+ (goto-char (point-min))
+ ;; Location data might be invalid by now!
+ (ignore-errors
+ (forward-line (1- line))
+ (goto-char (min (+ (point) column) (pos-eol))))
+ (point-marker))))))
+
+(defun consult--line-prefix (&optional curr-line)
+ "Annotate `consult-location' candidates with line numbers.
+CURR-LINE is the current line number."
+ (setq curr-line (or curr-line -1))
+ (let* ((width (length (number-to-string (line-number-at-pos
+ (point-max)
+ consult-line-numbers-widen))))
+ (before (format #("%%%dd " 0 6 (face consult-line-number-wrapped)) width))
+ (after (format #("%%%dd " 0 6 (face consult-line-number-prefix)) width)))
+ (lambda (cand)
+ (let ((line (cdr (get-text-property 0 'consult-location cand))))
+ (list cand (format (if (< line curr-line) before after) line) "")))))
+
+(defsubst consult--location-candidate (cand marker line tofu &rest props)
+ "Add MARKER and LINE as `consult-location' text property to CAND.
+Furthermore add the additional text properties PROPS, and append
+TOFU suffix for disambiguation."
+ (setq cand (concat cand (consult--tofu-encode tofu)))
+ (add-text-properties 0 1 `(consult-location (,marker . ,line) ,@props) cand)
+ cand)
+
+;; There is a similar variable `yank-excluded-properties'. Unfortunately
+;; we cannot use it here since it excludes too much (e.g., invisible)
+;; and at the same time not enough (e.g., cursor-sensor-functions).
+(defconst consult--remove-text-properties
+ '( category cursor cursor-intangible cursor-sensor-functions field follow-link
+ fontified front-sticky help-echo insert-behind-hooks insert-in-front-hooks
+ intangible keymap local-map modification-hooks mouse-face pointer read-only
+ rear-nonsticky yank-handler)
+ "List of text properties to remove from buffer strings.")
+
+(defsubst consult--buffer-substring (beg end &optional fontify)
+ "Return buffer substring between BEG and END.
+If FONTIFY and `consult-fontify-preserve' are non-nil, first ensure that the
+region has been fontified."
+ (if consult-fontify-preserve
+ (let (str)
+ (when fontify (consult--fontify-region beg end))
+ (setq str (buffer-substring beg end))
+ ;; TODO Propose the upstream addition of a function
+ ;; `preserve-list-of-text-properties', which should be as efficient as
+ ;; `remove-list-of-text-properties'.
+ (remove-list-of-text-properties
+ 0 (- end beg) consult--remove-text-properties str)
+ str)
+ (buffer-substring-no-properties beg end)))
+
+(defun consult--line-with-mark (marker)
+ "Current line string where the MARKER position is highlighted."
+ (let* ((beg (pos-bol))
+ (end (pos-eol))
+ (str (consult--buffer-substring beg end 'fontify)))
+ (if (>= marker end)
+ (concat str #(" " 0 1 (face consult-highlight-mark)))
+ (put-text-property (- marker beg) (- (1+ marker) beg)
+ 'face 'consult-highlight-mark str)
+ str)))
+
+;;;; Tofu cooks
+
+(defsubst consult--tofu-p (char)
+ "Return non-nil if CHAR is a tofu."
+ (<= consult--tofu-char char (+ consult--tofu-char consult--tofu-range -1)))
+
+(defun consult--tofu-strip (str)
+ "Strip tofus from STR."
+ (replace-regexp-in-string consult--tofu-regexp "" (substring-no-properties str)))
+
+(defsubst consult--tofu-append (cand id)
+ "Append tofu-encoded ID to CAND.
+The ID must fit within a single character. It must be smaller
+than `consult--tofu-range'."
+ (setq id (char-to-string (+ consult--tofu-char id)))
+ (add-text-properties 0 1 '(invisible t consult-strip t) id)
+ (concat cand id))
+
+(defsubst consult--tofu-get (cand)
+ "Extract tofu-encoded ID from CAND.
+See `consult--tofu-append'."
+ (- (aref cand (1- (length cand))) consult--tofu-char))
+
+;; We must disambiguate the lines by adding a prefix such that two lines with
+;; the same text can be distinguished. In order to avoid matching the line
+;; number, such that the user can search for numbers with `consult-line', we
+;; encode the line number as characters outside the Unicode range. By doing
+;; that, no accidental matching can occur.
+(defun consult--tofu-encode (n)
+ "Return tofu-encoded number N as a string.
+Large numbers are encoded as multiple tofu characters."
+ (let (str tofu)
+ (while (progn
+ (setq tofu (char-to-string
+ (+ consult--tofu-char (% n consult--tofu-range)))
+ str (if str (concat tofu str) tofu))
+ (and (>= n consult--tofu-range)
+ (setq n (/ n consult--tofu-range)))))
+ (add-text-properties 0 (length str) '(invisible t consult-strip t) str)
+ str))
+
+;;;; Regexp utilities
+
+(defun consult--find-highlights (str start &rest ignored-faces)
+ "Find highlighted regions in STR from position START.
+Highlighted regions have a non-nil face property.
+IGNORED-FACES are ignored when searching for matches."
+ (let (highlights
+ (end (length str))
+ (beg start))
+ (while (< beg end)
+ (let ((next (next-single-property-change beg 'face str end))
+ (val (get-text-property beg 'face str)))
+ (when (and val
+ (not (memq val ignored-faces))
+ (not (and (consp val)
+ (seq-some (lambda (x) (memq x ignored-faces)) val))))
+ (push (cons (- beg start) (- next start)) highlights))
+ (setq beg next)))
+ (nreverse highlights)))
+
+(defun consult--point-placement (str start &rest ignored-faces)
+ "Compute point placement from STR with START offset.
+IGNORED-FACES are ignored when searching for matches.
+Return cons of point position and a list of match begin/end pairs."
+ (let* ((matches (apply #'consult--find-highlights str start ignored-faces))
+ (pos (pcase-exhaustive consult-point-placement
+ ('match-beginning (or (caar matches) 0))
+ ('match-end (or (cdar (last matches)) 0))
+ ('line-beginning 0))))
+ (dolist (match matches)
+ (cl-decf (car match) pos)
+ (cl-decf (cdr match) pos))
+ (cons pos matches)))
+
+(defun consult--highlight-regexps (regexps ignore-case str)
+ "Highlight REGEXPS in STR.
+If a regular expression contains capturing groups, only these are highlighted.
+If no capturing groups are used highlight the whole match. Case is ignored
+if IGNORE-CASE is non-nil."
+ (dolist (re regexps)
+ (let ((i 0))
+ (while (and (let ((case-fold-search ignore-case))
+ (string-match re str i))
+ ;; Ensure that regexp search made progress (edge case for .*)
+ (> (match-end 0) i))
+ ;; Unfortunately there is no way to avoid the allocation of the match
+ ;; data, since the number of capturing groups is unknown.
+ (let ((m (match-data)))
+ (setq i (cadr m) m (or (cddr m) m))
+ (while m
+ (when (car m)
+ (add-face-text-property (car m) (cadr m)
+ 'consult-highlight-match nil str))
+ (setq m (cddr m)))))))
+ str)
+
+(defconst consult--convert-regexp-table
+ (append
+ ;; For simplicity, treat word beginning/end as word boundaries,
+ ;; since PCRE does not make this distinction. Usually the
+ ;; context determines if \b is the beginning or the end.
+ '(("\\<" . "\\b") ("\\>" . "\\b")
+ ("\\_<" . "\\b") ("\\_>" . "\\b")
+ ("\\s-" . "[ \\n\\t\\r]") ("\\S-" . "[^ \\n\\t\\r]")
+ ("\\sw" . "[a-zA-Z0-9]") ("\\Sw" . "[^a-zA-Z0-0]")
+ ("\\s_" . "[a-zA-Z0-9_-]") ("\\S_" . "[^a-zA-Z0-0_-]"))
+ ;; Treat \` and \' as beginning and end of line. This is more
+ ;; widely supported and makes sense for line-based commands.
+ '(("\\`" . "^") ("\\'" . "$"))
+ ;; Historical: Unescaped *, +, ? are supported at the beginning
+ (mapcan (lambda (x)
+ (mapcar (lambda (y)
+ (cons (concat x y)
+ (concat (string-remove-prefix "\\" x) "\\" y)))
+ '("*" "+" "?")))
+ '("" "\\(" "\\(?:" "\\|" "^"))
+ ;; Different escaping
+ (mapcan (lambda (x) `(,x (,(cdr x) . ,(car x))))
+ '(("\\|" . "|")
+ ("\\(" . "(") ("\\)" . ")")
+ ("\\{" . "{") ("\\}" . "}"))))
+ "Regexp conversion table.")
+
+(defun consult--convert-regexp (regexp type)
+ "Convert Emacs REGEXP to regexp syntax TYPE."
+ (if (memq type '(emacs basic))
+ regexp
+ ;; Support for Emacs regular expressions is fairly complete for basic
+ ;; usage. There are a few unsupported Emacs regexp features:
+ ;; - \= point matching
+ ;; - Most syntax classes \sx \Sx
+ ;; - Character classes \cx \Cx
+ ;; - Explicitly numbered groups (?3:group)
+ (replace-regexp-in-string
+ (rx (or "\\\\" "\\^" ;; Pass through
+ (seq (or "\\(?:" "\\|") (any "*+?")) ;; Historical: \|+ or \(?:* etc
+ (seq "\\(" (any "*+")) ;; Historical: \(* or \(+
+ (seq (or bos "^") (any "*+?")) ;; Historical: + or * at the beginning
+ (seq (opt "\\") (any "(){|}")) ;; Escape parens/braces/pipe
+ (seq "\\" (any "'<>`")) ;; Special escapes
+ (seq "\\" (any "Ss") (any "-w_")) ;; Whitespace, word, symbol syntax class
+ (seq "\\_" (any "<>")))) ;; Beginning or end of symbol
+ (lambda (x) (or (cdr (assoc x consult--convert-regexp-table)) x))
+ regexp 'fixedcase 'literal)))
+
+(defun consult--default-regexp-compiler (input type ignore-case)
+ "Compile a string to a list of regular expressions.
+See `consult--compile-regexp' for INPUT, TYPE and IGNORE-CASE."
+ (setq input (consult--split-escaped input))
+ (cons (mapcar (lambda (x) (consult--convert-regexp x type)) input)
+ (when-let (regexps (seq-filter #'consult--valid-regexp-p input))
+ (apply-partially #'consult--highlight-regexps regexps ignore-case))))
+
+(defun consult--compile-regexp (input type ignore-case)
+ "Compile the INPUT string to a list of regular expressions.
+Return a pair, the list of regular expressions and a highlight function.
+The highlight function takes a single argument, the string to highlight
+given the INPUT. TYPE is the desired type of regular expression, which
+can be `basic', `extended', `emacs' or `pcre'. If IGNORE-CASE is
+non-nil the highlight function matches case insensitively."
+ (funcall consult--regexp-compiler input type ignore-case))
+
+(defun consult--split-escaped (str)
+ "Split STR at spaces, which can be escaped with backslash."
+ (mapcar
+ (lambda (x) (string-replace "\0" " " x))
+ (split-string (replace-regexp-in-string
+ "\\\\\\\\\\|\\\\ "
+ (lambda (x) (if (equal x "\\ ") "\0" x))
+ str 'fixedcase 'literal)
+ " +" t)))
+
+(defun consult--join-regexps (regexps type)
+ "Join REGEXPS of TYPE."
+ ;; Add look-ahead wrapper only if there is more than one regular expression
+ (cond
+ ((and (eq type 'pcre) (cdr regexps))
+ (concat "^" (mapconcat (lambda (x) (format "(?=.*%s)" x))
+ regexps "")))
+ ((eq type 'basic)
+ (string-join regexps ".*"))
+ (t
+ (when (length> regexps 3)
+ (consult--minibuffer-message
+ "Too many regexps, %S ignored. Use post-filtering!"
+ (string-join (seq-drop regexps 3) " "))
+ (setq regexps (seq-take regexps 3)))
+ (consult--join-regexps-permutations regexps (and (eq type 'emacs) "\\")))))
+
+(defun consult--join-regexps-permutations (regexps esc)
+ "Join all permutations of REGEXPS.
+ESC is the escaping string for choice and groups."
+ (pcase regexps
+ ('nil "")
+ (`(,r) r)
+ (_ (mapconcat
+ (lambda (r)
+ (concat esc "(" r esc ").*" esc "("
+ (consult--join-regexps-permutations (remove r regexps) esc)
+ esc ")"))
+ regexps (concat esc "|")))))
+
+(defun consult--valid-regexp-p (re)
+ "Return t if regexp RE is valid."
+ (condition-case nil
+ (progn (string-match-p re "") t)
+ (invalid-regexp nil)))
+
+(defun consult--regexp-filter (regexps)
+ "Create filter regexp from REGEXPS."
+ (if (stringp regexps)
+ regexps
+ (mapconcat (lambda (x) (concat "\\(?:" x "\\)")) regexps "\\|")))
+
+;;;; Lookup functions
+
+(defun consult--lookup-member (selected candidates &rest _)
+ "Lookup SELECTED in CANDIDATES list, return original element."
+ (car (member selected candidates)))
+
+(defun consult--lookup-cons (selected candidates &rest _)
+ "Lookup SELECTED in CANDIDATES alist, return cons."
+ (assoc selected candidates))
+
+(defun consult--lookup-cdr (selected candidates &rest _)
+ "Lookup SELECTED in CANDIDATES alist, return `cdr' of element."
+ (cdr (assoc selected candidates)))
+
+(defun consult--lookup-location (selected candidates &rest _)
+ "Lookup SELECTED in CANDIDATES list of `consult-location' category.
+Return the location marker."
+ (when-let (found (member selected candidates))
+ (setq found (car (consult--get-location (car found))))
+ ;; Check that marker is alive
+ (and (or (not (markerp found)) (marker-buffer found)) found)))
+
+(defun consult--lookup-prop (prop selected candidates &rest _)
+ "Lookup SELECTED in CANDIDATES list and return PROP value."
+ (when-let (found (member selected candidates))
+ (get-text-property 0 prop (car found))))
+
+(defun consult--lookup-candidate (selected candidates &rest _)
+ "Lookup SELECTED in CANDIDATES list and return property `consult--candidate'."
+ (consult--lookup-prop 'consult--candidate selected candidates))
+
+;;;; Preview support
+
+(defun consult--preview-rename-buffer (buf &optional name)
+ "Rename BUF to the preview buffer name convention.
+NAME defaults to `buffer-name'."
+ (with-current-buffer buf
+ (rename-buffer (concat " Preview:" (or name (buffer-name))) 'unique)))
+
+(defun consult--preview-add-buffer (list buf &optional name)
+ "Add BUF to LIST and rename BUF to the preview buffer name convention.
+NAME defaults to `buffer-name'. Kill old buffers if the list length
+exceeds `consult-preview-max-count'."
+ (consult--preview-rename-buffer (cdr buf) name)
+ (push buf list)
+ (while (length> list consult-preview-max-count)
+ (kill-buffer (cdar (last list)))
+ (setq list (nbutlast list)))
+ list)
+
+(defun consult--preview-allowed-p (fun)
+ "Return non-nil if FUN is an allowed preview mode hook."
+ (or (memq fun consult-preview-allowed-hooks)
+ (when-let (((symbolp fun))
+ (name (symbol-name fun))
+ ;; Global modes in Emacs 29 are activated via a
+ ;; `find-file-hook' ending with `-check-buffers'. This has been
+ ;; changed in Emacs 30. Now a `change-major-mode-hook' is used
+ ;; instead with the suffix `-check-buffers'.
+ (suffix (static-if (>= emacs-major-version 30)
+ "-enable-in-buffer"
+ "-check-buffers"))
+ ((string-suffix-p suffix name)))
+ (memq (intern (string-remove-suffix suffix name))
+ consult-preview-allowed-hooks))))
+
+(defun consult--filter-find-file-hook (orig &rest hooks)
+ "Filter `find-file-hook' by `consult-preview-allowed-hooks'.
+This function is an advice for `run-hooks'.
+ORIG is the original function, HOOKS the arguments."
+ (if (memq 'find-file-hook hooks)
+ (cl-letf* (((default-value 'find-file-hook)
+ (seq-filter #'consult--preview-allowed-p
+ (default-value 'find-file-hook)))
+ (find-file-hook (default-value 'find-file-hook)))
+ (apply orig hooks))
+ (apply orig hooks)))
+
+(defun consult--minibuffer-message (&rest msg)
+ "Show MSG in the minibuffer without logging."
+ (with-selected-window (or (active-minibuffer-window) (selected-window))
+ (let (message-log-max minibuffer-message-timeout)
+ (apply #'minibuffer-message msg))))
+
+(defun consult--find-file-temporarily-1 (name)
+ "Open file NAME, helper function for `consult--find-file-temporarily'."
+ ;; file-attributes may throw permission denied error
+ (when-let ((attrs (ignore-errors (file-attributes name)))
+ (size (file-attribute-size attrs)))
+ (let* ((partial (>= size consult-preview-partial-size))
+ (buffer (if partial
+ (generate-new-buffer (format "consult-partial-preview-%s" name))
+ (find-file-noselect name 'nowarn)))
+ (success nil))
+ (unwind-protect
+ (with-current-buffer buffer
+ (if (not partial)
+ (when (or (eq major-mode 'hexl-mode)
+ (and (eq major-mode 'fundamental-mode)
+ (save-excursion (search-forward "\0" nil 'noerror))))
+ (error "No preview of binary file"))
+ (with-silent-modifications
+ (setq buffer-read-only t)
+ (insert-file-contents name nil 0 consult-preview-partial-chunk)
+ (goto-char (point-max))
+ (insert "\nFile truncated. End of partial preview.\n")
+ (goto-char (point-min)))
+ (when (save-excursion (search-forward "\0" nil 'noerror))
+ (error "No partial preview of binary file"))
+ ;; Auto detect major mode and hope for the best, given that the
+ ;; file is only previewed partially. If an error is thrown the
+ ;; buffer will be killed and preview is aborted.
+ (set-auto-mode)
+ (font-lock-mode 1))
+ (when (bound-and-true-p so-long-detected-p)
+ (error "No preview of file with long lines"))
+ ;; Run delayed hooks listed in `consult-preview-allowed-hooks'.
+ (dolist (hook (reverse (cons 'after-change-major-mode-hook delayed-mode-hooks)))
+ (run-hook-wrapped hook (lambda (fun)
+ (when (consult--preview-allowed-p fun)
+ (funcall fun))
+ nil)))
+ (setq success (current-buffer)))
+ (unless success
+ (kill-buffer buffer))))))
+
+(defun consult--find-file-temporarily (name)
+ "Open file NAME temporarily for preview."
+ (let ((vars (delq nil
+ (mapcar
+ (pcase-lambda (`(,k . ,v))
+ (if (boundp k)
+ (list k v (default-value k) (symbol-value k))
+ (message "consult-preview-variables: The variable `%s' is not bound" k)
+ nil))
+ consult-preview-variables))))
+ (condition-case err
+ (unwind-protect
+ (progn
+ (advice-add #'run-hooks :around #'consult--filter-find-file-hook)
+ (pcase-dolist (`(,k ,v . ,_) vars)
+ (set-default k v)
+ (set k v))
+ (consult--find-file-temporarily-1 name))
+ (advice-remove #'run-hooks #'consult--filter-find-file-hook)
+ (pcase-dolist (`(,k ,_ ,d ,v) vars)
+ (set-default k d)
+ (set k v)))
+ (error
+ (consult--minibuffer-message "%s" (error-message-string err))
+ nil))))
+
+(defun consult--temporary-files ()
+ "Return a function to open files temporarily for preview."
+ (let ((dir default-directory)
+ (hook (make-symbol "consult--temporary-files-upgrade-hook"))
+ (orig-buffers (buffer-list))
+ temporary-buffers)
+ (fset hook
+ (lambda (_)
+ ;; Fully initialize previewed files and keep them alive.
+ (unless (consult--completion-window-p)
+ (let (live-files)
+ (pcase-dolist (`(,file . ,buf) temporary-buffers)
+ (when-let (wins (and (buffer-live-p buf)
+ (get-buffer-window-list buf)))
+ (push (cons file (mapcar
+ (lambda (win)
+ (cons win (window-state-get win t)))
+ wins))
+ live-files)))
+ (pcase-dolist (`(,_ . ,buf) temporary-buffers)
+ (kill-buffer buf))
+ (setq temporary-buffers nil)
+ (pcase-dolist (`(,file . ,wins) live-files)
+ (when-let (buf (consult--file-action file))
+ (push buf orig-buffers)
+ (pcase-dolist (`(,win . ,state) wins)
+ (setf (car (alist-get 'buffer state)) buf)
+ (window-state-put state win))))))))
+ (lambda (&optional name)
+ (if name
+ (let ((default-directory dir))
+ (setq name (let (file-name-handler-alist)
+ (abbreviate-file-name (expand-file-name name))))
+ (or
+ ;; Find existing fully initialized buffer (non-previewed). We have
+ ;; to check for fully initialized buffer before accessing the
+ ;; previewed buffers, since `embark-act' can open a buffer which is
+ ;; currently previewed, such that we end up with two buffers for
+ ;; the same file - one previewed and only partially initialized and
+ ;; one fully initialized. In this case we prefer the fully
+ ;; initialized buffer. For directories `get-file-buffer' returns nil,
+ ;; therefore we have to special case Dired.
+ (let (file-name-handler-alist)
+ (if (and (fboundp 'dired-find-buffer-nocreate) (file-directory-p name))
+ (dired-find-buffer-nocreate name)
+ (get-file-buffer name)))
+ ;; Find existing previewed buffer. Previewed buffers are not fully
+ ;; initialized (hooks are delayed) in order to ensure fast preview.
+ (cdr (assoc name temporary-buffers))
+ ;; If no existing buffer has been found, open the file for preview.
+ (when-let (((not (seq-find (lambda (x) (string-match-p x name))
+ consult-preview-excluded-files)))
+ (buf (consult--find-file-temporarily name)))
+ ;; Only add new buffer if not already in the list
+ (unless (or (rassq buf temporary-buffers) (memq buf orig-buffers))
+ (add-hook 'window-selection-change-functions hook)
+ (cl-callf consult--preview-add-buffer temporary-buffers
+ (cons name buf) (file-name-nondirectory (directory-file-name name)))
+ ;; Disassociate buffer from file by setting `buffer-file-name'
+ ;; and `dired-directory' to nil. This lets us open an already
+ ;; previewed buffer with the Embark default action C-. RET.
+ ;; The buffer disassociation is delayed to avoid breaking modes
+ ;; like `pdf-view-mode' or `doc-view-mode' which rely on
+ ;; `buffer-file-name'. Executing (set-visited-file-name nil)
+ ;; early also prevents the major mode initialization.
+ (let ((hook (make-symbol "consult--temporary-files-disassociate-hook")))
+ (fset hook (lambda ()
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (remove-hook 'pre-command-hook hook)
+ (setq-local buffer-read-only t
+ dired-directory nil
+ buffer-file-name nil)))))
+ (add-hook 'pre-command-hook hook)))
+ buf)))
+ (remove-hook 'window-selection-change-functions hook)
+ (pcase-dolist (`(,_ . ,buf) temporary-buffers)
+ (kill-buffer buf))
+ (setq temporary-buffers nil)))))
+
+(defun consult--invisible-open-permanently ()
+ "Open overlays which hide the current line.
+See `isearch-open-necessary-overlays' and `isearch-open-overlay-temporary'."
+ (dolist (ov (overlays-in (pos-bol) (pos-eol)))
+ (when-let (fun (overlay-get ov 'isearch-open-invisible))
+ (when (invisible-p (overlay-get ov 'invisible))
+ (funcall fun ov)))))
+
+(defun consult--invisible-open-temporarily ()
+ "Temporarily open overlays which hide the current line.
+See `isearch-open-necessary-overlays' and `isearch-open-overlay-temporary'."
+ (let (restore)
+ (dolist (ov (overlays-in (pos-bol) (pos-eol)))
+ (let ((inv (overlay-get ov 'invisible)))
+ (when (and (invisible-p inv) (overlay-get ov 'isearch-open-invisible))
+ (push (if-let (fun (overlay-get ov 'isearch-open-invisible-temporary))
+ (progn
+ (funcall fun ov nil)
+ (lambda () (funcall fun ov t)))
+ (overlay-put ov 'invisible nil)
+ (lambda () (overlay-put ov 'invisible inv)))
+ restore))))
+ restore))
+
+(defun consult--jump-ensure-buffer (pos)
+ "Ensure that buffer of marker POS is displayed, return t if successful."
+ (or (not (markerp pos))
+ ;; Switch to buffer if it is not visible
+ (when-let ((buf (marker-buffer pos)))
+ (or (and (eq (current-buffer) buf) (eq (window-buffer) buf))
+ (consult--buffer-action buf 'norecord)
+ t))))
+
+(defun consult--jump (pos)
+ "Jump to POS.
+First push current position to mark ring, then move to new
+position and run `consult-after-jump-hook'."
+ (when pos
+ ;; Extract marker from list with with overlay positions, see `consult--line-match'
+ (when (consp pos) (setq pos (car pos)))
+ ;; When the marker is in the same buffer, record previous location
+ ;; such that the user can jump back quickly.
+ (when (or (not (markerp pos)) (eq (current-buffer) (marker-buffer pos)))
+ ;; push-mark mutates markers in the mark-ring and the mark-marker.
+ ;; Therefore we transform the marker to a number to be safe.
+ ;; We all love side effects!
+ (setq pos (+ pos 0))
+ (push-mark (point) t))
+ (when (consult--jump-ensure-buffer pos)
+ (unless (= (goto-char pos) (point)) ;; Widen if jump failed
+ (widen)
+ (goto-char pos))
+ (consult--invisible-open-permanently)
+ (run-hooks 'consult-after-jump-hook)))
+ nil)
+
+(defun consult--jump-preview ()
+ "The preview function used if selecting from a list of candidate positions.
+The function can be used as the `:state' argument of `consult--read'."
+ (let (restore)
+ (lambda (action cand)
+ (when (eq action 'preview)
+ (mapc #'funcall restore)
+ (setq restore nil)
+ ;; TODO Better buffer preview support
+ ;; 1. Use consult--buffer-preview instead of consult--jump-ensure-buffer
+ ;; 2. Remove function consult--jump-ensure-buffer
+ ;; 3. Remove consult-buffer-other-* from consult-customize-alist
+ (when-let ((pos (or (car-safe cand) cand)) ;; Candidate can be previewed
+ ((consult--jump-ensure-buffer pos)))
+ (let ((saved-min (point-min-marker))
+ (saved-max (point-max-marker))
+ (saved-pos (point-marker)))
+ (set-marker-insertion-type saved-max t) ;; Grow when text is inserted
+ (push (lambda ()
+ (when-let ((buf (marker-buffer saved-pos)))
+ (with-current-buffer buf
+ (narrow-to-region saved-min saved-max)
+ (goto-char saved-pos)
+ (set-marker saved-pos nil)
+ (set-marker saved-min nil)
+ (set-marker saved-max nil))))
+ restore))
+ (unless (= (goto-char pos) (point)) ;; Widen if jump failed
+ (widen)
+ (goto-char pos))
+ (setq restore (nconc (consult--invisible-open-temporarily) restore))
+ ;; Ensure that cursor is properly previewed (gh:minad/consult#764)
+ (unless (eq cursor-in-non-selected-windows 'box)
+ (let ((orig cursor-in-non-selected-windows)
+ (buf (current-buffer)))
+ (push
+ (if (local-variable-p 'cursor-in-non-selected-windows)
+ (lambda ()
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (setq-local cursor-in-non-selected-windows orig))))
+ (lambda ()
+ (when (buffer-live-p buf)
+ (with-current-buffer buf
+ (kill-local-variable 'cursor-in-non-selected-windows)))))
+ restore)
+ (setq-local cursor-in-non-selected-windows 'box)))
+ ;; Match previews
+ (let ((overlays
+ (list (save-excursion
+ (let ((vbeg (progn (beginning-of-visual-line) (point)))
+ (vend (progn (end-of-visual-line) (point)))
+ (end (pos-eol)))
+ (consult--make-overlay vbeg (if (= vend end) (1+ end) vend)
+ 'category 'consult-preview-line-overlay
+ 'window (selected-window)))))))
+ (dolist (match (cdr-safe cand))
+ (push (consult--make-overlay (+ (point) (car match))
+ (+ (point) (cdr match))
+ 'category 'consult-preview-match-overlay
+ 'window (selected-window))
+ overlays))
+ (push (lambda () (mapc #'delete-overlay overlays)) restore))
+ (run-hooks 'consult-after-jump-hook))))))
+
+(put 'consult-preview-line-overlay 'face 'consult-preview-line)
+(put 'consult-preview-line-overlay 'priority 1)
+(put 'consult-preview-match-overlay 'face 'consult-preview-match)
+(put 'consult-preview-match-overlay 'priority 2)
+
+(defun consult--jump-state ()
+ "The state function used if selecting from a list of candidate positions."
+ (consult--state-with-return (consult--jump-preview) #'consult--jump))
+
+(defun consult--get-location (cand)
+ "Return location from CAND."
+ (let ((loc (get-text-property 0 'consult-location cand)))
+ (when (consp (car loc))
+ ;; Transform cheap marker to real marker
+ (setcar loc (set-marker (make-marker) (cdar loc) (caar loc))))
+ loc))
+
+(defun consult--location-state (candidates)
+ "Location state function.
+The cheap location markers from CANDIDATES are upgraded on window
+selection change to full Emacs markers."
+ (let ((jump (consult--jump-state))
+ (hook (make-symbol "consult--location-upgrade-hook")))
+ (fset hook
+ (lambda (_)
+ (unless (consult--completion-window-p)
+ (remove-hook 'window-selection-change-functions hook)
+ (mapc #'consult--get-location
+ (if (functionp candidates) (funcall candidates) candidates)))))
+ (lambda (action cand)
+ (pcase action
+ ('setup (add-hook 'window-selection-change-functions hook))
+ ('exit (remove-hook 'window-selection-change-functions hook)))
+ (funcall jump action cand))))
+
+(defun consult--state-with-return (state return)
+ "Compose STATE function with RETURN function."
+ (lambda (action cand)
+ (funcall state action cand)
+ (when (and cand (eq action 'return))
+ (funcall return cand))))
+
+(defmacro consult--define-state (type)
+ "Define state function for TYPE."
+ `(defun ,(intern (format "consult--%s-state" type)) ()
+ ,(format "State function for %ss with preview.
+The result can be passed as :state argument to `consult--read'." type)
+ (consult--state-with-return (,(intern (format "consult--%s-preview" type)))
+ #',(intern (format "consult--%s-action" type)))))
+
+(defun consult--preview-key-normalize (preview-key)
+ "Normalize PREVIEW-KEY, return alist of keys and debounce times."
+ (let ((keys)
+ (debounce 0))
+ (setq preview-key (ensure-list preview-key))
+ (while preview-key
+ (if (eq (car preview-key) :debounce)
+ (setq debounce (cadr preview-key)
+ preview-key (cddr preview-key))
+ (let ((key (car preview-key)))
+ (unless (eq key 'any)
+ (setq key (consult--key-parse key)))
+ (push (cons key debounce) keys))
+ (pop preview-key)))
+ keys))
+
+(defun consult--preview-key-debounce (preview-key cand)
+ "Return debounce value of PREVIEW-KEY given the current candidate CAND."
+ (when (and (consp preview-key) (memq :keys preview-key))
+ (setq preview-key (funcall (plist-get preview-key :predicate) cand)))
+ (let ((map (make-sparse-keymap))
+ (keys (this-single-command-keys))
+ any)
+ (pcase-dolist (`(,k . ,d) (consult--preview-key-normalize preview-key))
+ (if (eq k 'any)
+ (setq any d)
+ (define-key map k `(lambda () ,d))))
+ (setq keys (lookup-key map keys))
+ (if (functionp keys) (funcall keys) any)))
+
+(defun consult--preview-append-local-pch (fun)
+ "Append FUN to local `post-command-hook' list."
+ ;; Symbol indirection because of bug#46407.
+ (let ((hook (make-symbol "consult--preview-post-command-hook")))
+ (fset hook fun)
+ ;; TODO Emacs 28 has a bug, where the hook--depth-alist is not cleaned up properly
+ ;; Do not use the broken add-hook here.
+ ;;(add-hook 'post-command-hook hook 'append 'local)
+ (setq-local post-command-hook
+ (append
+ (remove t post-command-hook)
+ (list hook)
+ (and (memq t post-command-hook) '(t))))))
+
+(defun consult--with-preview-1 (preview-key state transform candidate save-input fun)
+ "Add preview support for FUN.
+See `consult--with-preview' for the arguments
+PREVIEW-KEY, STATE, TRANSFORM, CANDIDATE and SAVE-INPUT."
+ (let ((mb-input "") (timer (timer-create)) mb-narrow selected previewed)
+ (minibuffer-with-setup-hook
+ (if (and state preview-key)
+ (lambda ()
+ (let ((hook (make-symbol "consult--preview-minibuffer-exit-hook"))
+ (depth (recursion-depth)))
+ (fset hook
+ (lambda ()
+ (when (= (recursion-depth) depth)
+ (remove-hook 'minibuffer-exit-hook hook)
+ (cancel-timer timer)
+ (with-selected-window (consult--original-window)
+ ;; STEP 3: Reset preview
+ (when previewed
+ (funcall state 'preview nil))
+ ;; STEP 4: Notify the preview function of the minibuffer exit
+ (funcall state 'exit nil)))))
+ (add-hook 'minibuffer-exit-hook hook))
+ ;; STEP 1: Setup the preview function
+ (with-selected-window (consult--original-window)
+ (funcall state 'setup nil))
+ (setq consult--preview-function
+ (lambda ()
+ (when-let ((cand (funcall candidate)))
+ ;; Drop properties to prevent bugs regarding candidate
+ ;; lookup, which must handle candidates without
+ ;; properties. Otherwise the arguments passed to the
+ ;; lookup function are confusing, since during preview
+ ;; the candidate has properties but for the final lookup
+ ;; after completion it does not.
+ (setq cand (substring-no-properties cand))
+ (with-selected-window (active-minibuffer-window)
+ (let ((input (minibuffer-contents-no-properties))
+ (narrow consult--narrow)
+ (win (consult--original-window)))
+ (with-selected-window win
+ (when-let ((transformed (funcall transform narrow input cand))
+ (debounce (consult--preview-key-debounce preview-key transformed)))
+ (cancel-timer timer)
+ ;; The transformed candidate may have text
+ ;; properties, which change the preview display.
+ ;; This matters for example for `consult-grep',
+ ;; where the current candidate and input may
+ ;; stay equal, but the highlighting of the
+ ;; candidate changes while the candidates list
+ ;; is lagging a bit behind and updates
+ ;; asynchronously.
+ ;;
+ ;; In older Consult versions we instead compared
+ ;; the input without properties, since I worried
+ ;; that comparing the transformed candidates
+ ;; could be potentially expensive. However
+ ;; comparing the transformed candidates is more
+ ;; correct. The transformed candidate is the
+ ;; thing which is actually previewed.
+ (unless (equal-including-properties previewed transformed)
+ (if (> debounce 0)
+ (progn
+ (timer-set-function
+ timer
+ (lambda ()
+ ;; Preview only when a completion
+ ;; window is selected and when
+ ;; the preview window is alive.
+ (when (and (consult--completion-window-p)
+ (window-live-p win))
+ (with-selected-window win
+ ;; STEP 2: Preview candidate
+ (funcall state 'preview (setq previewed transformed))))))
+ (timer-set-time timer (timer-relative-time nil debounce))
+ (timer-activate timer))
+ ;; STEP 2: Preview candidate
+ (funcall state 'preview (setq previewed transformed)))))))))))
+ (consult--preview-append-local-pch
+ (lambda ()
+ (setq mb-input (minibuffer-contents-no-properties)
+ mb-narrow consult--narrow)
+ (funcall consult--preview-function))))
+ (lambda ()
+ (consult--preview-append-local-pch
+ (lambda ()
+ (setq mb-input (minibuffer-contents-no-properties)
+ mb-narrow consult--narrow)))))
+ (unwind-protect
+ (setq selected (when-let (result (funcall fun))
+ (when-let ((save-input)
+ (list (symbol-value save-input))
+ ((equal (car list) result)))
+ (set save-input (cdr list)))
+ (funcall transform mb-narrow mb-input result)))
+ (when save-input
+ (add-to-history save-input mb-input))
+ (when state
+ ;; STEP 5: The preview function should perform its final action
+ (funcall state 'return selected))))))
+
+(defmacro consult--with-preview (preview-key state transform candidate save-input &rest body)
+ "Add preview support to BODY.
+
+STATE is the state function.
+TRANSFORM is the transformation function.
+CANDIDATE is the function returning the current candidate.
+PREVIEW-KEY are the keys which triggers the preview.
+SAVE-INPUT can be a history variable symbol to save the input.
+
+The state function takes two arguments, an action argument and the
+selected candidate. The candidate argument can be nil if no candidate is
+selected or if the selection was aborted. The function is called in
+sequence with the following arguments:
+
+ 1. \\='setup nil After entering the mb (minibuffer-setup-hook).
+⎧ 2. \\='preview CAND/nil Preview candidate CAND or reset if CAND is nil.
+⎪ \\='preview CAND/nil
+⎪ \\='preview CAND/nil
+⎪ ...
+⎩ 3. \\='preview nil Reset preview.
+ 4. \\='exit nil Before exiting the mb (minibuffer-exit-hook).
+ 5. \\='return CAND/nil After leaving the mb, CAND has been selected.
+
+The state function is always executed with the original window selected,
+see `consult--original-window'. The state function is called once in
+the beginning of the minibuffer setup with the `setup' argument. This is
+useful in order to perform certain setup operations which require that
+the minibuffer is initialized. During completion candidates are
+previewed. Then the function is called with the `preview' argument and a
+candidate CAND or nil if no candidate is selected. Furthermore if nil is
+passed for CAND, then the preview must be undone and the original state
+must be restored. The call with the `exit' argument happens once at the
+end of the completion process, just before exiting the minibuffer. The
+minibuffer is still alive at that point. Both `setup' and `exit' are
+only useful for setup and cleanup operations. They don't receive a
+candidate as argument. After leaving the minibuffer, the selected
+candidate or nil is passed to the state function with the action
+argument `return'. At this point the state function can perform the
+actual action on the candidate. The state function with the `return'
+argument is the continuation of `consult--read'. Via `unwind-protect' it
+is guaranteed, that if the `setup' action of a state function is
+invoked, the state function will also be called with `exit' and
+`return'."
+ (declare (indent 5))
+ `(consult--with-preview-1 ,preview-key ,state ,transform ,candidate ,save-input (lambda () ,@body)))
+
+;;;; Narrowing and grouping
+
+(defun consult--prefix-group (cand transform)
+ "Return title for CAND or TRANSFORM the candidate.
+The candidate must have a `consult--prefix-group' property."
+ (if transform
+ (substring cand (1+ (length (get-text-property 0 'consult--prefix-group cand))))
+ (get-text-property 0 'consult--prefix-group cand)))
+
+(defun consult--type-group (types)
+ "Return group function for TYPES."
+ (lambda (cand transform)
+ (if transform cand
+ (alist-get (get-text-property 0 'consult--type cand) types))))
+
+(defun consult--type-narrow (types)
+ "Return narrowing configuration from TYPES."
+ (list :predicate
+ (lambda (cand) (eq (get-text-property 0 'consult--type cand) consult--narrow))
+ :keys types))
+
+(defun consult--widen-key ()
+ "Return widening key, if `consult-widen-key' is not set.
+The default is twice the `consult-narrow-key'."
+ (cond
+ (consult-widen-key
+ (consult--key-parse consult-widen-key))
+ (consult-narrow-key
+ (let ((key (consult--key-parse consult-narrow-key)))
+ (vconcat key key)))))
+
+(defun consult-narrow (key)
+ "Narrow current completion with KEY.
+
+This command is used internally by the narrowing system of `consult--read'."
+ (declare (completion ignore))
+ (interactive
+ (list (unless (equal (this-single-command-keys) (consult--widen-key))
+ last-command-event)))
+ (consult--require-minibuffer)
+ (setq consult--narrow key)
+ (when-let ((pred (plist-get consult--narrow-config :predicate)))
+ (setq minibuffer-completion-predicate (and consult--narrow pred)))
+ (when consult--narrow-overlay
+ (delete-overlay consult--narrow-overlay))
+ (when consult--narrow
+ (setq consult--narrow-overlay
+ (consult--make-overlay
+ (1- (minibuffer-prompt-end)) (minibuffer-prompt-end)
+ 'before-string
+ (format #(" [%s]" 0 5 (face consult-narrow-indicator))
+ (alist-get consult--narrow
+ (plist-get consult--narrow-config :keys))))))
+ (run-hooks 'consult--completion-refresh-hook))
+
+(defconst consult--narrow-delete
+ `(menu-item
+ "" nil :filter
+ ,(lambda (&optional _)
+ (when (equal (minibuffer-contents-no-properties) "")
+ (lambda ()
+ (interactive)
+ (consult-narrow nil))))))
+
+(defconst consult--narrow-space
+ `(menu-item
+ "" nil :filter
+ ,(lambda (&optional _)
+ (let ((str (minibuffer-contents-no-properties)))
+ (when-let ((keys (plist-get consult--narrow-config :keys))
+ (pair (or (and (length= str 1) (assoc (aref str 0) keys))
+ (and (equal str "") (assoc ?\s keys)))))
+ (lambda ()
+ (interactive)
+ (delete-minibuffer-contents)
+ (consult-narrow (car pair))))))))
+
+(defun consult-narrow-help ()
+ "Print narrowing help as a `minibuffer-message'.
+
+This command can be bound to a key in `consult-narrow-map',
+to make it available for commands with narrowing."
+ (declare (completion ignore))
+ (interactive)
+ (consult--require-minibuffer)
+ (consult--minibuffer-message
+ (mapconcat (lambda (x)
+ (concat
+ (propertize (key-description (list (car x))) 'face 'consult-key)
+ " "
+ (propertize (cdr x) 'face 'consult-help)))
+ (plist-get consult--narrow-config :keys)
+ " ")))
+
+(defun consult--narrow-setup (config map)
+ "Setup narrowing with CONFIG and keymap MAP."
+ (setq consult--narrow-config (if (memq :keys config)
+ config (list :keys config)))
+ (when-let ((key consult-narrow-key))
+ (setq key (consult--key-parse key))
+ (dolist (pair (plist-get consult--narrow-config :keys))
+ (define-key map (vconcat key (vector (car pair)))
+ (cons (cdr pair) #'consult-narrow))))
+ (when-let ((widen (consult--widen-key)))
+ (define-key map widen (cons "All" #'consult-narrow))))
+
+;;;; Splitting completion style
+
+(defun consult--split-perl (str &optional _plist)
+ "Split input STR in async input and filtering part.
+
+The function returns a list with three elements: The async
+string, the start position of the completion filter string and a
+force flag. If the first character is a punctuation character it
+determines the separator. Examples: \"/async/filter\",
+\"#async#filter\"."
+ (if (string-match-p "^[[:punct:]]" str)
+ (save-match-data
+ (let ((q (regexp-quote (substring str 0 1))))
+ (string-match (concat "^" q "\\([^" q "]*\\)\\(" q "\\)?") str)
+ ;; Force update it two punctuation characters are entered.
+ `(,(propertize (match-string 1 str) 'consult--force (match-end 2))
+ ,(match-end 0)
+ ;; List of highlights
+ (0 . ,(match-beginning 1))
+ ,@(and (match-end 2) `((,(match-beginning 2) . ,(match-end 2)))))))
+ `(,str ,(length str))))
+
+(defun consult--split-none (str &optional _plist)
+ "Treat the complete input STR as async input."
+ `(,str ,(length str)))
+
+(defun consult--split-separator (str plist)
+ "Split input STR in async input and filtering part at first separator.
+PLIST is the splitter configuration, including the separator."
+ (let ((sep (regexp-quote (char-to-string (plist-get plist :separator)))))
+ (save-match-data
+ (if (string-match (format "^\\([^%s]+\\)\\(%s\\)?" sep sep) str)
+ ;; Force update if separator is entered.
+ `(,(propertize (match-string 1 str) 'consult--force (match-end 2))
+ ,(match-end 0)
+ ;; List of highlights
+ ,@(and (match-end 2) `((,(match-beginning 2) . ,(match-end 2)))))
+ `(,str ,(length str))))))
+
+(defun consult--split-setup (split)
+ "Setup splitting completion style with splitter function SPLIT."
+ (when (equal completion-styles '(consult--split))
+ (error "`consult--async-split-input' initialized twice"))
+ (let* ((styles completion-styles)
+ (catdef completion-category-defaults)
+ (catovr completion-category-overrides)
+ (try (lambda (str table pred point)
+ (let ((completion-styles styles)
+ (completion-category-defaults catdef)
+ (completion-category-overrides catovr)
+ (pos (cadr (funcall split str))))
+ (pcase (completion-try-completion (substring str pos) table pred
+ (max 0 (- point pos)))
+ ('t t)
+ (`(,newstr . ,newpt)
+ (setq newstr (concat (substring str 0 pos) newstr))
+ (if (eq (cadr (funcall split newstr)) pos)
+ (cons newstr (+ pos newpt))
+ (cons str point)))))))
+ (all (lambda (str table pred point)
+ (let ((completion-styles styles)
+ (completion-category-defaults catdef)
+ (completion-category-overrides catovr)
+ (pos (cadr (funcall split str))))
+ (completion-all-completions (substring str pos) table pred
+ (max 0 (- point pos)))))))
+ (setq-local completion-styles-alist (cons `(consult--split ,try ,all "")
+ completion-styles-alist)
+ completion-styles '(consult--split)
+ completion-category-defaults nil
+ completion-category-overrides nil)))
+
+;;;; Asynchronous pipeline
+
+(defun consult--async-pipeline (&rest async)
+ "Compose ASYNC pipeline.
+
+An async function must accept a single SINK argument and return a
+function accepting a single ACTION argument. In functional programming
+terminology, an async function is curried.
+
+ (lambda (sink)
+ (lambda (action)
+ ...))
+
+Async functions are composed with `consult--async-pipeline' as in the
+following example. The data flows downwards starting with the input
+from the user.
+
+ (consult--async-pipeline
+ (consult--async-min-input)
+ (consult--async-throttle)
+ (consult--async-process #\\='consult--man-builder)
+ (consult--async-transform #\\='consult--man-format)
+ (consult--async-highlight #\\='consult--man-builder))
+
+Nil functions are ignored to ease building conditional pipelines.
+
+ (consult--async-pipeline
+ (consult--async-min-input min-input)
+ (consult--async-throttle throttle debounce)
+ (consult--async-dynamic fun)
+ transform
+ (and highlight (consult--async-highlight highlight)))
+
+Async functions or pipelines can be passed as completion function to
+`consult--read' or used as `:async' field of `consult--multi' sources as
+shown in these examples:
+
+ (consult--read (consult--async-pipeline ...))
+ (consult--read (consult--dynamic-collection (lambda (input) ...)))
+ (consult--read (consult--process-collection #\\='consult--man-builder))
+
+ (defvar async-source
+ (list :async (consult--async-pipeline ...)))
+ (defvar dynamic-source
+ (list :async (consult--dynamic-collection (lambda (input) ...))))
+ (defvar command-source
+ (list :async (consult--process-collection #\\='consult--man-builder)))
+
+Incoming candidates and the action argument should be passed to the
+sink. The action can take the following forms:
+
+\\='setup Setup the internal closure state. Return nil.
+\\='destroy Destroy the internal closure state. Return nil.
+\\='flush Flush the list of candidates. Return nil.
+\\='refresh Request UI refresh. Return nil.
+\\='cancel Cancel any running process. Return nil.
+nil Return the list of candidates.
+list Append to the existing candidates list and return the whole list.
+string Update with the current user input string. Return nil.
+
+For the \\='setup action it is guaranteed that the call originates from
+the minibuffer. For the other actions no assumption about the context
+can be made."
+ (lambda (sink)
+ (seq-reduce (lambda (s f) (funcall f s)) (delq nil (reverse async)) sink)))
+
+(defun consult--async-wrap (async)
+ "Wrap ASYNC function with the default pipeline.
+The default pipeline provides `consult--async-split',
+`consult--async-indicator' and `consult--async-refresh'."
+ (consult--async-pipeline
+ (consult--async-split)
+ async
+ (consult--async-indicator)
+ (consult--async-refresh)))
+
+(defun consult--async-p (fun)
+ "Return t if FUN is an asynchronous function."
+ (and (functionp fun) (equal (func-arity fun) '(1 . 1))))
+
+(defmacro consult--with-async (async &rest body)
+ "Setup asynchronous completion in BODY.
+ASYNC is the asynchronous function or completion table."
+ (declare (indent 1))
+ `(let (new-chunk orig-chunk)
+ (minibuffer-with-setup-hook
+ ;; Append such that we overwrite the completion style setting of
+ ;; `fido-mode'. See `consult--async-split' and `consult--split-setup'.
+ (:append
+ (lambda ()
+ (when (consult--async-p ,async)
+ (setq new-chunk (max read-process-output-max consult--process-chunk)
+ orig-chunk read-process-output-max
+ read-process-output-max new-chunk)
+ (funcall ,async 'setup)
+ (let* ((mb (current-buffer))
+ (fun (lambda ()
+ (when-let (win (active-minibuffer-window))
+ (when (eq (window-buffer win) mb)
+ (with-current-buffer mb
+ (let ((inhibit-modification-hooks t))
+ ;; Push input string to request refresh.
+ (funcall ,async (minibuffer-contents-no-properties))))))))
+ ;; We use a symbol in order to avoid adding lambdas to
+ ;; the hook variable. Symbol indirection because of
+ ;; bug#46407.
+ (hook (make-symbol "consult--async-after-change-hook"))
+ (timer (timer-create)))
+ (timer-set-function timer fun)
+ ;; Delay modification hook to ensure that minibuffer is still
+ ;; alive after the change, such that we don't restart a new
+ ;; asynchronous search right before exiting the minibuffer.
+ (fset hook (lambda (&rest _)
+ (unless (memq timer timer-list)
+ (timer-set-time timer (current-time))
+ (timer-activate timer))))
+ (add-hook 'after-change-functions hook nil 'local)
+ ;; Immediately start asynchronous computation. This may lead
+ ;; to problems unnecessary work if content is inserted shortly
+ ;; afterwards.
+ (funcall fun)))))
+ (let ((,async (if (consult--async-p ,async) ,async (lambda (_) ,async))))
+ (unwind-protect
+ ,(macroexp-progn body)
+ (funcall ,async 'destroy)
+ (when (and orig-chunk (eq read-process-output-max new-chunk))
+ (setq read-process-output-max orig-chunk)))))))
+
+(defun consult--async-sink ()
+ "Asynchronous sink function."
+ (let (candidates last buffer)
+ (lambda (action)
+ (pcase-exhaustive action
+ ('setup
+ (setq buffer (current-buffer))
+ nil)
+ ((or (pred stringp) 'destroy 'cancel) nil)
+ ('flush (setq candidates nil last nil))
+ ('refresh
+ ;; Refresh the UI when the current minibuffer window belongs
+ ;; to the current asynchronous completion session.
+ (when-let (win (active-minibuffer-window))
+ (when (eq (window-buffer win) buffer)
+ (with-selected-window win
+ (run-hooks 'consult--completion-refresh-hook)
+ ;; Interaction between asynchronous completion functions and
+ ;; preview: We have to trigger preview immediately when
+ ;; candidates arrive (gh:minad/consult#436).
+ (when (and consult--preview-function candidates)
+ (funcall consult--preview-function)))))
+ nil)
+ ('nil candidates)
+ ((pred consp)
+ ;; Lazily initialize last link, such that it is only initialized when
+ ;; appending, and not for one-shot async functions like
+ ;; `consult--async-static'.
+ (if (not candidates)
+ (setq candidates action)
+ (setq last (last (setcdr (or last (last candidates)) action)))
+ candidates))))))
+
+(defun consult--async-dynamic (fun &optional restart)
+ "Dynamic computation of candidates.
+FUN computes the candidates. It takes either a single input argument or
+an input argument and a callback function, if computed candidates should
+be updated incrementally. The callback function must not be called
+after FUN has returned.
+RESTART is the time after which an interrupted computation should be
+restarted and defaults to `consult-async-input-debounce'."
+ (setq restart (or restart consult-async-input-debounce))
+ (when (equal (func-arity fun) '(1 . 1))
+ (let ((orig fun))
+ (setq fun (lambda (input callback)
+ (funcall callback (funcall orig input))))))
+ (lambda (sink)
+ (let ((timer (timer-create)) (current nil) (compute nil))
+ (setq compute
+ (lambda (input)
+ (cancel-timer timer)
+ (funcall sink [indicator running])
+ (redisplay)
+ (let* ((state 'init)
+ (killed
+ (while-no-input
+ (funcall
+ fun input
+ (lambda (response)
+ (when (eq state 'done)
+ (error "consult--async-dynamic: Callback called too late"))
+ (let (throw-on-input)
+ (when (eq state 'init)
+ (funcall sink 'flush)
+ (setq state 'running))
+ (when response
+ (funcall sink response)
+ ;; Accept process input such that timers
+ ;; trigger and refresh the completion UI.
+ (accept-process-output)))))
+ (setq current input
+ state 'done)
+ nil)))
+ (funcall sink `[indicator ,(if killed 'killed 'finished)])
+ (funcall sink 'refresh)
+ ;; If the computation was killed, restart it after a while.
+ ;; This happens when the point is moved. Then the input does
+ ;; not change and the computation is not restarted otherwise.
+ (when (and killed (not (memq timer timer-list)))
+ (timer-set-function timer compute (list input))
+ (timer-set-time timer (timer-relative-time nil restart))
+ (timer-activate timer)))))
+ (lambda (action)
+ (prog1 (funcall sink action)
+ (pcase action
+ ((or 'cancel 'destroy) (cancel-timer timer))
+ ((pred stringp)
+ (if (not (equal action current))
+ (funcall compute action)
+ (cancel-timer timer)
+ (funcall sink [indicator finished])))))))))
+
+(defun consult--async-static (items)
+ "Async function with static ITEMS."
+ (consult--async-dynamic
+ (lambda (input)
+ (pcase-let* ((`(,re . ,hl) (consult--compile-regexp
+ input 'emacs completion-ignore-case)))
+ (if re
+ (let* ((completion-regexp-list re)
+ (all (all-completions "" items)))
+ (cl-loop for s in-ref all do
+ (funcall hl (setf s (copy-sequence s))))
+ all)
+ (copy-sequence items))))))
+
+(defun consult--async-merge-sink (sink indicator tail idx)
+ "Create sink for the async sub-functions which merges the sub-lists.
+SINK is the joined sink.
+INDICATOR is a vector of indicator symbols.
+TAIL is a vector of list tail links for each sub-list.
+IDX is the index of the corresponding link in TAIL."
+ (lambda (action)
+ (pcase action
+ (`[indicator ,state]
+ (aset indicator (1- idx) state)
+ (let* ((severity [nil finished running killed failed])
+ (state (aref severity (cl-loop for i across indicator maximize
+ (or (seq-position severity i) 0)))))
+ (funcall sink `[indicator ,state])))
+ ('flush
+ ;; Flush items if sub-list exists.
+ (when-let ((tl (aref tail idx)) (pre t))
+ (let ((i idx)) (while (not (setq pre (aref tail (cl-decf i))))))
+ (setcdr pre (cdr tl))
+ (aset tail idx nil)
+ (funcall sink 'flush)
+ (funcall sink (cdr (aref tail 0)))))
+ ((pred consp)
+ (let ((tl (aref tail idx))
+ (last (last action))
+ pre)
+ (aset tail idx last)
+ (if tl ;; Append items if sub-list exists.
+ (progn
+ (setcdr last (cdr tl))
+ (setcdr tl action))
+ ;; Otherwise insert new sub-list.
+ (let ((i idx)) (while (not (setq pre (aref tail (cl-decf i))))))
+ (setcdr last (cdr pre))
+ (setcdr pre action))
+ (funcall sink 'flush)
+ (funcall sink (cdr (aref tail 0))))))))
+
+(defun consult--async-merge (asyncs)
+ "Create merged async function from multiple ASYNCS."
+ (lambda (sink)
+ (let* ((indicator (make-vector (length asyncs) nil))
+ (tail (make-vector (1+ (length indicator)) nil))
+ (asyncs
+ (seq-map-indexed
+ (lambda (fun idx)
+ (funcall fun (consult--async-merge-sink sink indicator tail (1+ idx))))
+ asyncs)))
+ (aset tail 0 (list nil)) ;; Guard element
+ (lambda (action)
+ (dolist (async asyncs)
+ (funcall async action))
+ (funcall sink action)))))
+
+(defun consult--async-debug (prefix)
+ "Async function with debug messages.
+The messages are prefixed with PREFIX."
+ (lambda (sink)
+ (lambda (action)
+ (consult--async-log "%s: %S\n" prefix action)
+ (funcall sink action))))
+
+(defun consult--async-predicate (pred)
+ "Async function running only if PRED is non-nil."
+ (lambda (sink)
+ (let (input)
+ (lambda (action)
+ (prog1 (and (not (stringp action))
+ (funcall sink action))
+ (pcase action
+ ('setup (setq pred (consult--in-buffer pred)))
+ ((or 'cancel 'destroy) (setq input nil))
+ ((pred stringp) (setq input action)))
+ (when (and input (funcall pred))
+ (funcall sink input)
+ (setq input nil)))))))
+
+(defun consult--async-min-input (&optional min-input)
+ "Async function enforcing a minimum input length.
+MIN-INPUT is the minimum input length and defaults to
+`consult-async-min-input'."
+ (setq min-input (or min-input consult-async-min-input))
+ (lambda (sink)
+ (lambda (action)
+ (if (stringp action)
+ ;; Input can be marked with the `consult--force' property such that it
+ ;; is passed through in any case.
+ (funcall sink (if (or (and (not (equal action ""))
+ (get-text-property 0 'consult--force action))
+ (>= (length action) min-input))
+ action 'cancel))
+ (funcall sink action)))))
+
+(defun consult--async-split (&optional style)
+ "Async function, which splits the input string.
+STYLE is the splitting style and defaults to the splitting style
+configured by `consult-async-split-style'."
+ (setq style (or style consult-async-split-style 'none)
+ style (or (alist-get style consult-async-split-styles-alist)
+ (user-error "Splitting style `%s' not found" style)))
+ (lambda (sink)
+ (lambda (action)
+ (pcase action
+ ('setup
+ (consult--split-setup (let ((fun (plist-get style :function)))
+ (lambda (str) (funcall fun str style))))
+ (when-let ((initial (plist-get style :initial)))
+ (save-excursion
+ (goto-char (minibuffer-prompt-end))
+ (unless (equal initial (char-after))
+ (insert-before-markers initial))))
+ (funcall sink 'setup))
+ ((pred stringp)
+ (pcase-let ((`(,input ,_ . ,highlights)
+ (funcall (plist-get style :function) action style))
+ (end (minibuffer-prompt-end)))
+ ;; Highlight punctuation characters
+ (pcase-dolist (`(,x . ,y) highlights)
+ (let ((x (+ end x)) (y (+ end y)))
+ (add-text-properties x y '(consult--split t rear-nonsticky t))
+ (add-face-text-property x y 'consult-async-split)))
+ (funcall sink input)))
+ (_ (funcall sink action))))))
+
+(defun consult--async-indicator ()
+ "Async function with a state indicator overlay."
+ (lambda (sink)
+ (let ((ind (cl-loop for (k c f) in consult-async-indicator
+ collect (cons k (propertize (string c) 'face f))))
+ ov)
+ (lambda (action)
+ (pcase action
+ ('setup
+ (dolist (ov (overlays-at (- (minibuffer-prompt-end) 2)))
+ (when (eq (overlay-get ov 'category) 'consult-async-indicator-overlay)
+ (error "`consult--async-indicator' initialized twice")))
+ (setq ov (consult--make-overlay
+ (- (minibuffer-prompt-end) 2)
+ (- (minibuffer-prompt-end) 1)
+ 'category 'consult-async-indicator-overlay))
+ (funcall sink 'setup))
+ ('destroy
+ (delete-overlay ov)
+ (funcall sink 'destroy))
+ (`[indicator ,state]
+ (overlay-put ov 'display (alist-get state ind)))
+ (_ (funcall sink action)))))))
+
+(defun consult--async-log (formatted &rest args)
+ "Log FORMATTED ARGS to variable `consult--async-log'."
+ (with-current-buffer (get-buffer-create consult--async-log)
+ (goto-char (point-max))
+ (insert (apply #'format formatted args))))
+
+(defun consult--async-process (builder &rest props)
+ "Async process function.
+BUILDER is the command line builder function.
+PROPS are optional properties passed to `make-process'."
+ (lambda (sink)
+ (let (proc proc-buf last-args count)
+ (lambda (action)
+ (pcase action
+ ((pred stringp)
+ (funcall sink action)
+ (let* ((args (funcall builder action)))
+ (unless (stringp (car args))
+ (setq args (car args)))
+ (unless (equal args last-args)
+ (setq last-args args)
+ (when proc
+ (delete-process proc)
+ (kill-buffer proc-buf)
+ (setq proc nil proc-buf nil))
+ (when args
+ (let* ((flush t)
+ (rest "")
+ (proc-filter
+ (lambda (_ out)
+ (when flush
+ (setq flush nil)
+ (funcall sink 'flush))
+ (let ((lines (split-string out "[\r\n]+")))
+ (if (not (cdr lines))
+ (setq rest (concat rest (car lines)))
+ (setcar lines (concat rest (car lines)))
+ (let* ((len (length lines))
+ (last (nthcdr (- len 2) lines)))
+ (setq rest (cadr last)
+ count (+ count len -1))
+ (setcdr last nil)
+ (funcall sink lines))))))
+ (proc-sentinel
+ (lambda (_ event)
+ (cond
+ (flush
+ (setq flush nil)
+ (funcall sink 'flush))
+ ((and (string-prefix-p "finished" event) (not (equal rest "")))
+ (cl-incf count)
+ (funcall sink (list rest))))
+ (funcall sink `[indicator
+ ,(cond
+ ((string-prefix-p "killed" event) 'killed)
+ ((string-prefix-p "finished" event) 'finished)
+ (t 'failed))])
+ (consult--async-log
+ "consult--async-process sentinel: event=%s lines=%d\n"
+ (string-trim event) count)
+ (when (> (buffer-size proc-buf) 0)
+ (with-current-buffer (get-buffer-create consult--async-log)
+ (goto-char (point-max))
+ (insert ">>>>> stderr >>>>>\n")
+ (let ((beg (point)))
+ (insert-buffer-substring proc-buf)
+ (save-excursion
+ (goto-char beg)
+ (message #("%s" 0 2 (face error))
+ (buffer-substring-no-properties (pos-bol) (pos-eol)))))
+ (insert "<<<<< stderr <<<<<\n")))))
+ (process-adaptive-read-buffering nil))
+ (funcall sink [indicator running])
+ (consult--async-log "consult--async-process started: args=%S default-directory=%S\n"
+ args default-directory)
+ (setq count 0
+ proc-buf (generate-new-buffer " *consult-async-stderr*")
+ proc (apply #'make-process
+ `(,@props
+ :connection-type pipe
+ :name ,(car args)
+ ;;; XXX tramp bug, the stderr buffer must be empty
+ :stderr ,proc-buf
+ :noquery t
+ :command ,args
+ :filter ,proc-filter
+ :sentinel ,proc-sentinel)))))))
+ nil)
+ ((or 'cancel 'destroy)
+ (when proc
+ (delete-process proc)
+ (kill-buffer proc-buf)
+ (setq proc nil proc-buf nil))
+ (setq last-args nil)
+ (funcall sink action))
+ (_ (funcall sink action)))))))
+
+(defun consult--async-highlight (&optional highlight)
+ "Async function with candidate highlighting.
+HIGHLIGHT is a function called with the input string. It should return
+a function which mutably adds highlighting to a candidate string.
+HIGHLIGHT can also return a pair where the second element is the actual
+highlight function. If not given, HIGHLIGHT defaults to a function
+which highlights words."
+ (unless (functionp highlight)
+ (setq highlight
+ (lambda (input)
+ (consult--compile-regexp input 'emacs completion-ignore-case))))
+ (consult--async-transform-by-input
+ (lambda (input)
+ (when-let ((hl (funcall highlight input))
+ (hl (if (functionp hl) hl (cdr hl))))
+ (lambda (cands)
+ (dolist (x cands cands)
+ (funcall hl (if (consp x) (car x) x))))))))
+
+(defun consult--async-throttle (&optional throttle debounce)
+ "Async function which throttles input.
+The THROTTLE delay defaults to `consult-async-input-throttle'.
+The DEBOUNCE delay defaults to `consult-async-input-debounce'."
+ (setq throttle (or throttle consult-async-input-throttle)
+ debounce (or debounce consult-async-input-debounce))
+ (lambda (sink)
+ (let ((timer (timer-create)) (last 0) initial-p input)
+ (lambda (action)
+ (pcase action
+ ((pred stringp)
+ (unless (equal action input)
+ (cancel-timer timer)
+ (funcall sink 'cancel)
+ (timer-set-function timer (lambda ()
+ (setq last (float-time))
+ (funcall sink action)))
+ (timer-set-time
+ timer
+ (timer-relative-time
+ ;; Debounce only if the user entered new input. Start
+ ;; immediately if the minibuffer contains initial input.
+ nil (max (if (funcall initial-p) 0 debounce)
+ (- (+ last throttle) (float-time)))))
+ (setq input action)
+ (timer-activate timer))
+ nil)
+ ('setup
+ (setq initial-p
+ (consult--in-buffer
+ (let ((initial (minibuffer-contents-no-properties)))
+ (lambda ()
+ (equal initial (minibuffer-contents-no-properties))))))
+ (funcall sink action))
+ ((or 'cancel 'destroy)
+ (cancel-timer timer)
+ (funcall sink action))
+ (_ (funcall sink action)))))))
+
+(defun consult--async-refresh (&optional delay)
+ "Async function which refreshes the display with a timer.
+The refresh happens after a DELAY, defaulting to
+`consult-async-refresh-delay'."
+ (setq delay (or delay consult-async-refresh-delay))
+ (lambda (sink)
+ (if (<= delay 0)
+ (lambda (action)
+ (pcase action
+ ((or (pred consp) 'flush)
+ (prog1 (funcall sink action)
+ (funcall sink 'refresh)))
+ (_ (funcall sink action))))
+ (let ((timer (timer-create)))
+ (lambda (action)
+ (prog1 (funcall sink action)
+ (pcase action
+ ((or (pred consp) 'flush)
+ (unless (memq timer timer-list)
+ (timer-set-function timer sink '(refresh))
+ (timer-set-time timer (timer-relative-time nil delay))
+ (timer-activate timer)))
+ ((or 'destroy 'refresh) ;; 'refresh already forced a refresh
+ (cancel-timer timer)))))))))
+
+(defun consult--async-transform-by-input (fun)
+ "Transform candidates via FUN.
+FUN takes the input string and must return a transformation function."
+ (lambda (sink)
+ (let (transform)
+ (lambda (action)
+ (cond
+ ((stringp action)
+ (setq transform (funcall fun action))
+ (funcall sink action))
+ ((and (consp action) transform)
+ (funcall sink (funcall transform action)))
+ (t (funcall sink action)))))))
+
+(defun consult--async-transform (fun)
+ "Use FUN to transform candidates."
+ (lambda (sink)
+ (lambda (action)
+ (funcall sink (if (consp action) (funcall fun action) action)))))
+
+(defun consult--async-map (fun)
+ "Map candidates by FUN."
+ (consult--async-transform (apply-partially #'mapcar fun)))
+
+(defun consult--async-filter (fun)
+ "Filter candidates by FUN."
+ (consult--async-transform (apply-partially #'seq-filter fun)))
+
+;;;; Prebuilt async pipelines
+
+(cl-defun consult--dynamic-collection (fun &key min-input throttle debounce
+ transform highlight)
+ "Dynamic candidate computation pipeline.
+FUN computes the candidates. It takes either a single input argument or
+an input argument and a callback function, if computed candidates should
+be updated incrementally. The callback function must not be called
+after FUN has returned.
+MIN-INPUT is passed to `consult--async-min-input'.
+THROTTLE and DEBOUNCE are passed to `consult--async-throttle'.
+TRANSFORM is an optional async function transforming the candidate.
+HIGHLIGHT is an optional highlight function, can be t for the default
+highlighting function."
+ (declare (indent 1))
+ (consult--async-pipeline
+ (consult--async-min-input min-input)
+ (consult--async-throttle throttle debounce)
+ (consult--async-dynamic fun)
+ transform
+ (and highlight (consult--async-highlight highlight))))
+
+(cl-defun consult--process-collection (builder &rest props &key min-input
+ debounce throttle transform
+ highlight &allow-other-keys)
+ "Asynchronous process pipeline.
+BUILDER is the command line builder function, which takes the
+input string and must either return a list of command line
+arguments or a pair of the command line argument list and a
+highlighting function.
+TRANSFORM is an optional async function transforming the candidate.
+If HIGHLIGHT is non-nil, highlight the candidates.
+MIN-INPUT is passed to `consult--async-min-input'.
+THROTTLE and DEBOUNCE are passed to `consult--async-throttle'.
+Other PROPS are passed to `make-process'."
+ (declare (indent 1))
+ (consult--async-pipeline
+ (consult--async-min-input min-input)
+ (consult--async-throttle throttle debounce)
+ (apply #'consult--async-process builder
+ (consult--plist-remove
+ '(:min-input :throttle :debounce :transform :highlight) props))
+ transform
+ (and highlight (consult--async-highlight
+ (if (functionp highlight) highlight builder)))))
+
+;;;; Special keymaps
+
+(defvar-keymap consult-async-map
+ :doc "Keymap added for commands with asynchronous candidates."
+ ;; Overwriting some unusable defaults of default minibuffer completion.
+ "<remap> <minibuffer-complete-word>" #'self-insert-command
+ ;; Remap Emacs 29 history and default completion for now
+ ;; (gh:minad/consult#613).
+ "<remap> <minibuffer-complete-defaults>" #'ignore
+ "<remap> <minibuffer-complete-history>" #'consult-history)
+
+(defvar-keymap consult-narrow-map
+ :doc "Narrowing keymap which is added to the local minibuffer map.
+Note that `consult-narrow-key' and `consult-widen-key' are bound dynamically."
+ "SPC" consult--narrow-space
+ "DEL" consult--narrow-delete)
+
+;;;; Internal API: consult--read
+
+(defun consult--annotate-align (cand ann)
+ "Align annotation ANN by computing the maximum CAND width."
+ (setq consult--annotate-align-width
+ (max consult--annotate-align-width
+ (* (ceiling (consult--display-width cand)
+ consult--annotate-align-step)
+ consult--annotate-align-step)))
+ (when ann
+ (concat
+ #(" " 0 1 (display (space :align-to (+ left consult--annotate-align-width))))
+ ann)))
+
+(defun consult--add-history (async items)
+ "Add ITEMS to the minibuffer future history.
+ASYNC must be non-nil for async completion functions."
+ (setq items
+ (delete-dups
+ (append
+ ;; Defaults are at the beginning of the future history
+ (ensure-list minibuffer-default)
+ ;; Custom items
+ (remove "" (remq nil (ensure-list items)))
+ ;; Add all completions for non-async commands. For async commands
+ ;; this feature is not useful, since if one selects a completion
+ ;; candidate, the async search is restarted using that candidate
+ ;; string. This usually does not yield a desired result since the
+ ;; async input uses a special format, e.g., `#grep#filter'.
+ (unless async
+ (all-completions "" minibuffer-completion-table
+ minibuffer-completion-predicate)))))
+ ;; Prefix all items with the initial input from the async split style.
+ (when (and async (get-text-property (minibuffer-prompt-end) 'consult--split))
+ (let* ((beg (minibuffer-prompt-end))
+ (end (or (text-property-any beg (point-max) 'consult--split nil)
+ (point-max)))
+ (pre (buffer-substring beg end)))
+ (cl-loop for item in-ref items do
+ (unless (string-prefix-p pre item)
+ (setf item (concat pre item))))))
+ items)
+
+(defun consult--setup-keymap (keymap async narrow preview-key)
+ "Setup minibuffer keymap.
+
+KEYMAP is a command-specific keymap.
+ASYNC must be non-nil for async completion functions.
+NARROW is the narrowing configuration.
+PREVIEW-KEY are the preview keys."
+ (let ((old-map (current-local-map))
+ (map (make-sparse-keymap)))
+
+ ;; Add narrow keys
+ (when narrow
+ (consult--narrow-setup narrow map))
+
+ ;; Preview trigger keys
+ (when (and (consp preview-key) (memq :keys preview-key))
+ (setq preview-key (plist-get preview-key :keys)))
+ (setq preview-key (mapcar #'car (consult--preview-key-normalize preview-key)))
+ (when preview-key
+ (dolist (key preview-key)
+ (unless (or (eq key 'any) (lookup-key old-map key))
+ (define-key map key #'ignore))))
+
+ ;; Put the keymap together
+ (use-local-map
+ (make-composed-keymap
+ (delq nil (list keymap
+ (and async consult-async-map)
+ (and narrow consult-narrow-map)
+ map))
+ old-map))))
+
+(defun consult--tofu-hide-in-minibuffer (&rest _)
+ "Hide the tofus in the minibuffer."
+ (let* ((min (minibuffer-prompt-end))
+ (max (point-max))
+ (pos max))
+ (while (and (> pos min) (consult--tofu-p (char-before pos)))
+ (cl-decf pos))
+ (when (< pos max)
+ (add-text-properties pos max '(invisible t rear-nonsticky t cursor-intangible t)))))
+
+(defun consult--read-annotate (fun cand)
+ "Annotate CAND with annotation function FUN."
+ (pcase (funcall fun cand)
+ (`(,_ ,_ ,suffix) suffix)
+ (ann ann)))
+
+(defun consult--read-affixate (fun cands)
+ "Affixate CANDS with annotation function FUN."
+ (mapcar (lambda (cand)
+ (let ((ann (funcall fun cand)))
+ (if (consp ann)
+ ann
+ (setq ann (or ann ""))
+ (list cand ""
+ ;; The default completion UI adds the
+ ;; `completions-annotations' face if no other faces are
+ ;; present.
+ (if (text-property-not-all 0 (length ann) 'face nil ann)
+ ann
+ (propertize ann 'face 'completions-annotations))))))
+ cands))
+
+(cl-defun consult--read-1 (table &key
+ prompt predicate require-match history default keymap category
+ initial narrow initial-narrow add-history annotate state
+ preview-key sort lookup group inherit-input-method async-wrap)
+ "See `consult--read' for the documentation of the arguments."
+ (when (and async-wrap (consult--async-p table))
+ (setq table (funcall (funcall async-wrap table) (consult--async-sink))))
+ (minibuffer-with-setup-hook
+ (:append (lambda ()
+ (add-hook 'after-change-functions #'consult--tofu-hide-in-minibuffer nil 'local)
+ (consult--setup-keymap keymap (consult--async-p table) narrow preview-key)
+ (when initial-narrow (consult-narrow initial-narrow))
+ (setq-local minibuffer-default-add-function
+ (apply-partially #'consult--add-history (consult--async-p table) add-history)
+ kill-transform-function #'consult--tofu-strip)))
+ (consult--with-async table
+ (consult--with-preview
+ preview-key state
+ (lambda (narrow input cand)
+ (funcall lookup cand (funcall table nil) input narrow))
+ (apply-partially #'run-hook-with-args-until-success
+ 'consult--completion-candidate-hook)
+ (pcase-exhaustive history
+ (`(:input ,var) var)
+ ((pred symbolp)))
+ ;; Do not unnecessarily let-bind the lambdas to avoid over-capturing in
+ ;; the interpreter. This will make closures and the lambda string
+ ;; representation larger, which makes debugging much worse. Fortunately
+ ;; the over-capturing problem does not affect the bytecode interpreter
+ ;; which does a proper scope analysis.
+ (let* ((metadata `(metadata
+ ,@(when category `((category . ,category)))
+ ,@(when group `((group-function . ,group)))
+ ,@(when annotate
+ `((affixation-function
+ . ,(apply-partially #'consult--read-affixate annotate))
+ (annotation-function
+ . ,(apply-partially #'consult--read-annotate annotate))))
+ ,@(unless sort '((cycle-sort-function . identity)
+ (display-sort-function . identity)))))
+ (consult--annotate-align-width 0)
+ (selected
+ (completing-read
+ prompt
+ (lambda (str pred action)
+ (let ((result (complete-with-action action (funcall table nil) str pred)))
+ (if (eq action 'metadata)
+ (if (and (eq (car result) 'metadata) (cdr result))
+ ;; Merge metadata
+ `(metadata ,@(cdr metadata) ,@(cdr result))
+ metadata)
+ result)))
+ predicate require-match initial
+ (if (symbolp history) history (cadr history))
+ default
+ inherit-input-method)))
+ ;; Repair the null completion semantics. `completing-read' may return
+ ;; an empty string even if REQUIRE-MATCH is non-nil. One can always
+ ;; opt-in to null completion by passing the empty string for DEFAULT.
+ (when (and (eq require-match t) (not default) (equal selected ""))
+ (user-error "No selection"))
+ selected)))))
+
+(cl-defun consult--read (table &rest options &key
+ prompt predicate require-match history default
+ keymap category initial narrow initial-narrow
+ add-history annotate state preview-key sort
+ lookup group inherit-input-method async-wrap)
+ "Enhanced completing read function to select from TABLE.
+
+The function is a thin wrapper around `completing-read'. Keyword
+arguments are used instead of positional arguments for code
+clarity. On top of `completing-read' it additionally supports
+computing the candidate list asynchronously, candidate preview
+and narrowing. You should use `completing-read' instead of
+`consult--read' if you don't use asynchronous candidate
+computation or candidate preview.
+
+Keyword OPTIONS:
+
+PROMPT is the string which is shown as prompt in the minibuffer.
+PREDICATE is a filter function called for each candidate, returns
+nil or t.
+REQUIRE-MATCH equals t means that an exact match is required.
+HISTORY is the symbol of the history variable.
+DEFAULT is the default selected value.
+ADD-HISTORY is a list of items to add to the history.
+CATEGORY is the completion category symbol.
+SORT should be set to nil if the candidates are already sorted.
+This will disable sorting in the completion UI.
+LOOKUP is a lookup function passed the selected candidate string,
+the list of candidates, the current input string and the current
+narrowing value.
+ANNOTATE is a function passed a candidate string. The function
+should either return an annotation string or a list of three
+strings (candidate prefix postfix).
+INITIAL is the initial input string.
+STATE is the state function, see `consult--with-preview'.
+GROUP is a completion metadata `group-function' as documented in
+the Elisp manual.
+PREVIEW-KEY are the preview keys. Can be nil, `any', a single
+key or a list of keys.
+NARROW is an alist of narrowing prefix strings and description.
+INITIAL-NARROW is an initial narrow key.
+KEYMAP is a command-specific keymap.
+INHERIT-INPUT-METHOD, if non-nil the minibuffer inherits the
+input method.
+ASYNC-WRAP wraps asynchronous functions and defaults to
+`consult--async-wrap'."
+ ;; supported types
+ (cl-assert (or (functionp table) ;; dynamic table or asynchronous function
+ (obarrayp table) ;; obarray
+ (hash-table-p table) ;; hash table
+ (not table) ;; empty list
+ (stringp (car table)) ;; string list
+ (and (consp (car table)) (stringp (caar table))) ;; string alist
+ (and (consp (car table)) (symbolp (caar table))))) ;; symbol alist
+ (ignore prompt predicate require-match history default keymap category
+ initial narrow initial-narrow add-history annotate state
+ preview-key sort lookup group inherit-input-method async-wrap)
+ (apply #'consult--read-1 table
+ (append
+ (consult--customize-get)
+ options
+ (list :prompt "Select: "
+ :preview-key consult-preview-key
+ :sort t
+ :async-wrap #'consult--async-wrap
+ :lookup (lambda (selected &rest _) selected)))))
+
+;;;; Internal API: consult--prompt
+
+(cl-defun consult--prompt-1 (&key prompt history add-history initial default
+ keymap state preview-key transform inherit-input-method)
+ "See `consult--prompt' for documentation."
+ (minibuffer-with-setup-hook
+ (:append (lambda ()
+ (consult--setup-keymap keymap nil nil preview-key)
+ (setq-local minibuffer-default-add-function
+ (apply-partially #'consult--add-history nil add-history))))
+ (consult--with-preview
+ preview-key state
+ (lambda (_narrow inp _cand) (funcall transform inp))
+ (lambda () "")
+ history
+ (read-from-minibuffer prompt initial nil nil history default inherit-input-method))))
+
+(cl-defun consult--prompt (&rest options &key prompt history add-history initial default
+ keymap state preview-key transform inherit-input-method)
+ "Read from minibuffer.
+
+Keyword OPTIONS:
+
+PROMPT is the string to prompt with.
+TRANSFORM is a function which is applied to the current input string.
+HISTORY is the symbol of the history variable.
+INITIAL is initial input.
+DEFAULT is the default selected value.
+ADD-HISTORY is a list of items to add to the history.
+STATE is the state function, see `consult--with-preview'.
+PREVIEW-KEY are the preview keys (nil, `any', a single key or a list of keys).
+KEYMAP is a command-specific keymap."
+ (ignore prompt history add-history initial default
+ keymap state preview-key transform inherit-input-method)
+ (apply #'consult--prompt-1
+ (append
+ (consult--customize-get)
+ options
+ (list :prompt "Input: "
+ :preview-key consult-preview-key
+ :transform #'identity))))
+
+;;;; Internal API: consult--multi
+
+(defsubst consult--multi-source (sources cand)
+ "Lookup source for CAND in SOURCES list."
+ (aref sources (consult--tofu-get cand)))
+
+(defsubst consult--multi-visible-p (src)
+ "Is SRC visible according to `consult--narrow'?"
+ (if-let ((n consult--narrow))
+ (pcase (plist-get src :narrow)
+ ((and ks `((,_ . ,_) . ,_)) (assq n ks))
+ ((or `(,k . ,_) k) (eq n k)))
+ (not (plist-get src :hidden))))
+
+(defun consult--multi-predicate (sources cand)
+ "Predicate function called for each candidate CAND given SOURCES."
+ (consult--multi-visible-p (consult--multi-source sources cand)))
+
+(defun consult--multi-narrow (sources)
+ "Return narrow list from SOURCES."
+ (thread-last
+ sources
+ (mapcan (lambda (src)
+ (when-let (narrow (plist-get src :narrow))
+ (if (consp narrow)
+ (if (consp (car narrow)) (append narrow nil) (list narrow))
+ (when-let (name (plist-get src :name))
+ (list (cons narrow name)))))))
+ (delq nil)
+ (delete-dups)))
+
+(defun consult--multi-annotate (sources cand)
+ "Annotate candidate CAND from multi SOURCES."
+ (consult--annotate-align
+ cand
+ (let ((src (consult--multi-source sources cand)))
+ (if-let ((fun (plist-get src :annotate)))
+ (funcall fun (cdr (get-text-property 0 'multi-category cand)))
+ (plist-get src :name)))))
+
+(defun consult--multi-group (sources cand transform)
+ "Return title of candidate CAND or TRANSFORM the candidate given SOURCES."
+ (if transform cand
+ (plist-get (consult--multi-source sources cand) :name)))
+
+(defun consult--multi-preview-key (sources)
+ "Return preview keys from SOURCES."
+ (list :predicate
+ (lambda (cand)
+ (if (plist-member (cdr cand) :preview-key)
+ (plist-get (cdr cand) :preview-key)
+ consult-preview-key))
+ :keys
+ (delete-dups
+ (seq-filter (lambda (k) (or (eq k 'any) (stringp k)))
+ (seq-mapcat (lambda (src)
+ (ensure-list
+ (if (plist-member src :preview-key)
+ (plist-get src :preview-key)
+ consult-preview-key)))
+ sources)))))
+
+(defun consult--multi-lookup (sources selected candidates _input narrow &rest _)
+ "Lookup SELECTED in CANDIDATES given SOURCES, with potential NARROW."
+ (if (or (string-blank-p selected)
+ (not (consult--tofu-p (aref selected (1- (length selected))))))
+ ;; Non-existing candidate without Tofu or default submitted (empty string)
+ (let* ((src (cond
+ (narrow (seq-find (lambda (src)
+ (let ((n (plist-get src :narrow)))
+ (eq (or (car-safe n) n -1) narrow)))
+ sources))
+ ((seq-find (lambda (src) (plist-get src :default)) sources))
+ ((seq-find (lambda (src) (not (plist-get src :hidden))) sources))
+ ((aref sources 0))))
+ (idx (seq-position sources src))
+ (def (and (string-blank-p selected) ;; default candidate
+ (seq-find (lambda (cand) (eq idx (consult--tofu-get cand))) candidates))))
+ (if def
+ (cons (cdr (get-text-property 0 'multi-category def)) src)
+ `(,selected :match nil ,@src)))
+ (if-let (found (member selected candidates))
+ ;; Existing candidate submitted
+ (cons (cdr (get-text-property 0 'multi-category (car found)))
+ (consult--multi-source sources selected))
+ ;; Non-existing Tofu'ed candidate submitted, e.g., via Embark
+ `(,(substring selected 0 -1) :match nil ,@(consult--multi-source sources selected)))))
+
+(defun consult--multi-items (idx src items)
+ "Create completion candidate strings from ITEMS.
+Attach source IDX and SRC properties to each item."
+ (unless (listp items)
+ (setq items (plist-get src :items)
+ items (if (functionp items) (funcall items) items)))
+ (let ((face (plist-get src :face))
+ (cat (or (plist-get src :category) 'general)))
+ (cl-loop
+ for item in items collect
+ (let* ((str (or (car-safe item) item))
+ (len (length str))
+ (cand (consult--tofu-append str idx)))
+ ;; Preserve existing `multi-category' datum of the candidate.
+ (unless (and (eq str item) (get-text-property 0 'multi-category str))
+ (put-text-property 0 len 'multi-category (cons cat (or (cdr-safe item) item)) cand))
+ (when face
+ (add-face-text-property 0 len face t cand))
+ cand))))
+
+(defun consult--multi-async (sources)
+ "Create async function from multi SOURCES."
+ (consult--async-merge
+ (cl-loop
+ for idx from 0 for src across sources collect
+ (let ((idx idx) (src src))
+ (consult--async-pipeline
+ (consult--async-predicate (apply-partially #'consult--multi-visible-p src))
+ (if-let ((async (plist-get src :async)))
+ (consult--async-pipeline
+ async
+ (consult--async-transform
+ (apply-partially #'consult--multi-items idx src)))
+ (consult--async-static (consult--multi-items idx src t))))))))
+
+(defun consult--multi-enabled-sources (sources)
+ "Return vector of enabled SOURCES."
+ (vconcat
+ (cl-loop
+ for src in sources
+ if (when (setq src (if (symbolp src) (symbol-value src) src))
+ (unless (xor (plist-member src :async) (plist-member src :items))
+ (error "Source must specify either :items or :async"))
+ (funcall (or (plist-get src :enabled) #'always)))
+ collect src)))
+
+(defun consult--multi-state (sources)
+ "State function given SOURCES."
+ (when-let (states (delq nil (mapcar (lambda (src)
+ (when-let (fun (plist-get src :state))
+ (cons src (funcall fun))))
+ sources)))
+ (let (last-fun)
+ (pcase-lambda (action `(,cand . ,src))
+ (pcase action
+ ('setup
+ (pcase-dolist (`(,_ . ,fun) states)
+ (funcall fun 'setup nil)))
+ ('exit
+ (pcase-dolist (`(,_ . ,fun) states)
+ (funcall fun 'exit nil)))
+ ('preview
+ (let ((selected-fun (cdr (assq src states))))
+ ;; If the candidate source changed during preview communicate to
+ ;; the last source, that none of its candidates is previewed anymore.
+ (when (and last-fun (not (eq last-fun selected-fun)))
+ (funcall last-fun 'preview nil))
+ (setq last-fun selected-fun)
+ (when selected-fun
+ (funcall selected-fun 'preview cand))))
+ ('return
+ (let ((selected-fun (cdr (assq src states))))
+ ;; Finish all the sources, except the selected one.
+ (pcase-dolist (`(,_ . ,fun) states)
+ (unless (eq fun selected-fun)
+ (funcall fun 'return nil)))
+ ;; Finish the source with the selected candidate
+ (when selected-fun
+ (funcall selected-fun 'return cand)))))))))
+
+(defun consult--multi-collection (sources)
+ "Static or asynchronous completion function from SOURCES."
+ (consult--with-increased-gc
+ (if (cl-loop for src across sources thereis (plist-get src :async))
+ (consult--multi-async sources)
+ (cl-loop for idx from 0 for src across sources nconc
+ (consult--multi-items idx src t)))))
+
+(defun consult--multi (sources &rest options)
+ "Select from candidates taken from a list of SOURCES.
+
+OPTIONS is the plist of options passed to `consult--read'. The following
+options are supported: :require-match, :history, :keymap, :initial,
+:initial-narrow, :add-history, :sort and :inherit-input-method. The other
+options of `consult--read' are used by the `consult--multi' implementation
+and should not be overwritten, except in in special scenarios.
+
+The function returns the selected candidate in the form (cons candidate
+source-plist). The plist has the key :match with a value nil if the
+candidate does not exist, t if the candidate exists and `new' if the
+candidate has been created.
+
+The sources of the source list can either be symbols of source variables
+or source values. Sources which are nil are ignored. Source values
+must be plists with the following fields.
+
+Either the :items or the :async source field is required:
+* :items - List of strings to select from or function returning list of
+ strings. The strings can carry metadata in text properties, which is
+ then available to the :annotate, :action and :state functions. The
+ list can also consist of pairs, with the string in the `car' used for
+ display and the `cdr' the actual candidate.
+* :async - Alternative to :items for asynchronous sources. The function
+ receives an asynchronous sink and an action as argument as documented
+ by `consult--async-pipeline'.
+
+Optional source fields:
+* :name - Name of the source as a string, used for narrowing,
+ group titles and annotations.
+* :narrow - Narrowing character, (char . string) pair or list of pairs.
+* :category - Completion category symbol.
+* :enabled - Function which must return t if the source is enabled.
+* :hidden - When t candidates of this source are hidden by default.
+* :face - Face used for highlighting the candidates.
+* :annotate - Annotation function called for each candidate, returns string.
+* :history - Name of history variable to add selected candidate.
+* :default - Must be t if the first item of the source is the default value.
+* :action - Function called with the selected candidate.
+* :new - Function called with new candidate name, only if :require-match is nil.
+* :state - State constructor for the source, must return the
+ state function. The state function is informed about state
+ changes of the UI and can be used to implement preview.
+* Other custom source fields can be added depending on the use
+ case. Note that the source is returned by `consult--multi'
+ together with the selected candidate."
+ (let* ((sources (consult--multi-enabled-sources sources))
+ (collection (consult--multi-collection sources))
+ (selected
+ (apply #'consult--read
+ collection
+ (append
+ options
+ (list
+ :category 'multi-category
+ :predicate (apply-partially #'consult--multi-predicate sources)
+ :annotate (apply-partially #'consult--multi-annotate sources)
+ :group (apply-partially #'consult--multi-group sources)
+ :lookup (apply-partially #'consult--multi-lookup sources)
+ :preview-key (consult--multi-preview-key sources)
+ :narrow (consult--multi-narrow sources)
+ :state (consult--multi-state sources))))))
+ (when-let (history (plist-get (cdr selected) :history))
+ (add-to-history history (car selected)))
+ (if (plist-member (cdr selected) :match)
+ (when-let (fun (plist-get (cdr selected) :new))
+ (funcall fun (car selected))
+ (plist-put (cdr selected) :match 'new))
+ (when-let (fun (plist-get (cdr selected) :action))
+ (funcall fun (car selected)))
+ (setq selected `(,(car selected) :match t ,@(cdr selected))))
+ selected))
+
+;;;; Customization macro
+
+(defun consult--customize-put (cmds prop form)
+ "Set property PROP to FORM of commands CMDS."
+ (dolist (cmd cmds)
+ (cond
+ ((and (boundp cmd) (consp (symbol-value cmd)))
+ (setf (plist-get (symbol-value cmd) prop) (eval form 'lexical)))
+ ((functionp cmd)
+ (setf (plist-get (alist-get cmd consult--customize-alist) prop) form))
+ (t (user-error "%s is neither a Command command nor a source" cmd))))
+ nil)
+
+(defmacro consult-customize (&rest args)
+ "Set properties of commands or sources.
+ARGS is a list of commands or sources followed by the list of
+keyword-value pairs. For `consult-customize' to succeed, the
+customized sources and commands must exist. When a command is
+invoked, the value of `this-command' is used to lookup the
+corresponding customization options."
+ (let (setter)
+ (while args
+ (let ((cmds (seq-take-while (lambda (x) (not (keywordp x))) args)))
+ (setq args (seq-drop-while (lambda (x) (not (keywordp x))) args))
+ (while (keywordp (car args))
+ (push `(consult--customize-put ',cmds ,(car args) ',(cadr args)) setter)
+ (setq args (cddr args)))))
+ (macroexp-progn setter)))
+
+(defun consult--customize-get ()
+ "Get configuration from `consult--customize-alist' for `this-command'."
+ (mapcar (lambda (x) (eval x 'lexical))
+ (alist-get this-command consult--customize-alist)))
+
+;;;; Commands
+
+;;;;; Command: consult-completion-in-region
+
+(defun consult--insertion-preview (start end)
+ "State function for previewing a candidate in a specific region.
+The candidates are previewed in the region from START to END. This function is
+used as the `:state' argument for `consult--read' in the `consult-yank' family
+of functions and in `consult-completion-in-region'."
+ (unless (or (minibufferp)
+ ;; Disable preview if anything odd is going on with the markers.
+ ;; Otherwise we get "Marker points into wrong buffer errors". See
+ ;; gh:minad/consult#375, where Org mode source blocks are
+ ;; completed in a different buffer than the original buffer. This
+ ;; completion is probably also problematic in my Corfu completion
+ ;; package.
+ (not (eq (window-buffer) (current-buffer)))
+ (and (markerp start) (not (eq (marker-buffer start) (current-buffer))))
+ (and (markerp end) (not (eq (marker-buffer end) (current-buffer)))))
+ (let (ov)
+ (lambda (action cand)
+ (cond
+ ((and (not cand) ov)
+ (delete-overlay ov)
+ (setq ov nil))
+ ((and (eq action 'preview) cand)
+ (unless ov
+ (setq ov (consult--make-overlay start end
+ 'invisible t
+ 'window (selected-window))))
+ ;; Use `add-face-text-property' on a copy of "cand in order to merge face properties
+ (setq cand (copy-sequence cand))
+ (add-face-text-property 0 (length cand) 'consult-preview-insertion t cand)
+ ;; Use the `before-string' property since the overlay might be empty.
+ (overlay-put ov 'before-string cand)))))))
+
+;;;###autoload
+(defun consult-completion-in-region (start end collection &optional predicate)
+ "Use minibuffer completion as the UI for `completion-at-point'.
+
+The function is called with 4 arguments: START END COLLECTION
+PREDICATE. The arguments and expected return value are as
+specified for `completion-in-region'. Use this function as a
+value for `completion-in-region-function'."
+ (barf-if-buffer-read-only)
+ (let* ((initial (buffer-substring-no-properties start end))
+ (metadata (completion-metadata initial collection predicate))
+ ;; bug#75910: category instead of `minibuffer-completing-file-name'
+ (minibuffer-completing-file-name
+ (eq 'file (completion-metadata-get metadata 'category)))
+ (threshold (completion--cycle-threshold metadata))
+ (all (completion-all-completions initial collection predicate (length initial)))
+ ;; Wrap all annotation functions to ensure that they are executed
+ ;; in the original buffer.
+ (exit-fun (plist-get completion-extra-properties :exit-function))
+ (ann-fun (plist-get completion-extra-properties :annotation-function))
+ (aff-fun (plist-get completion-extra-properties :affixation-function))
+ (docsig-fun (plist-get completion-extra-properties :company-docsig))
+ (completion-extra-properties
+ `(,@(and ann-fun (list :annotation-function (consult--in-buffer ann-fun)))
+ ,@(and aff-fun (list :affixation-function (consult--in-buffer aff-fun)))
+ ;; Provide `:annotation-function' if `:company-docsig' is specified.
+ ,@(and docsig-fun (not ann-fun) (not aff-fun)
+ (list :annotation-function
+ (consult--in-buffer
+ (lambda (cand)
+ (concat (propertize " " 'display '(space :align-to center))
+ (funcall docsig-fun cand)))))))))
+ ;; error if `threshold' is t or the improper list `all' is too short
+ (if (and threshold
+ (or (not (consp (ignore-errors (nthcdr threshold all))))
+ (and completion-cycling completion-all-sorted-completions)))
+ (completion--in-region start end collection predicate)
+ (let* ((this-command #'consult-completion-in-region)
+ (completion
+ (cond
+ ((atom all) nil)
+ ((and (consp all) (atom (cdr all)))
+ (concat (substring initial 0 (cdr all)) (car all)))
+ (t
+ (consult--local-let ((enable-recursive-minibuffers t))
+ ;; Evaluate completion table in the original buffer.
+ ;; This is a reasonable thing to do and required by
+ ;; some completion tables in particular by lsp-mode.
+ ;; See gh:minad/vertico#61.
+ (consult--read
+ (consult--completion-table-in-buffer collection)
+ :prompt (if (minibufferp)
+ ;; Use existing minibuffer prompt and input
+ (let ((prompt (buffer-substring (point-min) start)))
+ (put-text-property
+ (max 0 (1- (minibuffer-prompt-end))) (length prompt)
+ 'face 'shadow prompt)
+ prompt)
+ "Complete: ")
+ :state (consult--insertion-preview start end)
+ :predicate predicate
+ :initial initial))))))
+ (if completion
+ (progn
+ ;; bug#55205: completion--replace removes properties!
+ (completion--replace start end (setq completion (concat completion)))
+ (when exit-fun
+ (funcall exit-fun completion
+ ;; If completion is finished and cannot be further
+ ;; completed, return `finished'. Otherwise return
+ ;; `exact'.
+ (if (eq (try-completion completion collection predicate) t)
+ 'finished 'exact)))
+ t)
+ (message "No completion")
+ nil)))))
+
+;;;;; Command: consult-outline
+
+(defun consult--outline-candidates ()
+ "Return alist of outline headings and positions."
+ (consult--forbid-minibuffer)
+ (let* ((line (line-number-at-pos (point-min) consult-line-numbers-widen))
+ (heading-regexp (concat "^\\(?:"
+ ;; default definition from outline.el
+ (or (bound-and-true-p outline-regexp) "[*\^L]+")
+ "\\)"))
+ (heading-alist (bound-and-true-p outline-heading-alist))
+ (level-fun (or (bound-and-true-p outline-level)
+ (lambda () ;; as in the default from outline.el
+ (or (cdr (assoc (match-string 0) heading-alist))
+ (- (match-end 0) (match-beginning 0))))))
+ (buffer (current-buffer))
+ candidates)
+ (save-excursion
+ (goto-char (point-min))
+ (while (save-excursion
+ (if-let (fun (bound-and-true-p outline-search-function))
+ (funcall fun)
+ (re-search-forward heading-regexp nil t)))
+ (cl-incf line (consult--count-lines (match-beginning 0)))
+ (push (consult--location-candidate
+ (consult--buffer-substring (pos-bol) (pos-eol) 'fontify)
+ (cons buffer (point)) (1- line) (1- line)
+ 'consult--outline-level (funcall level-fun))
+ candidates)
+ (goto-char (1+ (pos-eol)))))
+ (unless candidates
+ (user-error "No headings"))
+ (nreverse candidates)))
+
+;;;###autoload
+(defun consult-outline (&optional level)
+ "Jump to an outline heading, obtained by matching against `outline-regexp'.
+
+This command supports narrowing to a heading level and candidate
+preview. The initial narrowing LEVEL can be given as prefix
+argument. The symbol at point is added to the future history."
+ (interactive
+ (list (and current-prefix-arg (prefix-numeric-value current-prefix-arg))))
+ (let* ((candidates (consult--slow-operation
+ "Collecting headings..."
+ (consult--outline-candidates)))
+ (min-level (- (cl-loop for cand in candidates minimize
+ (get-text-property 0 'consult--outline-level cand))
+ ?1))
+ (narrow-pred (lambda (cand)
+ (<= (get-text-property 0 'consult--outline-level cand)
+ (+ consult--narrow min-level))))
+ (narrow-keys (mapcar (lambda (c) (cons c (format "Level %c" c)))
+ (number-sequence ?1 ?9)))
+ (narrow-init (and level (max ?1 (min ?9 (+ level ?0))))))
+ (consult--read
+ candidates
+ :prompt "Go to heading: "
+ :annotate (consult--line-prefix)
+ :category 'consult-location
+ :sort nil
+ :require-match t
+ :lookup #'consult--line-match
+ :initial-narrow narrow-init
+ :narrow (list :predicate narrow-pred :keys narrow-keys)
+ :history '(:input consult--line-history)
+ :add-history (thing-at-point 'symbol)
+ :state (consult--location-state candidates))))
+
+;;;;; Command: consult-mark
+
+(defun consult--mark-candidates (markers)
+ "Return list of candidates strings for MARKERS."
+ (consult--forbid-minibuffer)
+ (let ((candidates)
+ (current-buf (current-buffer)))
+ (save-excursion
+ (dolist (marker markers)
+ (when-let ((pos (marker-position marker))
+ (buf (marker-buffer marker)))
+ (when (and (eq buf current-buf)
+ (consult--in-range-p pos))
+ (goto-char pos)
+ ;; `line-number-at-pos' is a very slow function, which should be
+ ;; replaced everywhere. However in this case the slow
+ ;; line-number-at-pos does not hurt much, since the mark ring is
+ ;; usually small since it is limited by `mark-ring-max'.
+ (push (consult--location-candidate
+ (consult--line-with-mark marker) marker
+ (line-number-at-pos pos consult-line-numbers-widen)
+ marker)
+ candidates)))))
+ (unless candidates
+ (user-error "No marks"))
+ (nreverse (delete-dups candidates))))
+
+;;;###autoload
+(defun consult-mark (&optional markers)
+ "Jump to a marker in MARKERS list (defaults to buffer-local `mark-ring').
+
+The command supports preview of the currently selected marker position.
+The symbol at point is added to the future history."
+ (interactive)
+ (consult--read
+ (consult--mark-candidates
+ (or markers (cons (mark-marker) mark-ring)))
+ :prompt "Go to mark: "
+ :annotate (consult--line-prefix)
+ :category 'consult-location
+ :sort nil
+ :require-match t
+ :lookup #'consult--lookup-location
+ :history '(:input consult--line-history)
+ :add-history (thing-at-point 'symbol)
+ :state (consult--jump-state)))
+
+;;;;; Command: consult-global-mark
+
+(defun consult--global-mark-candidates (markers)
+ "Return list of candidates strings for MARKERS."
+ (consult--forbid-minibuffer)
+ (let ((candidates))
+ (save-excursion
+ (dolist (marker markers)
+ (when-let ((pos (marker-position marker))
+ (buf (marker-buffer marker)))
+ (unless (minibufferp buf)
+ (with-current-buffer buf
+ (when (consult--in-range-p pos)
+ (goto-char pos)
+ ;; `line-number-at-pos' is slow, see comment in `consult--mark-candidates'.
+ (let* ((line (line-number-at-pos pos consult-line-numbers-widen))
+ (prefix (consult--format-file-line-match (buffer-name buf) line ""))
+ (cand (concat prefix (consult--line-with-mark marker) (consult--tofu-encode marker))))
+ (put-text-property 0 (length prefix) 'consult-strip t cand)
+ (put-text-property 0 (length cand) 'consult-location (cons marker line) cand)
+ (push cand candidates))))))))
+ (unless candidates
+ (user-error "No global marks"))
+ (nreverse (delete-dups candidates))))
+
+;;;###autoload
+(defun consult-global-mark (&optional markers)
+ "Jump to a marker in MARKERS list (defaults to `global-mark-ring').
+
+The command supports preview of the currently selected marker position.
+The symbol at point is added to the future history."
+ (interactive)
+ (consult--read
+ (consult--global-mark-candidates
+ (or markers global-mark-ring))
+ :prompt "Go to global mark: "
+ ;; Despite `consult-global-mark' formatting the candidates in grep-like
+ ;; style, we are not using the `consult-grep' category, since the candidates
+ ;; have location markers attached.
+ :category 'consult-location
+ :sort nil
+ :require-match t
+ :lookup #'consult--lookup-location
+ :history '(:input consult--line-history)
+ :add-history (thing-at-point 'symbol)
+ :state (consult--jump-state)))
+
+;;;;; Command: consult-line
+
+(defun consult--line-candidates (top curr-line)
+ "Return list of line candidates.
+Start from top if TOP non-nil.
+CURR-LINE is the current line number."
+ (consult--forbid-minibuffer)
+ (consult--fontify-all)
+ (let* ((buffer (current-buffer))
+ (line (line-number-at-pos (point-min) consult-line-numbers-widen))
+ default-cand candidates)
+ (consult--each-line beg end
+ (unless (looking-at-p "^\\s-*$")
+ (push (consult--location-candidate
+ (consult--buffer-substring beg end)
+ (cons buffer beg) line line)
+ candidates)
+ (when (and (not default-cand) (>= line curr-line))
+ (setq default-cand candidates)))
+ (cl-incf line))
+ (unless candidates
+ (user-error "No lines"))
+ (nreverse
+ (if (or top (not default-cand))
+ candidates
+ (let ((before (cdr default-cand)))
+ (setcdr default-cand nil)
+ (nconc before candidates))))))
+
+(defun consult--line-point-placement (selected candidates highlighted &rest ignored-faces)
+ "Find point position on matching line.
+SELECTED is the currently selected candidate.
+CANDIDATES is the list of candidates.
+HIGHLIGHTED is the highlighted string to determine the match position.
+IGNORED-FACES are ignored when determining the match position."
+ (when-let (pos (consult--lookup-location selected candidates))
+ (if highlighted
+ (let* ((matches (apply #'consult--point-placement highlighted 0 ignored-faces))
+ (dest (+ pos (car matches))))
+ ;; Only create a new marker when jumping across buffers (for example
+ ;; `consult-line-multi'). Avoid creating unnecessary markers, when
+ ;; scrolling through candidates, since creating markers is not free.
+ (when (and (markerp pos) (not (eq (marker-buffer pos) (current-buffer))))
+ (setq dest (move-marker (make-marker) dest (marker-buffer pos))))
+ (cons dest (cdr matches)))
+ pos)))
+
+(defun consult--line-match (selected candidates input &rest _)
+ "Lookup position of match.
+SELECTED is the currently selected candidate.
+CANDIDATES is the list of candidates.
+INPUT is the input string entered by the user."
+ (consult--line-point-placement selected candidates
+ (and (not (string-blank-p input))
+ (car (consult--completion-filter
+ input
+ (list (substring-no-properties selected))
+ 'consult-location 'highlight)))
+ 'completions-first-difference))
+
+;;;###autoload
+(defun consult-line (&optional initial start)
+ "Search for a matching line.
+
+Depending on the setting `consult-point-placement' the command
+jumps to the beginning or the end of the first match on the line
+or the line beginning. The default candidate is the non-empty
+line next to point. This command obeys narrowing. Optional
+INITIAL input can be provided. The search starting point is
+changed if the START prefix argument is set. The symbol at point
+and the last `isearch-string' is added to the future history."
+ (interactive (list nil (not (not current-prefix-arg))))
+ (let* ((curr-line (line-number-at-pos (point) consult-line-numbers-widen))
+ (top (not (eq start consult-line-start-from-top)))
+ (candidates (consult--slow-operation "Collecting lines..."
+ (consult--line-candidates top curr-line))))
+ (consult--read
+ candidates
+ :prompt (if top "Go to line from top: " "Go to line: ")
+ :annotate (consult--line-prefix curr-line)
+ :category 'consult-location
+ :sort nil
+ :require-match t
+ ;; Always add last `isearch-string' to future history
+ :add-history (list (thing-at-point 'symbol) isearch-string)
+ :history '(:input consult--line-history)
+ :lookup #'consult--line-match
+ :default (car candidates)
+ ;; Add `isearch-string' as initial input if starting from Isearch
+ :initial (or initial
+ (and isearch-mode
+ (prog1 isearch-string (isearch-done))))
+ :state (consult--location-state candidates))))
+
+;;;;; Command: consult-line-multi
+
+(defun consult--line-multi-match (selected candidates &rest _)
+ "Lookup position of match.
+SELECTED is the currently selected candidate.
+CANDIDATES is the list of candidates."
+ (consult--line-point-placement selected candidates
+ (car (member selected candidates))))
+
+(defun consult--line-multi-group (cand transform)
+ "Group function used by `consult-line-multi'.
+If TRANSFORM non-nil, return transformed CAND, otherwise return title."
+ (if transform cand
+ (let* ((marker (car (get-text-property 0 'consult-location cand)))
+ (buf (if (consp marker)
+ (car marker) ;; Handle cheap marker
+ (marker-buffer marker))))
+ (if buf (buffer-name buf) "Dead buffer"))))
+
+(defun consult--line-multi-candidates (buffers input callback)
+ "Collect matching candidates from multiple buffers.
+INPUT is the user input which should be matched.
+BUFFERS is the list of buffers.
+CALLBACK receives the candidates."
+ (pcase-let ((`(,regexps . ,hl) (consult--compile-regexp input 'emacs completion-ignore-case))
+ (candidates nil)
+ (cand-idx 0))
+ (when regexps
+ (dolist (buf buffers)
+ (with-current-buffer buf
+ (save-excursion
+ (let ((line (line-number-at-pos (point-min) consult-line-numbers-widen)))
+ (goto-char (point-min))
+ (while (and (not (eobp))
+ (save-excursion (re-search-forward (car regexps) nil t)))
+ (cl-incf line (consult--count-lines (match-beginning 0)))
+ (let ((bol (pos-bol))
+ (eol (pos-eol)))
+ (goto-char bol)
+ (when (and (not (looking-at-p "^\\s-*$"))
+ (cl-loop for r in (cdr regexps) always
+ (progn
+ (goto-char bol)
+ (re-search-forward r eol t))))
+ (push (consult--location-candidate
+ (funcall hl (buffer-substring-no-properties bol eol))
+ (cons buf bol) (1- line) cand-idx)
+ candidates)
+ (cl-incf cand-idx))
+ (goto-char (1+ eol)))))))
+ (funcall callback (nreverse candidates))
+ (setq candidates nil)))))
+
+;;;###autoload
+(defun consult-line-multi (query &optional initial)
+ "Search for a matching line in multiple buffers.
+
+By default search across all project buffers. If the prefix
+argument QUERY is non-nil, all buffers are searched. Optional
+INITIAL input can be provided. The symbol at point and the last
+`isearch-string' is added to the future history. In order to
+search a subset of buffers, QUERY can be set to a plist according
+to `consult--buffer-query'."
+ (interactive "P")
+ (unless (keywordp (car-safe query))
+ (setq query (list :sort 'alpha-current :directory (and (not query) 'project))))
+ (pcase-let* ((`(,prompt . ,buffers) (consult--buffer-query-prompt "Go to line" query))
+ (collection (consult--dynamic-collection
+ (apply-partially #'consult--line-multi-candidates
+ buffers))))
+ (consult--read
+ collection
+ :prompt prompt
+ :annotate (consult--line-prefix)
+ :category 'consult-location
+ :sort nil
+ :require-match t
+ ;; Always add last Isearch string to future history
+ :add-history (delq nil (list (thing-at-point 'symbol) isearch-string))
+ :history '(:input consult--line-multi-history)
+ :lookup #'consult--line-multi-match
+ ;; Add `isearch-string' as initial input if starting from Isearch
+ :initial (or initial
+ (and isearch-mode
+ (prog1 isearch-string (isearch-done))))
+ :state (consult--location-state (lambda () (funcall collection nil)))
+ :group #'consult--line-multi-group)))
+
+;;;;; Command: consult-keep-lines
+
+(defun consult--keep-lines-state (filter)
+ "State function for `consult-keep-lines' with FILTER function."
+ (let ((font-lock-orig font-lock-mode)
+ (whitespace-orig (bound-and-true-p whitespace-mode))
+ (hl-line-orig (bound-and-true-p hl-line-mode))
+ (point-orig (point))
+ lines content-orig replace last-input)
+ (if (use-region-p)
+ (save-restriction
+ ;; Use the same behavior as `keep-lines'.
+ (let ((rbeg (region-beginning))
+ (rend (save-excursion
+ (goto-char (region-end))
+ (unless (or (bolp) (eobp))
+ (forward-line 0))
+ (point))))
+ (consult--fontify-region rbeg rend)
+ (narrow-to-region rbeg rend)
+ (consult--each-line beg end
+ (push (consult--buffer-substring beg end) lines))
+ (setq content-orig (buffer-string)
+ replace (lambda (content &optional pos)
+ (delete-region rbeg rend)
+ (insert-before-markers content)
+ (goto-char (or pos rbeg))
+ (setq rend (+ rbeg (length content)))
+ (add-face-text-property rbeg rend 'region t)))))
+ (consult--fontify-all)
+ (setq content-orig (buffer-string)
+ replace (lambda (content &optional pos)
+ (delete-region (point-min) (point-max))
+ (insert content)
+ (goto-char (or pos (point-min)))))
+ (consult--each-line beg end
+ (push (consult--buffer-substring beg end) lines)))
+ (setq lines (nreverse lines))
+ (lambda (action input)
+ ;; Restoring content and point position
+ (when (and (eq action 'return) last-input)
+ ;; No undo recording, modification hooks, buffer modified-status
+ (with-silent-modifications (funcall replace content-orig point-orig)))
+ ;; Committing or new input provided -> Update
+ (when (and input ;; Input has been provided
+ (or
+ ;; Committing, but not with empty input
+ (and (eq action 'return) (not (string-match-p "\\`!? ?\\'" input)))
+ ;; Input has changed
+ (not (equal input last-input))))
+ (let ((filtered-content
+ (if (string-match-p "\\`!? ?\\'" input)
+ ;; Special case the empty input for performance.
+ ;; Otherwise it could happen that the minibuffer is empty,
+ ;; but the buffer has not been updated.
+ content-orig
+ (if (eq action 'return)
+ (apply #'concat (mapcan (lambda (x) (list x "\n"))
+ (funcall filter input lines)))
+ (while-no-input
+ ;; Heavy computation is interruptible if *not* committing!
+ ;; Allocate new string candidates since the matching function mutates!
+ (apply #'concat (mapcan (lambda (x) (list x "\n"))
+ (funcall filter input (mapcar #'copy-sequence lines)))))))))
+ (when (stringp filtered-content)
+ (when font-lock-mode (font-lock-mode -1))
+ (when (bound-and-true-p whitespace-mode) (whitespace-mode -1))
+ (when (bound-and-true-p hl-line-mode) (hl-line-mode -1))
+ (if (eq action 'return)
+ (atomic-change-group
+ ;; Disable modification hooks for performance
+ (let ((inhibit-modification-hooks t))
+ (funcall replace filtered-content)))
+ ;; No undo recording, modification hooks, buffer modified-status
+ (with-silent-modifications
+ (funcall replace filtered-content)
+ (setq last-input input))))))
+ ;; Restore modes
+ (when (eq action 'return)
+ (when hl-line-orig (hl-line-mode 1))
+ (when whitespace-orig (whitespace-mode 1))
+ (when font-lock-orig (font-lock-mode 1))))))
+
+;;;###autoload
+(defun consult-keep-lines (filter &optional initial)
+ "Select a subset of the lines in the current buffer with live preview.
+
+The selected lines are kept and the other lines are deleted. When called
+interactively, the lines selected are those that match the minibuffer input. In
+order to match the inverse of the input, prefix the input with `! '. When
+called from Elisp, the filtering is performed by a FILTER function. This
+command obeys narrowing.
+
+FILTER is the filter function.
+INITIAL is the initial input."
+ (interactive
+ (list (lambda (pattern cands)
+ ;; Use consult-location completion category when filtering lines
+ (consult--completion-filter-dispatch
+ pattern cands 'consult-location 'highlight))))
+ (consult--forbid-minibuffer)
+ (let ((ro buffer-read-only))
+ (unwind-protect
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (when ro
+ (consult--minibuffer-message
+ (substitute-command-keys
+ " [Unlocked read-only buffer. \\[minibuffer-keyboard-quit] to quit.]"))))
+ (setq buffer-read-only nil)
+ (consult--with-increased-gc
+ (consult--prompt
+ :prompt "Keep lines: "
+ :initial initial
+ :history 'consult--line-history
+ :state (consult--keep-lines-state filter))))
+ (setq buffer-read-only ro))))
+
+;;;;; Command: consult-focus-lines
+
+(defun consult--focus-lines-state (filter)
+ "State function for `consult-focus-lines' with FILTER function."
+ (let (lines overlays last-input pt-orig pt-min pt-max)
+ (save-excursion
+ (save-restriction
+ (if (not (use-region-p))
+ (consult--fontify-all)
+ (consult--fontify-region (region-beginning) (region-end))
+ (narrow-to-region
+ (region-beginning)
+ ;; Behave the same as `keep-lines'.
+ ;; Move to the next line.
+ (save-excursion
+ (goto-char (region-end))
+ (unless (or (bolp) (eobp))
+ (forward-line 0))
+ (point))))
+ (setq pt-orig (point) pt-min (point-min) pt-max (point-max))
+ (let ((i 0))
+ (consult--each-line beg end
+ ;; Use "\n" for empty lines, since we need a non-empty string to
+ ;; attach the text property to.
+ (let ((line (if (eq beg end) (char-to-string ?\n)
+ (buffer-substring-no-properties beg end))))
+ (put-text-property 0 1 'consult--focus-line (cons (cl-incf i) beg) line)
+ (push line lines)))
+ (setq lines (nreverse lines)))))
+ (lambda (action input)
+ ;; New input provided -> Update
+ (when (and input (not (equal input last-input)))
+ (let (new-overlays)
+ (pcase (while-no-input
+ (unless (string-match-p "\\`!? ?\\'" input) ;; Empty input.
+ (let* ((inhibit-quit (eq action 'return)) ;; Non interruptible, when quitting!
+ (not (string-prefix-p "! " input))
+ (stripped (string-remove-prefix "! " input))
+ (matches (funcall filter stripped lines))
+ (old-ind 0)
+ (block-beg pt-min)
+ (block-end pt-min))
+ (while old-ind
+ (let ((match (pop matches)) (ind nil) (beg pt-max) (end pt-max) prop)
+ (when match
+ (setq prop (get-text-property 0 'consult--focus-line match)
+ ind (car prop)
+ beg (cdr prop)
+ ;; Check for empty lines, see above.
+ end (+ 1 beg (if (equal match "\n") 0 (length match)))))
+ (unless (eq ind (1+ old-ind))
+ (let ((a (if not block-beg block-end))
+ (b (if not block-end beg)))
+ (when (/= a b)
+ (push (consult--make-overlay a b 'invisible t) new-overlays)))
+ (setq block-beg beg))
+ (setq block-end end old-ind ind)))))
+ 'commit)
+ ('commit
+ (mapc #'delete-overlay overlays)
+ (setq last-input input overlays new-overlays))
+ (_ (mapc #'delete-overlay new-overlays)))))
+ (when (eq action 'return)
+ (cond
+ ((not input)
+ (mapc #'delete-overlay overlays)
+ (goto-char pt-orig))
+ ((equal input "")
+ (consult-focus-lines nil 'show)
+ (goto-char pt-orig))
+ (t
+ ;; Successfully terminated -> Remember invisible overlays
+ (setq consult--focus-lines-overlays
+ (nconc consult--focus-lines-overlays overlays))
+ ;; move point past invisible
+ (goto-char (if-let (ov (and (invisible-p pt-orig)
+ (seq-find (lambda (ov) (overlay-get ov 'invisible))
+ (overlays-at pt-orig))))
+ (overlay-end ov)
+ pt-orig))))))))
+
+;;;###autoload
+(defun consult-focus-lines (filter &optional show initial)
+ "Hide or show lines using overlays.
+
+The selected lines are shown and the other lines hidden. When called
+interactively, the lines selected are those that match the minibuffer input. In
+order to match the inverse of the input, prefix the input with `! '. With
+optional prefix argument SHOW reveal the hidden lines. Alternatively the
+command can be restarted to reveal the lines. When called from Elisp, the
+filtering is performed by a FILTER function. This command obeys narrowing.
+
+FILTER is the filter function.
+INITIAL is the initial input."
+ (interactive
+ (list (lambda (pattern cands)
+ ;; Use consult-location completion category when filtering lines
+ (consult--completion-filter-dispatch
+ pattern cands 'consult-location nil))
+ current-prefix-arg))
+ (if show
+ (progn
+ (mapc #'delete-overlay consult--focus-lines-overlays)
+ (setq consult--focus-lines-overlays nil)
+ (message "All lines revealed"))
+ (consult--forbid-minibuffer)
+ (consult--with-increased-gc
+ (consult--prompt
+ :prompt
+ (if consult--focus-lines-overlays
+ "Focus on lines (RET to reveal): "
+ "Focus on lines: ")
+ :initial initial
+ :history 'consult--line-history
+ :state (consult--focus-lines-state filter)))))
+
+;;;;; Command: consult-goto-line
+
+(defun consult--goto-line-position (str msg)
+ "Transform input STR to line number.
+Print an error message with MSG function."
+ (save-match-data
+ (if (and str (string-match "\\`\\([[:digit:]]+\\):?\\([[:digit:]]*\\)\\'" str))
+ (let ((line (string-to-number (match-string 1 str)))
+ (col (string-to-number (match-string 2 str))))
+ (save-excursion
+ (save-restriction
+ (when consult-line-numbers-widen
+ (widen))
+ (goto-char (point-min))
+ (forward-line (1- line))
+ (goto-char (min (+ (point) col) (pos-eol)))
+ (point))))
+ (when (and str (not (equal str "")))
+ (funcall msg "Please enter a number."))
+ nil)))
+
+;;;###autoload
+(defun consult-goto-line (&optional arg)
+ "Read line number and jump to the line with preview.
+
+Enter either a line number to jump to the first column of the
+given line or line:column in order to jump to a specific column.
+Jump directly if a line number is given as prefix ARG. The
+command respects narrowing and the settings
+`consult-goto-line-numbers' and `consult-line-numbers-widen'."
+ (interactive "P")
+ (if arg
+ (call-interactively #'goto-line)
+ (consult--forbid-minibuffer)
+ (consult--local-let ((display-line-numbers consult-goto-line-numbers)
+ (display-line-numbers-widen consult-line-numbers-widen))
+ (while (if-let (pos (consult--goto-line-position
+ (consult--prompt
+ :prompt "Go to line: "
+ :history 'goto-line-history
+ :state
+ (let ((preview (consult--jump-preview)))
+ (lambda (action str)
+ (funcall preview action
+ (consult--goto-line-position str #'ignore)))))
+ #'consult--minibuffer-message))
+ (consult--jump pos)
+ t)))))
+
+;;;;; Command: consult-recent-file
+
+(defun consult--file-preview ()
+ "Create preview function for files."
+ (let ((open (consult--temporary-files))
+ (preview (consult--buffer-preview)))
+ (lambda (action cand)
+ (unless cand
+ (funcall open))
+ (funcall preview action
+ (and cand
+ (eq action 'preview)
+ (funcall open cand))))))
+
+(defun consult--file-action (file)
+ "Open FILE via `consult--buffer-action'."
+ ;; Try to preserve the buffer as is, if it has already been opened, for
+ ;; example in literal or raw mode.
+ (setq file (abbreviate-file-name (expand-file-name file)))
+ (consult--buffer-action (or (get-file-buffer file) (find-file-noselect file))))
+
+(consult--define-state file)
+
+;;;###autoload
+(defun consult-recent-file ()
+ "Find recent file using `completing-read'."
+ (interactive)
+ (find-file
+ (consult--read
+ (or
+ (mapcar #'consult--fast-abbreviate-file-name (bound-and-true-p recentf-list))
+ (user-error "No recent files, `recentf-mode' is %s"
+ (if recentf-mode "enabled" "disabled")))
+ :prompt "Find recent file: "
+ :sort nil
+ :require-match t
+ :category 'file
+ :state (consult--file-preview)
+ :history 'file-name-history)))
+
+;;;;; Command: consult-mode-command
+
+(defun consult--mode-name (mode)
+ "Return name part of MODE."
+ (replace-regexp-in-string
+ "global-\\(.*\\)-mode" "\\1"
+ (replace-regexp-in-string
+ "\\(-global\\)?-mode\\'" ""
+ (if (eq mode 'c-mode)
+ "cc"
+ (symbol-name mode))
+ 'fixedcase)
+ 'fixedcase))
+
+(defun consult--mode-command-candidates (modes)
+ "Extract commands from MODES.
+
+The list of features is searched for files belonging to the modes.
+From these files, the commands are extracted."
+ (let* ((case-fold-search)
+ (buffer (current-buffer))
+ (command-filter (consult--regexp-filter (seq-filter #'stringp consult-mode-command-filter)))
+ (feature-filter (seq-filter #'symbolp consult-mode-command-filter))
+ (minor-hash (consult--string-hash minor-mode-list))
+ (minor-local-modes (seq-filter (lambda (m)
+ (and (gethash m minor-hash)
+ (local-variable-if-set-p m)))
+ modes))
+ (minor-global-modes (seq-filter (lambda (m)
+ (and (gethash m minor-hash)
+ (not (local-variable-if-set-p m))))
+ modes))
+ (major-modes (seq-remove (lambda (m)
+ (gethash m minor-hash))
+ modes))
+ (major-paths-hash (consult--string-hash (mapcar #'symbol-file major-modes)))
+ (minor-local-paths-hash (consult--string-hash (mapcar #'symbol-file minor-local-modes)))
+ (minor-global-paths-hash (consult--string-hash (mapcar #'symbol-file minor-global-modes)))
+ (major-name-regexp (regexp-opt (mapcar #'consult--mode-name major-modes)))
+ (minor-local-name-regexp (regexp-opt (mapcar #'consult--mode-name minor-local-modes)))
+ (minor-global-name-regexp (regexp-opt (mapcar #'consult--mode-name minor-global-modes)))
+ (commands))
+ (dolist (feature load-history commands)
+ (when-let (name (alist-get 'provide feature))
+ (let* ((path (car feature))
+ (file (file-name-nondirectory path))
+ (key (cond
+ ((memq name feature-filter) nil)
+ ((or (gethash path major-paths-hash)
+ (string-match-p major-name-regexp file))
+ ?m)
+ ((or (gethash path minor-local-paths-hash)
+ (string-match-p minor-local-name-regexp file))
+ ?l)
+ ((or (gethash path minor-global-paths-hash)
+ (string-match-p minor-global-name-regexp file))
+ ?g))))
+ (when key
+ (dolist (cmd (cdr feature))
+ (let ((sym (cdr-safe cmd)))
+ (when (and (consp cmd)
+ (eq (car cmd) 'defun)
+ (commandp sym)
+ (not (get sym 'byte-obsolete-info))
+ (or (not read-extended-command-predicate)
+ (funcall read-extended-command-predicate sym buffer)))
+ (let ((name (symbol-name sym)))
+ (unless (string-match-p command-filter name)
+ (push (propertize name
+ 'consult--candidate sym
+ 'consult--type key)
+ commands))))))))))))
+
+;;;###autoload
+(defun consult-mode-command (&rest modes)
+ "Run a command from any of the given MODES.
+
+If no MODES are specified, use currently active major and minor modes."
+ (interactive)
+ (unless modes
+ (setq modes (cons major-mode
+ (seq-filter (lambda (m)
+ (and (boundp m) (symbol-value m)))
+ minor-mode-list))))
+ (let ((narrow `((?m . ,(format "Major: %s" major-mode))
+ (?l . "Local Minor")
+ (?g . "Global Minor"))))
+ (command-execute
+ (consult--read
+ (consult--mode-command-candidates modes)
+ :prompt "Mode command: "
+ :predicate
+ (lambda (cand)
+ (let ((key (get-text-property 0 'consult--type cand)))
+ (if consult--narrow
+ (= key consult--narrow)
+ (/= key ?g))))
+ :lookup #'consult--lookup-candidate
+ :group (consult--type-group narrow)
+ :narrow narrow
+ :require-match t
+ :history 'extended-command-history
+ :category 'command))))
+
+;;;;; Command: consult-yank
+
+(defun consult--read-from-kill-ring ()
+ "Open kill ring menu and return selected string."
+ ;; `current-kill' updates `kill-ring' with interprogram paste, see
+ ;; gh:minad/consult#443.
+ (current-kill 0)
+ ;; Do not specify a :lookup function in order to preserve completion-styles
+ ;; highlighting of the current candidate. We have to perform a final lookup to
+ ;; obtain the original candidate which may be propertized with yank-specific
+ ;; properties, like 'yank-handler.
+ (consult--lookup-member
+ (consult--read
+ (consult--remove-dups
+ (or (if yank-from-kill-ring-rotate
+ (append kill-ring-yank-pointer
+ (butlast kill-ring (length kill-ring-yank-pointer)))
+ kill-ring)
+ (user-error "Kill ring is empty")))
+ :prompt "Yank from kill-ring: "
+ :history t ;; disable history
+ :sort nil
+ :category 'kill-ring
+ :require-match t
+ :state
+ (consult--insertion-preview
+ (point)
+ ;; If previous command is yank, hide previously yanked string
+ (or (and (eq last-command 'yank) (mark t)) (point))))
+ kill-ring))
+
+;; Adapted from the Emacs `yank-from-kill-ring' function.
+;;;###autoload
+(defun consult-yank-from-kill-ring (string &optional arg)
+ "Select STRING from the kill ring and insert it.
+With prefix ARG, put point at beginning, and mark at end, like `yank' does.
+
+This command behaves like `yank-from-kill-ring', which also offers a
+`completing-read' interface to the `kill-ring'. Additionally the
+Consult version supports preview of the selected string."
+ (interactive (list (consult--read-from-kill-ring) current-prefix-arg))
+ (when string
+ (setq yank-window-start (window-start))
+ (push-mark)
+ (insert-for-yank string)
+ (setq this-command 'yank)
+ (when yank-from-kill-ring-rotate
+ (if-let (pos (seq-position kill-ring string))
+ (setq kill-ring-yank-pointer (nthcdr pos kill-ring))
+ (kill-new string)))
+ (when (consp arg)
+ ;; Swap point and mark like in `yank'.
+ (goto-char (prog1 (mark t)
+ (set-marker (mark-marker) (point) (current-buffer)))))))
+
+(put 'consult-yank-replace 'delete-selection 'yank)
+(put 'consult-yank-pop 'delete-selection 'yank)
+(put 'consult-yank-from-kill-ring 'delete-selection 'yank)
+
+;;;###autoload
+(defun consult-yank-pop (&optional arg)
+ "If there is a recent yank act like `yank-pop'.
+
+Otherwise select string from the kill ring and insert it.
+See `yank-pop' for the meaning of ARG.
+
+This command behaves like `yank-pop', which also offers a
+`completing-read' interface to the `kill-ring'. Additionally the
+Consult version supports preview of the selected string."
+ (interactive "*p")
+ (if (eq last-command 'yank)
+ (yank-pop (or arg 1))
+ (call-interactively #'consult-yank-from-kill-ring)))
+
+;; Adapted from the Emacs yank-pop function.
+;;;###autoload
+(defun consult-yank-replace (string)
+ "Select STRING from the kill ring.
+
+If there was no recent yank, insert the string.
+Otherwise replace the just-yanked string with the selected string."
+ (interactive (list (consult--read-from-kill-ring)))
+ (when string
+ (if (not (eq last-command 'yank))
+ (consult-yank-from-kill-ring string)
+ (let ((inhibit-read-only t)
+ (pt (point))
+ (mk (mark t)))
+ (setq this-command 'yank)
+ (funcall (or yank-undo-function 'delete-region) (min pt mk) (max pt mk))
+ (setq yank-undo-function nil)
+ (set-marker (mark-marker) pt (current-buffer))
+ (insert-for-yank string)
+ (set-window-start (selected-window) yank-window-start t)
+ (if (< pt mk)
+ (goto-char (prog1 (mark t)
+ (set-marker (mark-marker) (point) (current-buffer)))))))))
+
+;;;;; Command: consult-bookmark
+
+(defun consult--bookmark-preview ()
+ "Create preview function for bookmarks."
+ (let ((preview (consult--jump-preview))
+ (open (consult--temporary-files)))
+ (lambda (action cand)
+ (unless cand
+ (funcall open))
+ (funcall
+ preview action
+ ;; Only preview bookmarks with the default handler.
+ (when-let ((bm (and cand (eq action 'preview) (assoc cand bookmark-alist)))
+ (handler (or (bookmark-get-handler bm) #'bookmark-default-handler))
+ ((eq handler #'bookmark-default-handler))
+ (file (bookmark-get-filename bm))
+ (pos (bookmark-get-position bm))
+ (buf (funcall open file)))
+ (set-marker (make-marker) pos buf))))))
+
+(defun consult--bookmark-action (bm)
+ "Open BM via `consult--buffer-action'."
+ (bookmark-jump bm consult--buffer-display))
+
+(consult--define-state bookmark)
+
+(defun consult--bookmark-candidates ()
+ "Return bookmark candidates."
+ (bookmark-maybe-load-default-file)
+ (let ((narrow (cl-loop for (y _ . xs) in consult-bookmark-narrow nconc
+ (cl-loop for x in xs collect (cons x y)))))
+ (cl-loop for bm in bookmark-alist collect
+ (propertize (car bm)
+ 'consult--type
+ (alist-get
+ (or (bookmark-get-handler bm) #'bookmark-default-handler)
+ narrow)))))
+
+;;;###autoload
+(defun consult-bookmark (name)
+ "If bookmark NAME exists, open it, otherwise create a new bookmark with NAME.
+
+The command supports preview of file bookmarks and narrowing. See the
+variable `consult-bookmark-narrow' for the narrowing configuration."
+ (interactive
+ (list
+ (let ((narrow (cl-loop for (x y . _) in consult-bookmark-narrow collect (cons x y))))
+ (consult--read
+ (consult--bookmark-candidates)
+ :prompt "Bookmark: "
+ :state (consult--bookmark-preview)
+ :category 'bookmark
+ :history 'bookmark-history
+ ;; Add default names to future history.
+ ;; Ignore errors such that `consult-bookmark' can be used in
+ ;; buffers which are not backed by a file.
+ :add-history (ignore-errors (bookmark-prop-get (bookmark-make-record) 'defaults))
+ :group (consult--type-group narrow)
+ :narrow (consult--type-narrow narrow)))))
+ (bookmark-maybe-load-default-file)
+ (if (assoc name bookmark-alist)
+ (bookmark-jump name)
+ (bookmark-set name)))
+
+;;;;; Command: consult-complex-command
+
+;;;###autoload
+(defun consult-complex-command ()
+ "Select and evaluate command from the command history.
+
+This command can act as a drop-in replacement for `repeat-complex-command'."
+ (interactive)
+ (let* ((history (or (delete-dups (mapcar #'prin1-to-string command-history))
+ (user-error "There are no previous complex commands")))
+ (cmd (read (consult--read
+ history
+ :prompt "Command: "
+ :default (car history)
+ :sort nil
+ :history t ;; disable history
+ :category 'expression))))
+ ;; Taken from `repeat-complex-command'
+ (add-to-history 'command-history cmd)
+ (apply #'funcall-interactively
+ (car cmd)
+ (mapcar (lambda (e) (eval e t)) (cdr cmd)))))
+
+;;;;; Command: consult-history
+
+(defun consult--current-history ()
+ "Return the history and index variable relevant to the current buffer.
+If the minibuffer is active, the minibuffer history is returned,
+otherwise the history corresponding to the mode. There is a
+special case for `repeat-complex-command', for which the command
+history is used."
+ (cond
+ ;; In the minibuffer we use the current minibuffer history,
+ ;; which can be configured by setting `minibuffer-history-variable'.
+ ((minibufferp)
+ (when (eq minibuffer-history-variable t)
+ (user-error "Minibuffer history is disabled for `%s'" this-command))
+ (list (mapcar #'consult--tofu-strip
+ (if (eq minibuffer-history-variable 'command-history)
+ ;; If pressing "C-x M-:", i.e., `repeat-complex-command',
+ ;; we are instead querying the `command-history' and get a
+ ;; full s-expression. Alternatively you might want to use
+ ;; `consult-complex-command', which can also be bound to
+ ;; "C-x M-:"!
+ (mapcar #'prin1-to-string command-history)
+ (symbol-value minibuffer-history-variable)))))
+ ;; Otherwise we use a mode-specific history, see `consult-mode-histories'.
+ (t (let ((found (seq-find (lambda (h)
+ (and (derived-mode-p (car h))
+ (boundp (if (consp (cdr h)) (cadr h) (cdr h)))))
+ consult-mode-histories)))
+ (unless found
+ (user-error "No history configured for `%s', see `consult-mode-histories'"
+ major-mode))
+ (cons (symbol-value (cadr found)) (cddr found))))))
+
+;;;###autoload
+(defun consult-history (&optional history index bol)
+ "Insert string from HISTORY of current buffer.
+In order to select from a specific HISTORY, pass the history
+variable as argument. INDEX is the name of the index variable to
+update, if any. BOL is the function which jumps to the beginning
+of the prompt. See also `cape-history' from the Cape package."
+ (interactive)
+ (declare-function ring-elements "ring")
+ (pcase-let* ((`(,history ,index ,bol) (if history
+ (list history index bol)
+ (consult--current-history)))
+ (history (if (ring-p history) (ring-elements history) history))
+ (`(,beg . ,end)
+ (if (minibufferp)
+ (cons (minibuffer-prompt-end) (point-max))
+ (if bol
+ (save-excursion
+ (funcall bol)
+ (cons (point) (pos-eol)))
+ (cons (point) (point)))))
+ (str (consult--local-let ((enable-recursive-minibuffers t))
+ (consult--read
+ (or (consult--remove-dups history)
+ (user-error "History is empty"))
+ :prompt "History: "
+ :history t ;; disable history
+ :category ;; Report category depending on history variable
+ (and (minibufferp)
+ (pcase minibuffer-history-variable
+ ('extended-command-history 'command)
+ ('buffer-name-history 'buffer)
+ ('face-name-history 'face)
+ ('read-envvar-name-history 'environment-variable)
+ ('bookmark-history 'bookmark)
+ ('file-name-history 'file)))
+ :sort nil
+ :initial (buffer-substring-no-properties beg end)
+ :state (consult--insertion-preview beg end)))))
+ (delete-region beg end)
+ (when index
+ (set index (seq-position history str)))
+ (insert (substring-no-properties str))))
+
+;;;;; Command: consult-isearch-history
+
+(defun consult-isearch-forward (&optional reverse)
+ "Continue Isearch forward optionally in REVERSE."
+ (declare (completion ignore))
+ (interactive)
+ (consult--require-minibuffer)
+ (setq isearch-new-forward (not reverse) isearch-new-nonincremental nil)
+ (funcall (or (command-remapping #'exit-minibuffer) #'exit-minibuffer)))
+
+(defun consult-isearch-backward (&optional reverse)
+ "Continue Isearch backward optionally in REVERSE."
+ (declare (completion ignore))
+ (interactive)
+ (consult-isearch-forward (not reverse)))
+
+(defvar-keymap consult-isearch-history-map
+ :doc "Additional keymap used by `consult-isearch-history'."
+ "<remap> <isearch-forward>" #'consult-isearch-forward
+ "<remap> <isearch-backward>" #'consult-isearch-backward)
+
+(defun consult--isearch-history-candidates ()
+ "Return Isearch history candidates."
+ ;; Do not throw an error on empty history, in order to allow starting a
+ ;; search. We do not :require-match here.
+ (let ((history (if (eq t search-default-mode)
+ (append regexp-search-ring search-ring)
+ (append search-ring regexp-search-ring))))
+ (delete-dups
+ (mapcar
+ (lambda (cand)
+ ;; The search type can be distinguished via text properties.
+ (let* ((props (plist-member (text-properties-at 0 cand)
+ 'isearch-regexp-function))
+ (type (pcase (cadr props)
+ ((and 'nil (guard (not props))) ?r)
+ ('nil ?l)
+ ('word-search-regexp ?w)
+ ('isearch-symbol-regexp ?s)
+ ('char-fold-to-regexp ?c)
+ (_ ?u))))
+ ;; Disambiguate history items. The same string could
+ ;; occur with different search types.
+ (consult--tofu-append cand type)))
+ history))))
+
+(defconst consult--isearch-history-narrow
+ '((?c . "Char")
+ (?u . "Custom")
+ (?l . "Literal")
+ (?r . "Regexp")
+ (?s . "Symbol")
+ (?w . "Word")))
+
+;;;###autoload
+(defun consult-isearch-history ()
+ "Read a search string with completion from the Isearch history.
+
+This replaces the current search string if Isearch is active, and
+starts a new Isearch session otherwise."
+ (interactive)
+ (consult--forbid-minibuffer)
+ (let* ((isearch-message-function #'ignore)
+ (cursor-in-echo-area t) ;; Avoid cursor flickering
+ (candidates (consult--isearch-history-candidates)))
+ (unless isearch-mode (isearch-mode t))
+ (with-isearch-suspended
+ (setq isearch-new-string
+ (consult--read
+ candidates
+ :prompt "I-search: "
+ :category 'consult-isearch-history
+ :history t ;; disable history
+ :sort nil
+ :initial isearch-string
+ :keymap consult-isearch-history-map
+ :annotate
+ (lambda (cand)
+ (consult--annotate-align
+ cand
+ (alist-get (consult--tofu-get cand) consult--isearch-history-narrow)))
+ :group
+ (lambda (cand transform)
+ (if transform
+ cand
+ (alist-get (consult--tofu-get cand) consult--isearch-history-narrow)))
+ :lookup
+ (lambda (selected candidates &rest _)
+ (if-let (found (member selected candidates))
+ (substring (car found) 0 -1)
+ selected))
+ :state
+ (lambda (action cand)
+ (when (and (eq action 'preview) cand)
+ (setq isearch-string cand)
+ (isearch-update-from-string-properties cand)
+ (isearch-update)))
+ :narrow
+ (list :predicate
+ (lambda (cand) (= (consult--tofu-get cand) consult--narrow))
+ :keys consult--isearch-history-narrow))
+ isearch-new-message
+ (mapconcat 'isearch-text-char-description isearch-new-string "")))
+ ;; Setting `isearch-regexp' etc only works outside of `with-isearch-suspended'.
+ (unless (plist-member (text-properties-at 0 isearch-string) 'isearch-regexp-function)
+ (setq isearch-regexp t
+ isearch-regexp-function nil))))
+
+;;;;; Command: consult-minor-mode-menu
+
+(defun consult--minor-mode-candidates ()
+ "Return list of minor-mode candidate strings."
+ (mapcar
+ (pcase-lambda (`(,name . ,sym))
+ (propertize
+ name
+ 'consult--candidate sym
+ 'consult--minor-mode-narrow
+ (logior
+ (ash (if (local-variable-if-set-p sym) ?l ?g) 8)
+ (if (and (boundp sym) (symbol-value sym)) ?i ?o))
+ 'consult--minor-mode-group
+ (concat
+ (if (local-variable-if-set-p sym) "Local " "Global ")
+ (if (and (boundp sym) (symbol-value sym)) "On" "Off"))))
+ (nconc
+ ;; according to describe-minor-mode-completion-table-for-symbol
+ ;; the minor-mode-list contains *all* minor modes
+ (mapcar (lambda (sym) (cons (symbol-name sym) sym)) minor-mode-list)
+ ;; take the lighters from minor-mode-alist
+ (delq nil
+ (mapcar (pcase-lambda (`(,sym ,lighter))
+ (when (and lighter (not (equal "" lighter)))
+ (let (message-log-max)
+ (setq lighter (string-trim (format-mode-line lighter)))
+ (unless (string-blank-p lighter)
+ (cons lighter sym)))))
+ minor-mode-alist)))))
+
+(defconst consult--minor-mode-menu-narrow
+ '((?l . "Local")
+ (?g . "Global")
+ (?i . "On")
+ (?o . "Off")))
+
+;;;###autoload
+(defun consult-minor-mode-menu ()
+ "Enable or disable minor mode.
+
+This is an alternative to `minor-mode-menu-from-indicator'."
+ (interactive)
+ (call-interactively
+ (consult--read
+ (consult--minor-mode-candidates)
+ :prompt "Minor mode: "
+ :require-match t
+ :category 'minor-mode
+ :group
+ (lambda (cand transform)
+ (if transform cand (get-text-property 0 'consult--minor-mode-group cand)))
+ :narrow
+ (list :predicate
+ (lambda (cand)
+ (let ((narrow (get-text-property 0 'consult--minor-mode-narrow cand)))
+ (or (= (logand narrow 255) consult--narrow)
+ (= (ash narrow -8) consult--narrow))))
+ :keys
+ consult--minor-mode-menu-narrow)
+ :lookup #'consult--lookup-candidate
+ :history 'consult--minor-mode-menu-history)))
+
+;;;;; Command: consult-theme
+
+;;;###autoload
+(defun consult-theme (theme)
+ "Disable current themes and enable THEME from `consult-themes'.
+
+The command supports previewing the currently selected theme."
+ (interactive
+ (list
+ (let* ((regexp (consult--regexp-filter
+ (mapcar (lambda (x) (if (stringp x) x (format "\\`%s\\'" x)))
+ consult-themes)))
+ (avail-themes (seq-filter
+ (lambda (x) (string-match-p regexp (symbol-name x)))
+ (cons 'default (custom-available-themes))))
+ (saved-theme (car custom-enabled-themes)))
+ (consult--read
+ (mapcar #'symbol-name avail-themes)
+ :prompt "Theme: "
+ :require-match t
+ :category 'theme
+ :history 'consult--theme-history
+ :lookup (lambda (selected &rest _)
+ (setq selected (and selected (intern-soft selected)))
+ (or (and selected (car (memq selected avail-themes)))
+ saved-theme))
+ :state (lambda (action theme)
+ (pcase action
+ ('return (consult-theme (or theme saved-theme)))
+ ((and 'preview (guard theme)) (consult-theme theme))))
+ :default (symbol-name (or saved-theme 'default))))))
+ (when (eq theme 'default) (setq theme nil))
+ (unless (eq theme (car custom-enabled-themes))
+ (mapc #'disable-theme custom-enabled-themes)
+ (when theme
+ (if (custom-theme-p theme)
+ (enable-theme theme)
+ (load-theme theme :no-confirm)))))
+
+;;;;; Command: consult-buffer
+
+(defun consult--buffer-sort-alpha (buffers)
+ "Sort BUFFERS alphabetically, put starred buffers at the end."
+ (sort buffers
+ (lambda (x y)
+ (setq x (buffer-name x) y (buffer-name y))
+ (let ((a (and (length> x 0) (eq (aref x 0) ?*)))
+ (b (and (length> y 0) (eq (aref y 0) ?*))))
+ (if (eq a b)
+ (string< x y)
+ (not a))))))
+
+(defun consult--buffer-sort-alpha-current (buffers)
+ "Sort BUFFERS alphabetically, put current at the beginning."
+ (let ((buffers (consult--buffer-sort-alpha buffers))
+ (current (current-buffer)))
+ (if (memq current buffers)
+ (cons current (delq current buffers))
+ buffers)))
+
+(defun consult--buffer-sort-visibility (buffers)
+ "Sort BUFFERS by visibility."
+ (let ((current (car (memq (current-buffer) buffers))) visible)
+ (consult--keep! buffers
+ (unless (eq it current)
+ (if (get-buffer-window it 'visible)
+ (progn (push it visible) nil)
+ it)))
+ (nconc buffers (nreverse visible) (and current (list current)))))
+
+(defun consult--normalize-directory (dir)
+ "Normalize directory DIR.
+DIR can be project, nil or a path."
+ (cond
+ ((eq dir 'project) (consult--project-root))
+ (dir (expand-file-name dir))))
+
+(defun consult--buffer-query-prompt (prompt query)
+ "Return a list of buffers and create an appropriate prompt string.
+Return a pair of a prompt string and a list of buffers. PROMPT
+is the prefix of the prompt string. QUERY specifies the buffers
+to search and is passed to `consult--buffer-query'."
+ (let* ((dir (plist-get query :directory))
+ (ndir (consult--normalize-directory dir))
+ (buffers (apply #'consult--buffer-query :directory ndir query))
+ (count (length buffers)))
+ (cons (format "%s (%d buffer%s%s): " prompt count
+ (if (= count 1) "" "s")
+ (cond
+ ((and ndir (eq dir 'project))
+ (format ", Project %s" (consult--project-name ndir)))
+ (ndir (concat ", " (consult--left-truncate-file ndir)))
+ (t "")))
+ buffers)))
+
+(cl-defun consult--buffer-query (&key sort directory mode as predicate (filter t)
+ include (exclude consult-buffer-filter)
+ (buffer-list t))
+ "Query for a list of matching buffers.
+The function supports filtering by various criteria which are
+used throughout Consult. In particular it is the backbone of
+most `consult-buffer-sources'.
+DIRECTORY can either be the symbol project or a file name.
+SORT can be visibility, alpha or nil.
+FILTER can be either t, nil or invert.
+EXCLUDE is a list of regexps.
+INCLUDE is a list of regexps.
+MODE can be a mode or a list of modes to restrict the returned buffers.
+PREDICATE is a predicate function.
+BUFFER-LIST is the unfiltered list of buffers.
+AS is a conversion function."
+ (let ((root (consult--normalize-directory directory)))
+ (setq buffer-list (if (eq buffer-list t) (buffer-list) (copy-sequence buffer-list)))
+ (when sort
+ (setq buffer-list (funcall (intern (format "consult--buffer-sort-%s" sort)) buffer-list)))
+ (when (or filter mode as root)
+ (let ((exclude-re (consult--regexp-filter exclude))
+ (include-re (consult--regexp-filter include))
+ (case-fold-search))
+ (consult--keep! buffer-list
+ (and
+ (or (not mode)
+ (let ((mm (buffer-local-value 'major-mode it)))
+ (if (consp mode)
+ (seq-some (lambda (m) (provided-mode-derived-p mm m)) mode)
+ (provided-mode-derived-p mm mode))))
+ (pcase-exhaustive filter
+ ('nil t)
+ ((or 't 'invert)
+ (eq (eq filter t)
+ (and
+ (or (not exclude)
+ (not (string-match-p exclude-re (buffer-name it))))
+ (or (not include)
+ (not (not (string-match-p include-re (buffer-name it)))))))))
+ (or (not root)
+ (when-let (dir (buffer-local-value 'default-directory it))
+ (string-prefix-p root
+ (if (and (/= 0 (length dir)) (eq (aref dir 0) ?/))
+ dir
+ (expand-file-name dir)))))
+ (or (not predicate) (funcall predicate it))
+ (if as (funcall as it) it)))))
+ buffer-list))
+
+(defun consult--buffer-file-hash ()
+ "Return hash table of all buffer file names."
+ (consult--string-hash (consult--buffer-query :as #'buffer-file-name)))
+
+(defun consult--buffer-pair (buffer)
+ "Return a pair of name of BUFFER and BUFFER."
+ (cons (buffer-name buffer) buffer))
+
+(defun consult--buffer-preview ()
+ "Buffer preview function."
+ (let ((orig-buf (window-buffer (consult--original-window)))
+ (orig-prev (copy-sequence (window-prev-buffers)))
+ (orig-next (copy-sequence (window-next-buffers)))
+ (orig-bl (copy-sequence (frame-parameter nil 'buffer-list)))
+ (orig-bbl (copy-sequence (frame-parameter nil 'buried-buffer-list)))
+ other-win)
+ (lambda (action cand)
+ (pcase action
+ ('return
+ ;; Restore buffer list for the current tab
+ (set-frame-parameter nil 'buffer-list orig-bl)
+ (set-frame-parameter nil 'buried-buffer-list orig-bbl))
+ ('exit
+ (set-window-prev-buffers other-win orig-prev)
+ (set-window-next-buffers other-win orig-next))
+ ('preview
+ ;; Prevent opening the preview in another tab, since restoring the tab
+ ;; status is difficult and also costly.
+ (cl-letf* (((symbol-function #'display-buffer-in-tab) #'ignore)
+ ((symbol-function #'display-buffer-in-new-tab) #'ignore))
+ (when (and (eq consult--buffer-display #'switch-to-buffer-other-window)
+ (not other-win))
+ (switch-to-buffer-other-window orig-buf 'norecord)
+ (setq other-win (selected-window)))
+ (let ((win (or other-win (selected-window)))
+ (buf (or (and cand (get-buffer cand)) orig-buf)))
+ (when (and (window-live-p win) (buffer-live-p buf)
+ (not (buffer-match-p consult-preview-excluded-buffers buf)))
+ (with-selected-window win
+ (unless (or orig-prev orig-next)
+ (setq orig-prev (copy-sequence (window-prev-buffers))
+ orig-next (copy-sequence (window-next-buffers))))
+ (switch-to-buffer buf 'norecord))))))))))
+
+(defun consult--buffer-action (buffer &optional norecord)
+ "Switch to BUFFER via `consult--buffer-display' function.
+If NORECORD is non-nil, do not record the buffer switch in the buffer list."
+ (funcall consult--buffer-display buffer norecord))
+
+(consult--define-state buffer)
+
+(defvar consult--source-bookmark
+ `( :name "Bookmark"
+ :narrow ?m
+ :category bookmark
+ :face consult-bookmark
+ :history bookmark-history
+ :items ,#'bookmark-all-names
+ :state ,#'consult--bookmark-state)
+ "Bookmark source for `consult-buffer'.")
+
+(defvar consult--source-project-buffer
+ `( :name "Project Buffer"
+ :narrow ?b
+ :category buffer
+ :face consult-buffer
+ :history buffer-name-history
+ :state ,#'consult--buffer-state
+ :enabled ,(lambda () consult-project-function)
+ :items
+ ,(lambda ()
+ (when-let (root (consult--project-root))
+ (consult--buffer-query :sort 'visibility
+ :directory root
+ :as #'consult--buffer-pair))))
+ "Project buffer source for `consult-buffer'.")
+
+(defvar consult--source-project-recent-file
+ `( :name "Project File"
+ :narrow ?f
+ :category file
+ :face consult-file
+ :history file-name-history
+ :state ,#'consult--file-state
+ :new
+ ,(lambda (file)
+ (consult--file-action
+ (expand-file-name file (consult--project-root))))
+ :enabled
+ ,(lambda ()
+ (and consult-project-function
+ recentf-mode))
+ :items
+ ,(lambda ()
+ (when-let (root (consult--project-root))
+ (let ((len (length root))
+ (ht (consult--buffer-file-hash))
+ items)
+ (dolist (file (bound-and-true-p recentf-list) (nreverse items))
+ ;; Emacs 29 abbreviates file paths by default, see
+ ;; `recentf-filename-handlers'. I recommend to set
+ ;; `recentf-filename-handlers' to nil to avoid any slow down.
+ (unless (eq (aref file 0) ?/)
+ (let (file-name-handler-alist) ;; No Tramp slowdown please.
+ (setq file (expand-file-name file))))
+ (when (and (not (gethash file ht)) (string-prefix-p root file))
+ (let ((part (substring file len)))
+ (when (equal part "") (setq part "./"))
+ (push (cons part file) items))))))))
+ "Project file source for `consult-buffer'.")
+
+(defvar consult--source-project-root
+ `( :name "Project Root"
+ :narrow ?r
+ :category file
+ :face consult-file
+ :history file-name-history
+ :action ,(lambda (root)
+ (let ((default-directory root))
+ (call-interactively #'find-file)))
+ :items ,#'consult--project-known-roots)
+ "Known project root source.")
+
+(defvar consult--source-project-buffer-hidden
+ `( :hidden t :narrow ((?p . "Project") (?B . "Project Buffer"))
+ ,@consult--source-project-buffer)
+ "Like `consult--source-project-buffer' but hidden by default.")
+
+(defvar consult--source-project-recent-file-hidden
+ `( :hidden t :narrow ((?p . "Project") (?F . "Project File"))
+ ,@consult--source-project-recent-file)
+ "Like `consult--source-project-recent-file' but hidden by default.")
+
+(defvar consult--source-project-root-hidden
+ `( :hidden t :narrow ((?p . "Project") (?R . "Project Root"))
+ ,@consult--source-project-root)
+ "Like `consult--source-project-root' but hidden by default.")
+
+(defvar consult--source-hidden-buffer
+ `( :name "Hidden Buffer"
+ :narrow ?\s
+ :hidden t
+ :category buffer
+ :face consult-buffer
+ :history buffer-name-history
+ :action ,#'consult--buffer-action
+ :items
+ ,(lambda () (consult--buffer-query :sort 'visibility
+ :filter 'invert
+ :as #'consult--buffer-pair)))
+ "Hidden buffer source for `consult-buffer'.")
+
+(defvar consult--source-modified-buffer
+ `( :name "Modified Buffer"
+ :narrow ?*
+ :hidden t
+ :category buffer
+ :face consult-buffer
+ :history buffer-name-history
+ :state ,#'consult--buffer-state
+ :items
+ ,(lambda () (consult--buffer-query :sort 'visibility
+ :as #'consult--buffer-pair
+ :predicate
+ (lambda (buf)
+ (and (buffer-modified-p buf)
+ (buffer-file-name buf))))))
+ "Modified buffer source for `consult-buffer'.")
+
+(defvar consult--source-buffer
+ `( :name "Buffer"
+ :narrow ?b
+ :category buffer
+ :face consult-buffer
+ :history buffer-name-history
+ :state ,#'consult--buffer-state
+ :default t
+ :items
+ ,(lambda () (consult--buffer-query :sort 'visibility
+ :as #'consult--buffer-pair)))
+ "Buffer source for `consult-buffer'.")
+
+(defun consult--file-register-p (reg)
+ "Return non-nil if REG is a file register."
+ (memq (car-safe (cdr reg)) '(file-query file)))
+
+(autoload 'consult-register--candidates "consult-register")
+(defvar consult--source-file-register
+ `( :name "File Register"
+ :narrow (?r . "Register")
+ :category file
+ :state ,#'consult--file-state
+ :enabled ,(lambda () (seq-some #'consult--file-register-p register-alist))
+ :items ,(lambda () (consult-register--candidates #'consult--file-register-p)))
+ "File register source.")
+
+(defvar consult--source-recent-file
+ `( :name "File"
+ :narrow ?f
+ :category file
+ :face consult-file
+ :history file-name-history
+ :state ,#'consult--file-state
+ :new ,#'consult--file-action
+ :enabled ,(lambda () recentf-mode)
+ :items
+ ,(lambda ()
+ (let ((ht (consult--buffer-file-hash))
+ items)
+ (dolist (file (bound-and-true-p recentf-list) (nreverse items))
+ ;; Emacs 29 abbreviates file paths by default, see
+ ;; `recentf-filename-handlers'. I recommend to set
+ ;; `recentf-filename-handlers' to nil to avoid any slow down.
+ (unless (eq (aref file 0) ?/)
+ (let (file-name-handler-alist) ;; No Tramp slowdown please.
+ (setq file (expand-file-name file))))
+ (unless (gethash file ht)
+ (push (consult--fast-abbreviate-file-name file) items))))))
+ "Recent file source for `consult-buffer'.")
+
+;;;###autoload
+(defun consult-buffer (&optional sources)
+ "Enhanced `switch-to-buffer' command with support for virtual buffers.
+
+The command supports recent files, bookmarks, views and project files as
+virtual buffers. Buffers are previewed. Narrowing to buffers (b), files (f),
+bookmarks (m) and project files (p) is supported via the corresponding
+keys. In order to determine the project-specific files and buffers, the
+`consult-project-function' is used. The virtual buffer SOURCES
+default to `consult-buffer-sources'. See `consult--multi' for the
+configuration of the virtual buffer sources."
+ (interactive)
+ (let ((selected (consult--multi (or sources consult-buffer-sources)
+ :require-match
+ (confirm-nonexistent-file-or-buffer)
+ :prompt "Switch to: "
+ :history 'consult--buffer-history
+ :sort nil)))
+ ;; For non-matching candidates, fall back to buffer creation.
+ (unless (plist-get (cdr selected) :match)
+ (consult--buffer-action (car selected)))))
+
+(defmacro consult--with-project (&rest body)
+ "Ensure that BODY is executed with a project root."
+ ;; We have to work quite hard here to ensure that the project root is
+ ;; only overridden at the current recursion level. When entering a
+ ;; recursive minibuffer session, we should be able to still switch the
+ ;; project. But who does that? Working on the first level on project A
+ ;; and on the second level on project B and on the third level on project C?
+ ;; You mustn't be afraid to dream a little bigger, darling.
+ `(let ((consult-project-function
+ (let ((root (or (consult--project-root t) (user-error "No project found")))
+ (depth (recursion-depth))
+ (orig consult-project-function))
+ (lambda (may-prompt)
+ (if (= depth (recursion-depth))
+ root
+ (funcall orig may-prompt))))))
+ ,@body))
+
+;;;###autoload
+(defun consult-project-buffer ()
+ "Enhanced `project-switch-to-buffer' command with support for virtual buffers.
+The command may prompt you for a project directory if it is invoked from
+outside a project. See `consult-buffer' for more details."
+ (interactive)
+ (consult--with-project
+ (consult-buffer consult-project-buffer-sources)))
+
+;;;###autoload
+(defun consult-buffer-other-window ()
+ "Variant of `consult-buffer', switching to a buffer in another window."
+ (interactive)
+ (let ((consult--buffer-display #'switch-to-buffer-other-window))
+ (consult-buffer)))
+
+;;;###autoload
+(defun consult-buffer-other-frame ()
+ "Variant of `consult-buffer', switching to a buffer in another frame."
+ (interactive)
+ (let ((consult--buffer-display #'switch-to-buffer-other-frame))
+ (consult-buffer)))
+
+;;;###autoload
+(defun consult-buffer-other-tab ()
+ "Variant of `consult-buffer', switching to a buffer in another tab."
+ (interactive)
+ (let ((consult--buffer-display #'switch-to-buffer-other-tab))
+ (consult-buffer)))
+
+;;;;; Command: consult-grep
+
+(defun consult--grep-format (builder)
+ "Async function highlighting grep match results.
+BUILDER is the command line builder function."
+ (consult--async-transform-by-input
+ (lambda (input)
+ (let ((highlight (cdr (funcall builder input))))
+ (lambda (cands)
+ (let ((file "") (file-len 0) result)
+ (save-match-data
+ (dolist (str cands (nreverse result))
+ (when (and (string-match consult--grep-match-regexp str)
+ ;; Filter out empty context lines
+ (or (/= (aref str (match-beginning 3)) ?-)
+ (/= (match-end 0) (length str))))
+ ;; We share the file name across candidates to reduce
+ ;; the amount of allocated memory.
+ (unless (and (= file-len (- (match-end 1) (match-beginning 1)))
+ (eq t (compare-strings
+ file 0 file-len
+ str (match-beginning 1) (match-end 1) nil)))
+ (setq file (match-string 1 str)
+ file-len (length file)))
+ (let* ((line (match-string 2 str))
+ (ctx (= (aref str (match-beginning 3)) ?-))
+ (sep (if ctx "-" ":"))
+ (content (substring str (match-end 0)))
+ (line-len (length line)))
+ (when (and consult-grep-max-columns
+ (length> content consult-grep-max-columns))
+ (setq content (substring content 0 consult-grep-max-columns)))
+ (when highlight
+ (funcall highlight content))
+ (setq str (concat file sep line sep content))
+ ;; Store file name in order to avoid allocations in `consult--prefix-group'
+ (add-text-properties 0 file-len `(face consult-file consult--prefix-group ,file) str)
+ (put-text-property (1+ file-len) (+ 1 file-len line-len) 'face 'consult-line-number str)
+ (when ctx
+ (add-face-text-property (+ 2 file-len line-len) (length str) 'consult-grep-context 'append str))
+ (push str result)))))))))))
+
+(defun consult--grep-position (cand &optional find-file)
+ "Return the grep position marker for CAND.
+FIND-FILE is the file open function, defaulting to `find-file-noselect'."
+ (when cand
+ (let* ((file-end (next-single-property-change 0 'face cand))
+ (line-end (next-single-property-change (1+ file-end) 'face cand))
+ (matches (consult--point-placement cand (1+ line-end) 'consult-grep-context))
+ (file (substring-no-properties cand 0 file-end))
+ (line (string-to-number (substring-no-properties cand (+ 1 file-end) line-end))))
+ (when-let (pos (consult--marker-from-line-column
+ (funcall (or find-file #'consult--file-action) file)
+ line (or (car matches) 0)))
+ (cons pos (cdr matches))))))
+
+(defun consult--grep-state ()
+ "Grep state function."
+ (let ((open (consult--temporary-files))
+ (jump (consult--jump-state)))
+ (lambda (action cand)
+ (unless cand
+ (funcall open))
+ (funcall jump action (consult--grep-position
+ cand
+ (and (not (eq action 'return)) open))))))
+
+(defun consult--grep-exclude-args ()
+ "Produce grep exclude arguments.
+Take the variables `grep-find-ignored-directories' and
+`grep-find-ignored-files' into account."
+ (unless (boundp 'grep-find-ignored-files) (require 'grep))
+ (nconc (mapcar (lambda (s) (concat "--exclude=" s))
+ (bound-and-true-p grep-find-ignored-files))
+ (mapcar (lambda (s) (concat "--exclude-dir=" s))
+ (bound-and-true-p grep-find-ignored-directories))))
+
+(defun consult--grep (prompt make-builder dir initial)
+ "Run asynchronous grep.
+
+MAKE-BUILDER is the function that returns the command line
+builder function. DIR is a directory or a list of file or
+directories. PROMPT is the prompt string. INITIAL is initial
+input."
+ (pcase-let* ((`(,prompt ,paths ,dir) (consult--directory-prompt prompt dir))
+ (default-directory dir)
+ (builder (funcall make-builder paths)))
+ (consult--read
+ (consult--process-collection builder
+ :transform (consult--grep-format builder)
+ :file-handler t)
+ :prompt prompt
+ :lookup #'consult--lookup-member
+ :state (consult--grep-state)
+ :initial initial
+ :add-history (thing-at-point 'symbol)
+ :require-match t
+ :category 'consult-grep
+ :group #'consult--prefix-group
+ :history '(:input consult--grep-history)
+ :sort nil)))
+
+(defun consult--grep-lookahead-p (&rest cmd)
+ "Return t if grep CMD supports look-ahead."
+ (eq 0 (process-file-shell-command
+ (concat "echo xaxbx | "
+ (mapconcat #'shell-quote-argument `(,@cmd "^(?=.*b)(?=.*a)") " ")))))
+
+(defun consult--grep-make-builder (paths)
+ "Build grep command line and grep across PATHS."
+ (let* ((cmd (consult--build-args consult-grep-args))
+ (type (if (consult--grep-lookahead-p (car cmd) "-P") 'pcre 'extended)))
+ (lambda (input)
+ (pcase-let* ((`(,arg . ,opts) (consult--command-split input))
+ (flags (append cmd opts))
+ (ignore-case (or (member "-i" flags) (member "--ignore-case" flags))))
+ (if (or (member "-F" flags) (member "--fixed-strings" flags))
+ (cons (append cmd (list "-e" arg) opts paths)
+ (apply-partially #'consult--highlight-regexps
+ (list (regexp-quote arg)) ignore-case))
+ (pcase-let ((`(,re . ,hl) (consult--compile-regexp arg type ignore-case)))
+ (when re
+ (cons (append cmd
+ (list (if (eq type 'pcre) "-P" "-E") ;; perl or extended
+ "-e" (consult--join-regexps re type))
+ opts paths)
+ hl))))))))
+
+;;;###autoload
+(defun consult-grep (&optional dir initial)
+ "Search with `grep' for files in DIR where the content matches a regexp.
+
+The initial input is given by the INITIAL argument. DIR can be nil, a
+directory string or a list of file/directory paths. If `consult-grep'
+is called interactively with a prefix argument, the user can specify the
+directories or files to search in. Multiple directories or files must
+be separated by comma in the minibuffer, since they are read via
+`completing-read-multiple'. By default the project directory is used if
+`consult-project-function' is defined and returns non-nil. Otherwise
+the `default-directory' is searched. If the command is invoked with a
+double prefix argument (twice `C-u') the user is asked for a project, if
+not yet inside a project, or the current project is searched.
+
+The input string is split, the first part of the string (grep input) is
+passed to the asynchronous grep process and the second part of the
+string is passed to the completion-style filtering.
+
+The input string is split at a punctuation character, which is given as
+the first character of the input string. The format is similar to
+Perl-style regular expressions, e.g., /regexp/. Furthermore command
+line options can be passed to grep, specified behind --. The overall
+prompt input has the form `#async-input -- grep-opts#filter-string'.
+
+Note that the grep input string is transformed from Emacs regular
+expressions to Posix regular expressions. Always enter Emacs regular
+expressions at the prompt. `consult-grep' behaves like builtin Emacs
+search commands, e.g., Isearch, which take Emacs regular expressions.
+Furthermore the asynchronous input split into words, each word must
+match separately and in any order. See `consult--regexp-compiler' for
+the inner workings. In order to disable transformations of the grep
+input, adjust `consult--regexp-compiler' accordingly.
+
+Here we give a few example inputs:
+
+#alpha beta : Search for alpha and beta in any order.
+#alpha.*beta : Search for alpha before beta.
+#\\(alpha\\|beta\\) : Search for alpha or beta (Note Emacs syntax!)
+#word -- -C3 : Search for word, include 3 lines as context
+#first#second : Search for first, quick filter for second.
+
+The symbol at point is added to the future history."
+ (interactive "P")
+ (consult--grep "Grep" #'consult--grep-make-builder dir initial))
+
+;;;;; Command: consult-git-grep
+
+(defun consult--git-grep-make-builder (paths)
+ "Create grep command line builder given PATHS."
+ (let ((cmd (consult--build-args consult-git-grep-args)))
+ (lambda (input)
+ (pcase-let* ((`(,arg . ,opts) (consult--command-split input))
+ (flags (append cmd opts))
+ (ignore-case (or (member "-i" flags) (member "--ignore-case" flags))))
+ (if (or (member "-F" flags) (member "--fixed-strings" flags))
+ (cons (append cmd (list "-e" arg) opts paths)
+ (apply-partially #'consult--highlight-regexps
+ (list (regexp-quote arg)) ignore-case))
+ (pcase-let ((`(,re . ,hl) (consult--compile-regexp arg 'extended ignore-case)))
+ (when re
+ (cons (append cmd
+ (cdr (mapcan (lambda (x) (list "--and" "-e" x)) re))
+ opts paths)
+ hl))))))))
+
+;;;###autoload
+(defun consult-git-grep (&optional dir initial)
+ "Search with `git grep' for files in DIR with INITIAL input.
+See `consult-grep' for details."
+ (interactive "P")
+ (consult--grep "Git-grep" #'consult--git-grep-make-builder dir initial))
+
+;;;;; Command: consult-ripgrep
+
+(defun consult--ripgrep-make-builder (paths)
+ "Create ripgrep command line builder given PATHS."
+ (let* ((cmd (consult--build-args consult-ripgrep-args))
+ (type (if (consult--grep-lookahead-p (car cmd) "-P") 'pcre 'extended)))
+ (lambda (input)
+ (pcase-let* ((`(,arg . ,opts) (consult--command-split input))
+ (flags (append cmd opts))
+ (ignore-case
+ (and (not (or (member "-s" flags) (member "--case-sensitive" flags)))
+ (or (member "-i" flags) (member "--ignore-case" flags)
+ (and (or (member "-S" flags) (member "--smart-case" flags))
+ (let (case-fold-search)
+ ;; Case insensitive if there are no uppercase letters
+ (not (string-match-p "[[:upper:]]" arg))))))))
+ (if (or (member "-F" flags) (member "--fixed-strings" flags))
+ (cons (append cmd (list "-e" arg) opts paths)
+ (apply-partially #'consult--highlight-regexps
+ (list (regexp-quote arg)) ignore-case))
+ (pcase-let ((`(,re . ,hl) (consult--compile-regexp arg type ignore-case)))
+ (when re
+ (cons (append cmd (and (eq type 'pcre) '("-P"))
+ (list "-e" (consult--join-regexps re type))
+ opts paths)
+ hl))))))))
+
+;;;###autoload
+(defun consult-ripgrep (&optional dir initial)
+ "Search with `rg' for files in DIR with INITIAL input.
+See `consult-grep' for details."
+ (interactive "P")
+ (consult--grep "Ripgrep" #'consult--ripgrep-make-builder dir initial))
+
+;;;;; Command: consult-find
+
+(defun consult--find (prompt builder initial)
+ "Run find command in current directory.
+
+The function returns the selected file.
+The filename at point is added to the future history.
+
+BUILDER is the command line builder function.
+PROMPT is the prompt.
+INITIAL is initial input."
+ (consult--read
+ (consult--process-collection builder
+ :transform (consult--async-map (lambda (x) (string-remove-prefix "./" x)))
+ :highlight t :file-handler t) ;; allow tramp
+ :prompt prompt
+ :sort nil
+ :require-match t
+ :initial initial
+ :add-history (thing-at-point 'filename)
+ :category 'file
+ :history '(:input consult--find-history)))
+
+(defun consult--find-make-builder (paths)
+ "Build find command line, finding across PATHS."
+ (let* ((cmd (seq-mapcat (lambda (x)
+ (if (equal x ".") paths (list x)))
+ (consult--build-args consult-find-args)))
+ (type (if (eq 0 (process-file-shell-command
+ (concat (car cmd) " -regextype emacs -version")))
+ 'emacs 'basic)))
+ (lambda (input)
+ (pcase-let* ((`(,arg . ,opts) (consult--command-split input))
+ ;; ignore-case=t since -iregex is used below
+ (`(,re . ,hl) (consult--compile-regexp arg type t)))
+ (when re
+ (cons (append cmd
+ (cdr (mapcan
+ (lambda (x)
+ `("-and" "-iregex"
+ ,(format ".*%s.*"
+ ;; Replace non-capturing groups with capturing groups.
+ ;; GNU find does not support non-capturing groups.
+ (replace-regexp-in-string
+ "\\\\(\\?:" "\\(" x 'fixedcase 'literal))))
+ re))
+ opts)
+ hl))))))
+
+;;;###autoload
+(defun consult-find (&optional dir initial)
+ "Search for files with `find' in DIR.
+The file names must match the input regexp. INITIAL is the
+initial minibuffer input. See `consult-grep' for details
+regarding the asynchronous search and the arguments."
+ (interactive "P")
+ (pcase-let* ((`(,prompt ,paths ,dir) (consult--directory-prompt "Find" dir))
+ (default-directory dir)
+ (builder (consult--find-make-builder paths)))
+ (find-file (consult--find prompt builder initial))))
+
+;;;;; Command: consult-fd
+
+(defun consult--fd-make-builder (paths)
+ "Build find command line, finding across PATHS."
+ (let ((cmd (consult--build-args consult-fd-args)))
+ (lambda (input)
+ (pcase-let* ((`(,arg . ,opts) (consult--command-split input))
+ (flags (append cmd opts))
+ (ignore-case
+ (and (not (or (member "-s" flags) (member "--case-sensitive" flags)))
+ (or (member "-i" flags) (member "--ignore-case" flags)
+ (let (case-fold-search)
+ ;; Case insensitive if there are no uppercase letters
+ (not (string-match-p "[[:upper:]]" arg)))))))
+ (if (or (member "-F" flags) (member "--fixed-strings" flags))
+ (cons (append cmd (list arg) opts paths)
+ (apply-partially #'consult--highlight-regexps
+ (list (regexp-quote arg)) ignore-case))
+ (pcase-let ((`(,re . ,hl) (consult--compile-regexp arg 'pcre ignore-case)))
+ (when re
+ (cons (append cmd
+ (mapcan (lambda (x) `("--and" ,x)) re)
+ opts
+ (mapcan (lambda (x) `("--search-path" ,x)) paths))
+ hl))))))))
+
+;;;###autoload
+(defun consult-fd (&optional dir initial)
+ "Search for files with `fd' in DIR.
+The file names must match the input regexp. INITIAL is the
+initial minibuffer input. See `consult-grep' for details
+regarding the asynchronous search and the arguments."
+ (interactive "P")
+ (pcase-let* ((`(,prompt ,paths ,dir) (consult--directory-prompt "Fd" dir))
+ (default-directory dir)
+ (builder (consult--fd-make-builder paths)))
+ (find-file (consult--find prompt builder initial))))
+
+;;;;; Command: consult-locate
+
+(defun consult--locate-builder (input)
+ "Build command line from INPUT."
+ (pcase-let ((`(,arg . ,opts) (consult--command-split input)))
+ (unless (string-blank-p arg)
+ (cons (append (consult--build-args consult-locate-args)
+ (consult--split-escaped arg) opts)
+ (cdr (consult--default-regexp-compiler input 'basic t))))))
+
+;;;###autoload
+(defun consult-locate (&optional initial)
+ "Search with `locate' for files which match input given INITIAL input.
+
+The input is treated literally such that locate can take advantage of
+the locate database index. Regular expressions would often force a slow
+linear search through the entire database. The locate process is started
+asynchronously, similar to `consult-grep'. See `consult-grep' for more
+details regarding the asynchronous search."
+ (interactive)
+ (find-file (consult--find "Locate: " #'consult--locate-builder initial)))
+
+;;;;; Command: consult-man
+
+(defun consult--man-builder (input)
+ "Build command line from INPUT."
+ (pcase-let* ((`(,arg . ,opts) (consult--command-split input))
+ (`(,re . ,hl) (consult--compile-regexp arg 'extended t)))
+ (when re
+ (cons (append (consult--build-args consult-man-args)
+ (list (consult--join-regexps re 'extended))
+ opts)
+ hl))))
+
+(defun consult--man-format (lines)
+ "Format man candidates from LINES."
+ (let ((candidates))
+ (save-match-data
+ (dolist (str lines)
+ (when (string-match "\\`\\(.*?\\([^ ]+\\) *(\\([^,)]+\\)[^)]*).*?\\) +- +\\(.*\\)\\'" str)
+ (let* ((names (match-string 1 str))
+ (name (match-string 2 str))
+ (section (match-string 3 str))
+ (desc (match-string 4 str))
+ (cand (format "%s - %s" names desc)))
+ (add-text-properties 0 (length names)
+ (list 'face 'consult-file
+ 'consult-man (concat section " " name))
+ cand)
+ (push cand candidates)))))
+ (nreverse candidates)))
+
+(defun consult--man-preview ()
+ "Create preview function for man pages."
+ (let ((preview (consult--buffer-preview))
+ (orig (buffer-list))
+ buffers)
+ (lambda (action cand)
+ (unless cand
+ (pcase-dolist (`(,_ . ,buf) buffers)
+ (kill-buffer buf))
+ (setq buffers nil))
+ (let ((consult--buffer-display #'switch-to-buffer-other-window))
+ (funcall preview action
+ (and cand
+ (eq action 'preview)
+ (or (cdr (assoc cand buffers))
+ (let ((buf (consult--man-action cand t)))
+ (unless (memq buf orig)
+ (cl-callf consult--preview-add-buffer
+ buffers (cons cand buf)))
+ buf))))))))
+
+(defun consult--man-action (page &optional nodisplay)
+ "Create man PAGE buffer, do not display if NODISPLAY is non-nil."
+ (dlet ((Man-prefer-synchronous-call t)
+ (Man-notify-method (and (not nodisplay) 'aggressive)))
+ (let (inhibit-message message-log-max)
+ (with-current-buffer (man page)
+ (goto-char (point-min))
+ (current-buffer)))))
+
+(consult--define-state man)
+
+;;;###autoload
+(defun consult-man (&optional initial)
+ "Search for man page given INITIAL input.
+
+The input string is not preprocessed and passed literally to the
+underlying man commands. The man process is started asynchronously,
+similar to `consult-grep'. See `consult-grep' for more details regarding
+the asynchronous search."
+ (interactive)
+ (consult--read
+ (consult--process-collection #'consult--man-builder
+ :transform (consult--async-transform #'consult--man-format)
+ :highlight t)
+ :prompt "Manual entry: "
+ :require-match t
+ :category 'consult-man
+ :state (consult--man-state)
+ :lookup (apply-partially #'consult--lookup-prop 'consult-man)
+ :initial initial
+ :add-history (thing-at-point 'symbol)
+ :history '(:input consult--man-history)))
+
+;;;; Preview at point in completions buffers
+
+(define-minor-mode consult-preview-at-point-mode
+ "Preview minor mode for *Completions* buffers.
+When moving around in the *Completions* buffer, the candidate at point is
+automatically previewed."
+ :group 'consult
+ (if consult-preview-at-point-mode
+ (add-hook 'post-command-hook #'consult-preview-at-point nil 'local)
+ (remove-hook 'post-command-hook #'consult-preview-at-point 'local)))
+
+(defun consult-preview-at-point ()
+ "Preview candidate at point in *Completions* buffer."
+ (interactive)
+ (when-let ((win (active-minibuffer-window))
+ (buf (window-buffer win))
+ (fun (buffer-local-value 'consult--preview-function buf)))
+ (funcall fun)))
+
+;;;; Integration with completion systems
+
+;;;;; Integration: Default *Completions*
+
+(defun consult--default-completion-minibuffer-candidate ()
+ "Return current minibuffer candidate from default completion system or Icomplete."
+ (when (and (minibufferp)
+ (eq completing-read-function #'completing-read-default))
+ (let ((content (minibuffer-contents-no-properties)))
+ ;; When the current minibuffer content matches a candidate, return it!
+ (if (test-completion content
+ minibuffer-completion-table
+ minibuffer-completion-predicate)
+ content
+ ;; Return the full first candidate of the sorted completion list.
+ (when-let ((completions (completion-all-sorted-completions)))
+ (concat
+ (substring content 0 (or (cdr (last completions)) 0))
+ (car completions)))))))
+
+(defun consult--default-completion-list-candidate ()
+ "Return current candidate at point from completions buffer."
+ ;; See feature request bug#74408 for `completion-list-candidate-at-point'.
+ (let (beg)
+ (when (and
+ (derived-mode-p 'completion-list-mode)
+ (cond
+ ((and (not (eobp)) (get-text-property (point) 'completion--string))
+ (setq beg (1+ (point))))
+ ((and (not (bobp)) (get-text-property (1- (point)) 'completion--string))
+ (setq beg (point)))))
+ (get-text-property (previous-single-property-change beg 'completion--string)
+ 'completion--string))))
+
+;;;;; Integration: Vertico
+
+(defvar vertico--input)
+
+(defun consult--vertico-candidate ()
+ "Return current candidate for Consult preview."
+ (declare-function vertico--candidate "ext:vertico")
+ (and vertico--input (vertico--candidate 'highlight)))
+
+(defun consult--vertico-refresh ()
+ "Refresh completion UI."
+ (declare-function vertico--exhibit "ext:vertico")
+ (when vertico--input
+ (setq vertico--input t)
+ (vertico--exhibit)))
+
+(with-eval-after-load 'vertico
+ (add-hook 'consult--completion-candidate-hook #'consult--vertico-candidate)
+ (add-hook 'consult--completion-refresh-hook #'consult--vertico-refresh)
+ (define-key consult-async-map [remap vertico-insert] 'vertico-next-group))
+
+;;;;; Integration: Mct
+
+(with-eval-after-load 'mct (add-hook 'consult--completion-refresh-hook
+ 'mct--live-completions-refresh))
+
+;;;;; Integration: Icomplete
+
+(defun consult--icomplete-refresh ()
+ "Refresh icomplete view."
+ (defvar icomplete-mode)
+ (declare-function icomplete-exhibit "icomplete")
+ (when icomplete-mode
+ (let ((top (car completion-all-sorted-completions)))
+ (completion--flush-all-sorted-completions)
+ ;; force flushing, otherwise narrowing is broken!
+ (setq completion-all-sorted-completions nil)
+ (when top
+ (let* ((completions (completion-all-sorted-completions))
+ (last (last completions))
+ (before)) ;; completions before top
+ ;; warning: completions is an improper list
+ (while (consp completions)
+ (if (equal (car completions) top)
+ (progn
+ (setcdr last (append (nreverse before) (cdr last)))
+ (setq completion-all-sorted-completions completions
+ completions nil))
+ (push (car completions) before)
+ (setq completions (cdr completions)))))))
+ (icomplete-exhibit)))
+
+(with-eval-after-load 'icomplete
+ (add-hook 'consult--completion-refresh-hook #'consult--icomplete-refresh))
+
+(provide 'consult)
+;;; consult.el ends here