From 8c4e09dff83847ac7f07bf1da7751e9328006c4d Mon Sep 17 00:00:00 2001 From: Jack Jamison Date: Thu, 30 Jul 2026 20:09:00 -0400 Subject: actual final changes and get rid of junk in lisp dir actually works fine --- .config/emacs/lisp/minadstack/consult.el | 5739 ------------------------------ 1 file changed, 5739 deletions(-) delete mode 100644 .config/emacs/lisp/minadstack/consult.el (limited to '.config/emacs/lisp/minadstack/consult.el') diff --git a/.config/emacs/lisp/minadstack/consult.el b/.config/emacs/lisp/minadstack/consult.el deleted file mode 100644 index d500c9c..0000000 --- a/.config/emacs/lisp/minadstack/consult.el +++ /dev/null @@ -1,5739 +0,0 @@ -;;; consult.el --- Search and navigate via completing-read -*- lexical-binding: t -*- - -;; Copyright (C) 2021-2026 Free Software Foundation, Inc. - -;; Author: Daniel Mendler and Consult contributors -;; Maintainer: Daniel Mendler -;; Created: 2020 -;; Version: 3.6 -;; Package-Requires: ((emacs "29.1") (compat "31")) -;; 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 . - -;;; Commentary: - -;; Consult implements a set of `consult-' 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 - "Search and navigate via `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 (* 1024 1024) - "Avoid whole-buffer fontification for buffers larger than this character limit. -This setting affects the command `consult-keep-lines'." - :type '(natnum :tag "Buffer size in characters")) - -(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-list-function #'buffer-list - "List of buffers to use for selection. -By default, the variable is set to the function `buffer-list', which -returns all buffers from all frames. Set it to -`consult--frame-buffer-list' to only use buffers belonging to the -current frame (or tab-bar tab). Alternatively use a custom function for -custom buffer isolation." - :type `(choice (const :tag "All buffers" ,#'buffer-list) - (const :tag "Frame/Tab buffers" ,#'consult--frame-buffer-list) - (function :tag "Custom function"))) - -(defcustom consult-buffer-sources - '(consult-source-buffer - consult-source-hidden-buffer - consult-source-modified-buffer - consult-source-other-buffer - consult-source-recent-file - consult-source-buffer-register - 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 (* 1024 1024) - "Files larger than this byte limit are previewed partially." - :type '(natnum :tag "File size in bytes")) - -(defcustom consult-preview-partial-chunk (* 10 1024) - "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 "Shell" eshell-bookmark-jump shell-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 :weight normal)) - "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-async-option - '((t :inherit warning :weight normal)) - "Face used to highlight asynchronous command options.") - -(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 warning :weight normal)) - "Face used to highlight line number prefixes after wrap around.") - -;;;; 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-list-candidate - #'consult--default-completion-minibuffer-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 - (list #'redisplay #'consult--default-completion-list-refresh) - "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 #x100000 - "Special character used to encode line suffixes for disambiguation. -We use characters in the Unicode PUA-B.") - -(defconst consult--tofu-range #xFFFE - "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 narrow 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.2 - "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'.") - -(defvar consult--focus-lines-indicator - (propertize - "FOCUS" 'face 'highlight - 'help-echo - "`consult-focus-lines': \\`mouse-1' or \\[consult-focus-lines] \\`RET' to reveal." - 'local-map - (define-keymap " " - (lambda () (interactive) (consult-focus-lines nil 'reveal)))) - "Mode line indicator displayed if `consult-focus-lines' is active.") - -;;;; 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 "")) - (setq str (substring-no-properties str)) - ;; Find first option - (when (string-match "\\(?:\\`\\| \\)-" str) - (setq opts (substring str (1- (match-end 0))) - str (substring str 0 (match-beginning 0))) - (when (equal opts "-") - (setq opts ""))) - ;; Replace backslash-escaped dashes - (setq str (replace-regexp-in-string "\\(\\`\\| \\)\\\\-" "\\1-" str)) - ;; Options end with double dash - (when (string-match "\\(\\`\\| \\)--\\(?: \\|\\'\\)" opts) - (setq str (concat str " " (substring opts (match-end 0))) - opts (substring opts 0 (match-beginning 0)))) - ;; Use `split-string-shell-command' here instead of - ;; `split-string-and-unquote' since it handles more flexible input - - ;; double quoted strings, single quoted strings and escaped spaces. - (cons str (split-string-shell-command (string-trim opts)))))) - -(defmacro consult--keep! (list form) - "Evaluate FORM for every element of LIST and keep the non-nil results." - (declare (indent 1) (debug (gv-place body))) - (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)))) - (setf ,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) (debug (symbolp symbolp body))) - (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) (debug let)) - (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-name-handler-alist) ;; No Tramp interference please. - (file (directory-file-name (abbreviate-file-name file))) - (prefix nil)) - (when (string-match "\\`/\\([^/|:]+:[^/|:]*:\\)" file) - (setq prefix (propertize (match-string 1 file) 'face 'error) - file (if (= (match-end 0) (length 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 "Dirs 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))) - -(defsubst 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." - (declare (indent 0) (debug t)) - (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) (debug t)) - `(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) - (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)))))) - -(defsubst consult--copy-property (beg end str prop) - "Copy PROP from buffer region BEG to END to STR. -The string STR is modified." - (let ((pos beg)) - (while (< pos end) - (let ((next (next-single-property-change pos prop nil end)) - (val (get-text-property pos prop))) - (when val - (if (eq prop 'face) - (add-face-text-property (- pos beg) (- next beg) val t str) - (put-text-property (- pos beg) (- next beg) prop val str))) - (setq pos next))))) - -(defun consult--copy-faces (beg end str) - "Copy faces from buffer region BEG to END to STR. -The string STR is modified." - (consult--copy-property beg end str 'face) - (consult--copy-property beg end str 'invisible) - (consult--copy-property beg end str 'display)) - -(defun consult--line-fontify (&optional curr-line) - "Annotation function to fontify `consult-location' line and add line number. -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 (propertize before 'face 'consult-line-number-prefix))) - (lambda (cand) - (pcase-let* ((`(,pos . ,line) (get-text-property 0 'consult-location cand)) - (buf (when consult-fontify-preserve - (if (consp pos) - (car pos) - (and (markerp pos) (marker-buffer pos)))))) - (when (buffer-live-p buf) - (with-current-buffer buf - (goto-char (if (markerp pos) pos (cdr pos))) - (let ((beg (pos-bol)) - (end (pos-eol))) - ;; Only apply lazy highlighting if the buffer has not been changed. - (when (string-prefix-p (buffer-substring-no-properties beg end) cand) - (setq cand (copy-sequence cand)) - (consult--fontify-region beg end) - (consult--copy-faces beg end 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) - -(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 (buffer-substring-no-properties beg end))) - (when fontify (consult--fontify-region beg end)) - (consult--copy-faces beg end 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 suffix 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 Unicode PUA-B characters. This way accidental -;; matching is unlikely. -(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) - (decf (car match) pos) - (decf (cdr match) pos)) - (cons pos matches))) - -(defun consult--highlight-regexps (regexps ignore-case str) - "Highlight REGEXPS (or single regexp string) 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 (ensure-list 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) - -(defun consult--highlight-literals (literals ignore-case str) - "Highlight list of LITERALS or single literal string in STR. -Case insensitive if IGNORE-CASE is non-nil." - (consult--highlight-regexps (mapcar #'regexp-quote (ensure-list literals)) - ignore-case 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)) - ((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)) - (if-let* ((win (get-buffer-window buf))) - (select-window win 'norecord) - (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-f (preview-key state transform candidate save-input body) - "See `consult--with-preview' for documentation." - (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 body))) - (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) (debug t)) - `(consult--with-preview-f ,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 if 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) (debug (symbolp body))) - `(consult--with-async-f ,async (lambda (,async) ,@body))) - -(defun consult--with-async-f (async body) - "See `consult--with-async' for documentation." - (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 - (funcall body async) - (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 (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 (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) - (add-text-properties (+ end x) (+ end y) - '(face consult-async-split consult--split t rear-nonsticky t))) - (funcall sink input))) - (_ (funcall sink action)))))) - -(defun consult--async-options () - "Async function, which highlights commands options in the input string." - (lambda (sink) - (lambda (action) - (when (stringp action) - (save-match-data - (when-let* ((iend (save-excursion - (goto-char (minibuffer-prompt-end)) - (search-forward action nil t))) - (ibeg (- iend (length action)))) - (remove-list-of-text-properties ibeg iend '(face rear-nonsticky)) - (when-let* (((string-match "\\(?:\\`\\| \\)\\(-\\)" action)) - (beg (match-beginning 1)) - ((string-match "\\(?:\\`\\| \\)\\(--\\)\\(?: \\|\\'\\)\\|\\'" action)) - (end (or (match-end 1) (match-end 0)))) - (add-text-properties (+ ibeg beg) (+ ibeg end) - '( face consult-async-option - rear-nonsticky t)))))) - (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 ""))) - (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-options) - (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. - " " #'self-insert-command - ;; Remap Emacs 29 history and default completion for now - ;; (gh:minad/consult#613). - " " #'ignore - " " #'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))) - (decf pos)) - (when (< pos max) - (add-text-properties pos max '(invisible t rear-nonsticky t cursor-intangible t))))) - -(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 documentation." - (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)))) - ,@(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 command - keymap category initial narrow initial-narrow annotate - add-history 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. -COMMAND is used for customization, defaulting to `this-command.' -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'." - (ignore prompt predicate require-match history default keymap category - initial narrow initial-narrow add-history annotate state command - preview-key sort lookup group inherit-input-method async-wrap) - (apply #'consult--read-1 table - (consult--customize-args - options - :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 command) - "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. -COMMAND is used for customization, defaulting to `this-command.'" - (ignore prompt history add-history initial default command - keymap state preview-key transform inherit-input-method) - (apply #'consult--prompt-1 - (consult--customize-args - options - :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 (warn "consult-customize: %s is neither a 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 `:command' or `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-args (options &rest defaults) - "Get configuration from `consult--customize-alist' for the current command. -OPTIONS is the option plist, and DEFAULTS are default options which are -overridden by OPTIONS." - (append - (mapcar (lambda (x) (eval x 'lexical)) - (alist-get (or (plist-get options :command) this-command) - consult--customize-alist)) - (consult--plist-remove '(:command) options) - defaults)) - -;;;; 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))))))) - -(defun consult--in-region (start end table predicate) - "Internal `completion-in-region-function'. -The arguments START, END, TABLE and PREDICATE and -expected return value are as specified for `completion-in-region'." - (barf-if-buffer-read-only) - (let* ((initial (buffer-substring-no-properties start end)) - (metadata (completion-metadata initial table 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 table predicate - (if (<= start (point) end) - (- (point) start) - (length initial)) - metadata))) - ;; Normalize improper list - (when-let* ((last (last all))) - (setcdr last nil)) - (if (or (eq threshold t) (length< all (1+ (or threshold 1))) - (and completion-cycling completion-all-sorted-completions)) - (let (completion-auto-help) - (completion--in-region start end table predicate)) - ;; Wrap all annotation functions to ensure that they are executed - ;; in the original buffer. - (let* ((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)))))))) - (completion - (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 table) - :command #'consult-completion-in-region - :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)))) - (completion--replace start end 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 table predicate) t) - 'finished 'exact))) - t)))) - -;;;###autoload -(defun consult-completion-in-region (start end table predicate) - "Use minibuffer completion as the UI for `completion-at-point'. - -The arguments START, END, TABLE and PREDICATE and expected return value -are as specified for `completion-in-region'. Use this function as a -value for `completion-in-region-function'." - (if (and (or (bound-and-true-p vertico-mode) (bound-and-true-p icomplete-mode)) - (not (eq table minibuffer-completion-table))) - (consult--in-region start end table predicate) - (completion--in-region start end table predicate))) - -;;;;; Command: consult-outline - -(defun consult--outline-candidates () - "Return list of outline heading strings with position attached." - (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))) - (incf line (consult--count-lines (match-beginning 0))) - (push (consult--location-candidate - (buffer-substring-no-properties (pos-bol) (pos-eol)) - (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-fontify) - :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) - (width (length (number-to-string (line-number-at-pos - (point-max) - consult-line-numbers-widen)))) - (fmt (format #("%%%dd %%s%%s" 0 6 (face consult-line-number-prefix)) width))) - (save-excursion - (dolist (marker markers) - (when-let* ((pos (marker-position marker)) - ((and (eq (marker-buffer marker) (current-buffer)) - (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'. - (let* ((line (line-number-at-pos pos consult-line-numbers-widen)) - (cand (format fmt line (consult--line-with-mark marker) (consult--tofu-encode marker)))) - (put-text-property 0 width 'consult-strip t cand) - (put-text-property 0 (length cand) 'consult-location (cons marker line) cand) - (push cand 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: " - :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)) - ((not (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) - (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 - (buffer-substring-no-properties beg end) - (cons buffer beg) line line) - candidates) - (when (and (not default-cand) (>= line curr-line)) - (setq default-cand candidates))) - (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-fontify 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))) - (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) - (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-fontify) - :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))))) - ;; Font-locking is lazy, i.e., if a line has not been looked at yet, the - ;; line is not font-locked. Therefore we have to enforce slow font-locking - ;; now. In order to prevent is hang-up we check the region size against - ;; `consult-fontify-max-size'. - (when (< (- (point-max) (point-min)) consult-fontify-max-size) - (consult--fontify-region (point-min) (point-max))) - (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) - "Filter a subset of the lines in the current buffer with live preview. - -The filtered 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. If the buffer is narrowed to a region, the -command only acts on this region. See also `consult-focus-lines' which -uses overlays to display only matching lines, but does not modify the -buffer. - -FILTER is the filter function, called for each line. -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 - (when (use-region-p) - (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 (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 - (cl-callf 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) - "Show only matching lines using overlays. - -In contrast to `consult-keep-lines' the buffer is not modified. The -FILTER selects the lines which are shown. 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 -rerun the command and exit the minibuffer directly without input to -reveal the lines. When called from Elisp, the filtering is performed by -a FILTER function. If the buffer is narrowed to a region, the command -only acts on this region. - -FILTER is the filter function, called for each line. -SHOW is the prefix argument, if non-nil reveal all hidden lines. -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)))) - (cl-callf2 assq-delete-all 'consult--focus-lines-overlays mode-line-misc-info) - (when (and consult--focus-lines-overlays consult--focus-lines-indicator) - (push `(consult--focus-lines-overlays ,consult--focus-lines-indicator) - mode-line-misc-info))) - -;;;;; 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 - :lookup #'consult--lookup-member - :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) - :lookup #'consult--lookup-member - :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'." - " " #'consult-isearch-forward - " " #'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) - (with-selected-window (or (active-minibuffer-window) - (selected-window)) - (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 - (unless (and (memq theme custom-known-themes) (get theme 'theme-settings)) - (load-theme theme 'no-confirm 'no-enable)) - (if (and (memq theme custom-known-themes) (get theme 'theme-settings)) - (enable-theme theme) - (consult--minibuffer-message "%s is not a valid theme" theme))))) - -;;;;; 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))) - -(defun consult--frame-buffer-list () - "List of buffers belonging to the current frame or tab." - (let ((buffers (append (frame-parameter nil 'buffer-list) - (reverse (frame-parameter nil 'buried-buffer-list))))) - ;; Sometimes visible buffers are not registered in the buffer-list. - (cl-loop for win in (window-list) for buf = (window-buffer win) - unless (memq buf buffers) do (push buf buffers)) - buffers)) - -(cl-defun consult--buffer-query ( &key sort directory mode as predicate (filter t) - include (exclude consult-buffer-filter) - (buffer-list consult-buffer-list-function)) - "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 a function or a list of buffers. -AS is a conversion function." - (let ((root (consult--normalize-directory directory))) - (setq buffer-list (cond - ((functionp buffer-list) (funcall buffer-list)) - ((listp buffer-list) (copy-sequence buffer-list)) - (t (buffer-list)))) - (when (or filter mode 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)) - it)))) - (when sort - (setq buffer-list (funcall (intern (format "consult--buffer-sort-%s" sort)) buffer-list))) - (when as - (cl-loop for it in-ref buffer-list do (setf it (funcall as 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 - :buffer-list t))) - "Hidden buffer source for `consult-buffer'. -The source is hidden by default and can be summoned via its narrow key. -All buffers are taken into account, i.e., the entire `buffer-list' from -all frames.") - -(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'. -The source is hidden by default and can be summoned via its narrow key. -Only buffers returned by the `consult-buffer-list-function' are taken -into account.") - -(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'. -Only buffers returned by the `consult-buffer-list-function' are taken into -account.") - -(defvar consult-source-other-buffer - `( :name "Other Buffer" - :narrow ?o - :hidden t - :category buffer - :face consult-buffer - :history buffer-name-history - :state ,#'consult--buffer-state - :enabled ,(lambda () (not (eq consult-buffer-list-function #'buffer-list))) - :items - ,(lambda () - (let ((local (consult--string-hash (consult--buffer-query)))) - (consult--buffer-query :sort 'visibility - :predicate (lambda (buf) (not (gethash buf local))) - :as #'consult--buffer-pair - :buffer-list t)))) - "Source for `consult-buffer' for buffers from other frames or tabs. -The source is hidden by default and can be summoned via its narrow key. -Only buffers returned by the `consult-buffer-list-function' are taken -into account.") - -(autoload 'consult-register--candidates "consult-register") - -(defun consult--buffer-register-p (reg) - "Return non-nil if REG is a buffer register." - (and (eq (car-safe reg) 'buffer) (buffer-live-p (get-buffer (cdr reg))))) - -(defvar consult-source-buffer-register - `( :name "Buffer Register" - :narrow (?r . "Register") - :category buffer - :state ,#'consult--buffer-state - :enabled ,(lambda () (cl-loop for (_ . reg) in register-alist - thereis (consult--buffer-register-p reg))) - :items ,(lambda () (consult-register--candidates #'consult--buffer-register-p))) - "Buffer register source.") - -(defun consult--file-register-p (reg) - "Return non-nil if REG is a file register." - (memq (car-safe reg) '(file-query file))) - -(defvar consult-source-file-register - `( :name "File Register" - :narrow (?r . "Register") - :category file - :state ,#'consult--file-state - :enabled ,(lambda () (cl-loop for (_ . reg) in register-alist - thereis (consult--file-register-p reg))) - :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." - (declare (indent 0) (debug t)) - `(consult--with-project-f (lambda () ,@body))) - -(defun consult--with-project-f (body) - "See `consult--with-project' for documentation." - ;; 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. - (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)))))) - (funcall 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 (string-match consult--grep-match-regexp 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 variable `grep-find-ignored-directories' and the variable -`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-literals 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 'consult-compile-error "consult-compile") - -;;;###autoload -(defun consult-grep-match (&optional arg) - "Jump to grep matches related to the current project or file. - -This command collects entries from all related Grep buffers. The -command supports preview of the currently selected match. With prefix -ARG, jump to the match in the Grep buffer, instead of to the actual -location of the match. This command is a thin wrapper around -`consult-compile-error'." - (interactive "P") - (consult-compile-error arg t)) - -;;;###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-opt#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-literals 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-literals 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)) - (method (or (seq-find (lambda (o) - (member o '("-name" "-path" "-regex" - "-iname" "-ipath" "-iregex"))) - opts) - "-iregex")) - (opts (remove method opts)) - (ignore-case (string-prefix-p "-i" method))) - (if (not (string-suffix-p "regex" method)) - (when-let* ((args (consult--split-escaped arg))) - (cons (append cmd - (cdr (mapcan - (lambda (x) `("-and" ,method ,(format "*%s*" x))) - args)) - opts) - (apply-partially #'consult--highlight-literals args ignore-case))) - (pcase-let ((`(,re . ,hl) (consult--compile-regexp arg type ignore-case))) - (when (or re opts) ;; Either option or regexp must be provided - (cons (append cmd - (cdr (mapcan - (lambda (x) - `("-and" ,method - ,(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) - (member "-g" flags) (member "--glob" flags)) - (when-let* ((args (consult--split-escaped arg))) - (cons (append cmd opts - (mapcan (lambda (x) `("--and" ,x)) - (if (or (member "-g" flags) (member "--glob" flags)) - (mapcar (lambda (x) (concat "**/" x)) args) - args)) - (mapcan (lambda (x) `("--search-path" ,x)) paths)) - (apply-partially #'consult--highlight-literals args ignore-case))) - (pcase-let ((`(,re . ,hl) (consult--compile-regexp arg 'pcre ignore-case))) - (when (or re opts) ;; Either option or regexp must be provided - (cons (append cmd opts - (mapcan (lambda (x) `("--and" ,x)) re) - (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 arg '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)) - (when-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)) - (inhibit-message t) - (message-log-max nil)) - (when-let* ((buf (man page)) - ((buffer-live-p buf))) - (with-current-buffer buf - (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))) - -;;;; Integration with completion systems - -;;;;; Integration: Default *Completions* - -(defun consult--default-completion-list-preview () - "Preview candidate at point in *Completions* buffer." - (when-let* ((win (active-minibuffer-window)) - (buf (window-buffer win)) - (fun (buffer-local-value 'consult--preview-function buf))) - (funcall fun))) - -(defun consult--default-completion-list-preview-setup () - "Setup preview at point in *Completions* buffer." - (add-hook 'post-command-hook #'consult--default-completion-list-preview nil 'local)) -(add-hook 'completion-list-mode-hook #'consult--default-completion-list-preview-setup) - -(defun consult--default-completion-minibuffer-candidate () - "Return current minibuffer candidate from default completion system or Icomplete." - (when (minibufferp) - (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." - (when-let* ((buffer - (if (derived-mode-p #'completion-list-mode) - ;; Use current buffer if already inside *Completions* buffer - (current-buffer) - ;; Otherwise check if there is an active *Completions* buffer - ;; which can be controlled remotely from the minibuffer. See - ;; the setting `minibuffer-visible-completions'. - (when-let* ((bound-and-true-p minibuffer-visible-completions) - (window (get-buffer-window "*Completions*" 'visible)) - (buffer (window-buffer window)) - ((eq (buffer-local-value 'completion-reference-buffer buffer) - (window-buffer (active-minibuffer-window))))) - buffer)))) - (with-current-buffer buffer - ;; TODO Use `completion-list-candidate-at-point' on Emacs 31 - (let (beg) - (when (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)))))) - -(defun consult--default-completion-list-refresh () - "Refresh default completion UI." - (when (and (bound-and-true-p completion-eager-update) - (bound-and-true-p completion-eager-display) - (not (bound-and-true-p vertico-mode)) - (not (bound-and-true-p icomplete-mode))) - (minibuffer-completion-help))) - -;;;;; 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 -- cgit v1.2.3