diff options
author | noa | 2025-02-17 00:01:51 +0800 |
---|---|---|
committer | noa | 2025-02-17 00:01:51 +0800 |
commit | 3b8b726ced8d5008147a7da336ce6f2f86e1fe2d (patch) | |
tree | 6c0b1e88b508ceb7d0abad968222358fe3dbe95d /emacs/site-lisp | |
parent | 91e3f9bb49169f70b92847e18029bb50e964b00e (diff) |
Add some helper packages to site-lisp
Diffstat (limited to 'emacs/site-lisp')
-rw-r--r-- | emacs/site-lisp/consult-recoll.el | 333 | ||||
-rw-r--r-- | emacs/site-lisp/consult.el | 5551 |
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 |