diff options
Diffstat (limited to '.config/emacs/lisp/minadstack')
| -rw-r--r-- | .config/emacs/lisp/minadstack/cape.el | 1359 | ||||
| -rw-r--r-- | .config/emacs/lisp/minadstack/consult.el | 5739 | ||||
| -rw-r--r-- | .config/emacs/lisp/minadstack/corfu-history.el | 114 | ||||
| -rw-r--r-- | .config/emacs/lisp/minadstack/corfu.el | 1444 | ||||
| -rw-r--r-- | .config/emacs/lisp/minadstack/marginalia.el | 1461 | ||||
| -rw-r--r-- | .config/emacs/lisp/minadstack/orderless.el | 672 | ||||
| -rw-r--r-- | .config/emacs/lisp/minadstack/vertico-directory.el | 136 | ||||
| -rw-r--r-- | .config/emacs/lisp/minadstack/vertico.el | 736 |
8 files changed, 0 insertions, 11661 deletions
diff --git a/.config/emacs/lisp/minadstack/cape.el b/.config/emacs/lisp/minadstack/cape.el deleted file mode 100644 index c180044..0000000 --- a/.config/emacs/lisp/minadstack/cape.el +++ /dev/null @@ -1,1359 +0,0 @@ -;;; cape.el --- Completion At Point Extensions -*- lexical-binding: t -*- - -;; Copyright (C) 2021-2026 Free Software Foundation, Inc. - -;; Author: Daniel Mendler <mail@daniel-mendler.de> -;; Maintainer: Daniel Mendler <mail@daniel-mendler.de> -;; Created: 2021 -;; Version: 2.7 -;; Package-Requires: ((emacs "29.1") (compat "31")) -;; URL: https://github.com/minad/cape -;; Keywords: abbrev, convenience, matching, completion, text - -;; This file is part of GNU Emacs. - -;; This program is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Let your completions fly! This package provides additional completion -;; backends in the form of Capfs, see `completion-at-point-functions'. -;; -;; `cape-abbrev': Complete abbreviation (`add-global-abbrev', `add-mode-abbrev'). -;; `cape-dabbrev': Complete word from current buffers. -;; `cape-dict': Complete word from dictionary file. -;; `cape-elisp-block': Complete Elisp in Org or Markdown code block. -;; `cape-elisp-symbol': Complete Elisp symbol. -;; `cape-emoji': Complete Emoji. -;; `cape-file': Complete file name. -;; `cape-history': Complete from Eshell, Comint or minibuffer history. -;; `cape-keyword': Complete programming language keyword. -;; `cape-line': Complete entire line from file. -;; `cape-rfc1345': Complete Unicode char using RFC 1345 mnemonics. -;; `cape-sgml': Complete Unicode char from SGML entity, e.g., &alpha. -;; `cape-tex': Complete Unicode char from TeX command, e.g. \hbar. - -;;; Code: - -(require 'compat) -(eval-when-compile - (require 'cl-lib) - (require 'subr-x)) - -;;;; Customization - -(defgroup cape nil - "Completion At Point Extensions." - :link '(info-link :tag "Info Manual" "(cape)") - :link '(url-link :tag "Website" "https://github.com/minad/cape") - :link '(emacs-library-link :tag "Library Source" "cape.el") - :group 'convenience - :group 'tools - :group 'matching - :prefix "cape-") - -(defcustom cape-dict-limit 100 - "Maximal number of completion candidates returned by `cape-dict'." - :type '(choice (const nil) natnum)) - -;; TODO bug#80071 file-local language. Add mechanism to locate dictionary file -;; based on file-local language variable. -(defcustom cape-dict-file "/usr/share/dict/words" - "Path to dictionary word list file. -This variable can also be a list of paths or -a function returning a single or more paths." - :type '(choice string (repeat string) function)) - -(defcustom cape-dict-case-replace 'case-replace - "Preserve case of input. -See `dabbrev-case-replace' for details." - :type '(choice (const :tag "Disable" nil) - (const :tag "Use `case-replace'" case-replace) - (other :tag "Enable" t))) - -(defcustom cape-dict-case-fold 'case-fold-search - "Case fold search during search. -See `dabbrev-case-fold-search' for details." - :type '(choice (const :tag "Disable" nil) - (const :tag "Use `case-fold-search'" case-fold-search) - (other :tag "Enable" t))) - -(defcustom cape-dabbrev-buffer-function #'cape-same-mode-buffers - "Function which returns list of buffers. -The buffers are scanned for completion candidates by `cape-dabbrev'." - :type `(choice (const :tag "Current buffer" current-buffer) - (const :tag "Text buffers" ,#'cape-text-buffers) - (const :tag "Buffers with same mode" ,#'cape-same-mode-buffers) - (function :tag "Custom function"))) - -(defcustom cape-file-directory nil - "Base directory used by `cape-file." - :type '(choice (const nil) string function)) - -(defcustom cape-file-prefix "file:" - "File completion trigger prefixes. -The value can be a string or a list of strings. The default -`file:' is the prefix of Org file links which work in arbitrary -buffers via `org-open-at-point-global'." - :type '(choice string (repeat string))) - -(defcustom cape-file-directory-must-exist t - "The parent directory must exist for file completion." - :type 'boolean) - -(defcustom cape-line-buffer-function #'cape-same-mode-buffers - "Function which returns list of buffers. -The buffers are scanned for completion candidates by `cape-line'." - :type `(choice (const :tag "Current buffer" current-buffer) - (const :tag "Text buffers" ,#'cape-text-buffers) - (const :tag "Buffers with same mode" ,#'cape-same-mode-buffers) - (function :tag "Custom function"))) - -(defcustom cape-elisp-symbol-wrapper - '((org-mode ?~ ?~) - (markdown-mode ?` ?`) - (emacs-lisp-mode ?` ?') - (rst-mode "``" "``") - (log-edit-mode "`" "'") - (change-log-mode "`" "'") - (message-mode "`" "'") - (rcirc-mode "`" "'")) - "Wrapper characters for symbols." - :type '(alist :key-type symbol :value-type (list (choice character string) - (choice character string)))) - -;;;; Helpers - -(defun cape--buffer-list (pred) - "Return list of buffers satisfying PRED." - (let* ((cur (current-buffer)) - (orig (and (minibufferp) (window-buffer (minibuffer-selected-window)))) - (list (cl-loop for buf in (buffer-list) - if (and (not (eq buf cur)) (not (eq buf orig)) - (funcall pred buf)) - collect buf))) - `(,cur ,@(and orig (list orig)) ,@list))) - -(defun cape-same-mode-buffers () - "Return buffers with same major mode as current buffer." - (cape--buffer-list - (lambda (buf) (eq major-mode (buffer-local-value 'major-mode buf))))) - -(defun cape-text-buffers () - "Return `text-mode' and `prog-mode' buffers." - (cape--buffer-list - (lambda (buf) - (let ((mode (buffer-local-value 'major-mode buf))) - (or (provided-mode-derived-p mode #'text-mode) - (provided-mode-derived-p mode #'prog-mode)))))) - -(defun cape--case-fold-p (fold) - "Return non-nil if case folding is enabled for FOLD." - (if (eq fold 'case-fold-search) case-fold-search fold)) - -(defun cape--case-replace-list (flag input strs) - "Replace case of STRS depending on INPUT and FLAG." - (if (and (if (eq flag 'case-replace) case-replace flag) - (let (case-fold-search) (string-match-p "\\`[[:upper:]]" input))) - (mapcar (apply-partially #'cape--case-replace flag input) strs) - strs)) - -(defun cape--case-replace (flag input str) - "Replace case of STR depending on INPUT and FLAG." - (or (and (if (eq flag 'case-replace) case-replace flag) - (string-prefix-p input str t) - (let (case-fold-search) (string-match-p "\\`[[:upper:]]" input)) - (save-match-data - ;; Ensure that single character uppercase input does not lead to an - ;; all uppercase result. - (when (and (= (length input) 1) (> (length str) 1)) - (setq input (concat input (substring str 1 2)))) - (and (string-match input input) - (replace-match str nil nil input)))) - str)) - -(defun cape--separator-p (str) - "Return non-nil if input STR has a separator character. -Separator characters are used by completion styles like Orderless -to split filter words. In Corfu, the separator is configurable -via the variable `corfu-separator'." - (string-search (string ;; Support `corfu-separator' and Orderless - (or (and (bound-and-true-p corfu-mode) - (bound-and-true-p corfu-separator)) - ?\s)) - str)) - -(defmacro cape--silent (&rest body) - "Silence BODY." - (declare (indent 0)) - `(cl-letf ((inhibit-message t) - (message-log-max nil) - ((symbol-function #'minibuffer-message) #'ignore)) - (ignore-errors ,@body))) - -(defun cape--bounds (thing) - "Return bounds of THING." - (or (bounds-of-thing-at-point thing) (cons (point) (point)))) - -(defmacro cape--wrapped-table (wrap body) - "Create wrapped completion table, handle `completion--unquote'. -WRAP is the wrapper function. -BODY is the wrapping expression." - (declare (indent 1)) - `(lambda (str pred action) - (,@body - (let ((result (complete-with-action action table str pred))) - (when (and (eq action 'completion--unquote) (functionp (cadr result))) - (cl-callf ,wrap (cadr result))) - result)))) - -(defun cape--accept-all-table (table) - "Create completion TABLE which accepts all input." - (cape--wrapped-table cape--accept-all-table - (or (eq action 'lambda)))) - -(defun cape--passthrough-table (table) - "Create completion TABLE disabling any filtering." - (cape--wrapped-table cape--passthrough-table - (let (completion-ignore-case completion-regexp-list (_ (setq str "")))))) - -(defun cape--noninterruptible-table (table) - "Create non-interruptible completion TABLE." - (cape--wrapped-table cape--noninterruptible-table - (let (throw-on-input)))) - -(defun cape--silent-table (table) - "Create a new completion TABLE which is silent (no messages, no errors)." - (cape--wrapped-table cape--silent-table - (cape--silent))) - -(defun cape--nonessential-table (table) - "Mark completion TABLE as `non-essential'." - (let ((dir default-directory)) - (cape--wrapped-table cape--nonessential-table - (let ((default-directory dir) - (non-essential t)))))) - -(defun cape--table-drop-metadata (table keys) - "Create completion TABLE without metadata KEYS." - (if (functionp table) - (lambda (str pred action) - (if (eq action 'metadata) - (when-let* ((md (copy-sequence (funcall table str pred action)))) - (dolist (k keys) (setq md (assq-delete-all k md))) - md) - (complete-with-action action table str pred))) - table)) - -(defvar cape--debug-length 5 - "Length of printed lists in `cape--debug-print'.") - -(defvar cape--debug-id 0 - "Completion table identifier.") - -(defun cape--debug-message (&rest msg) - "Print debug MSG." - (let ((inhibit-message t)) - (apply #'message msg))) - -(defun cape--debug-print (obj &optional full) - "Print OBJ as string, truncate lists if FULL is nil." - (cond - ((symbolp obj) (symbol-name obj)) - ((functionp obj) "#<function>") - ((proper-list-p obj) - (concat - "(" - (string-join - (mapcar #'cape--debug-print - (if full obj (take cape--debug-length obj))) - " ") - (if (and (not full) (length> obj cape--debug-length)) " ...)" ")"))) - (t (let ((print-level 2)) - (prin1-to-string obj))))) - -(defun cape--debug-table (table name beg end) - "Create completion TABLE with debug messages. -NAME is the name of the Capf, BEG and END are the input markers." - (lambda (str pred action) - (let ((result (complete-with-action action table str pred))) - (if (and (eq action 'completion--unquote) (functionp (cadr result))) - ;; See `cape--wrapped-table' - (cl-callf cape--debug-table (cadr result) name beg end) - (cape--debug-message - "%s(action=%S input=%s:%s:%S prefix=%S ignore-case=%S%s%s) => %s" - name - (pcase action - ('nil 'try) - ('t 'all) - ('lambda 'test) - (_ action)) - (+ beg 0) (+ end 0) (buffer-substring-no-properties beg end) - str completion-ignore-case - (if completion-regexp-list - (concat " regexp=" (cape--debug-print completion-regexp-list t)) - "") - (if pred - (concat " predicate=" (cape--debug-print pred)) - "") - (cape--debug-print result))) - result))) - -(defun cape--dynamic-table (beg end fun) - "Create dynamic completion table from FUN with caching. -BEG and END are the input bounds. FUN is the function which -computes the candidates. FUN must return a pair of a predicate -function function and the list of candidates. The predicate is -passed new input and must return non-nil if the candidates are -still valid. - -It is only necessary to use this function if the set of -candidates is computed dynamically based on the input and not -statically determined. The behavior is similar but slightly -different to `completion-table-dynamic'. - -The difference to the builtins `completion-table-dynamic' and -`completion-table-with-cache' is that this function does not use -the prefix argument of the completion table to compute the -candidates. Instead it uses the input in the buffer between BEG -and END to FUN to compute the candidates. This way the dynamic -candidate computation is compatible with non-prefix completion -styles like `substring' or `orderless', which pass the empty -string as first argument to the completion table." - (let ((beg (copy-marker beg)) - (end (copy-marker end t)) - valid table) - (lambda (str pred action) - ;; Bail out early for `metadata' and `boundaries'. This is a pointless - ;; move because of caching, but we do it anyway in the hope that the - ;; profiler report looks less confusing, since the weight of the expensive - ;; FUN computation is moved to the `all-completions' action. Computing - ;; `all-completions' must surely be most expensive, so nobody will suspect - ;; a thing. - (unless (or (eq action 'metadata) (eq (car-safe action) 'boundaries)) - (let ((input (buffer-substring-no-properties beg end))) - (unless (and valid - (or (cape--separator-p input) - (funcall valid input))) - (let* (;; Reset in case `all-completions' is used inside FUN - completion-ignore-case completion-regexp-list - ;; Retrieve new state by calling FUN - (new (and (< beg end) (funcall fun input))) - ;; No interrupt during state update - throw-on-input) - (setq valid (car new) table (cdr new))))) - (complete-with-action action table str pred))))) - -;;;; Capfs - -;;;;; cape-history - -(declare-function ring-elements "ring") -(declare-function eshell-bol "eshell") -(declare-function comint-line-beginning-position "comint") -(defvar eshell-history-ring) -(defvar comint-input-ring) - -(defvar cape--history-properties - (list :company-kind (lambda (_) 'text) - :exclusive 'no - :display-sort-function #'identity - :cycle-sort-function #'identity - :category 'cape-history) - "Completion extra properties for `cape-history'.") - -;;;###autoload -(defun cape-history (&optional interactive) - "Complete from Eshell, Comint or minibuffer history. -See also `consult-history' for a more flexible variant based on -`completing-read'. If INTERACTIVE is nil the function acts like a Capf." - (interactive (list t)) - (if interactive - (cape-interactive #'cape-history) - (let (history bol) - (cond - ((derived-mode-p 'eshell-mode) - (setq history eshell-history-ring - bol (static-if (< emacs-major-version 30) - (save-excursion (eshell-bol) (point)) - (line-beginning-position)))) - ((derived-mode-p 'comint-mode) - (setq history comint-input-ring - bol (comint-line-beginning-position))) - ((and (minibufferp) (not (eq minibuffer-history-variable t))) - (setq history (symbol-value minibuffer-history-variable) - bol (line-beginning-position)))) - (when (ring-p history) - (setq history (ring-elements history))) - (when history - `(,bol ,(point) ,history ,@cape--history-properties))))) - -;;;;; cape-file - -(defvar comint-unquote-function) -(defvar comint-requote-function) - -(defvar cape--file-properties - (list :annotation-function (lambda (s) (if (string-suffix-p "/" s) " Dir" " File")) - :company-kind (lambda (s) (if (string-suffix-p "/" s) 'folder 'file)) - :exclusive 'no - :category 'file) - "Completion extra properties for `cape-file'.") - -;;;###autoload -(defun cape-file (&optional interactive) - "Complete file name at point. -See the user option `cape-file-directory-must-exist'. -If INTERACTIVE is nil the function acts like a Capf." - (interactive (list t)) - (if interactive - (cape-interactive '(cape-file-directory-must-exist) #'cape-file) - (pcase-let* ((default-directory (pcase cape-file-directory - ('nil default-directory) - ((pred stringp) cape-file-directory) - (_ (funcall cape-file-directory)))) - (prefix (and cape-file-prefix - (looking-back - (concat - (regexp-opt (ensure-list cape-file-prefix) t) - "[^ \n\t]*") - (pos-bol)) - (match-end 1))) - (`(,beg . ,end) (if prefix - (cons prefix (point)) - (cape--bounds 'filename))) - (non-essential t) - (file (buffer-substring-no-properties beg end))) - (when (or prefix - (not cape-file-directory-must-exist) - (and (string-search "/" file) - (file-exists-p (file-name-directory - (substitute-in-file-name file))))) - (unless (boundp 'comint-unquote-function) - (require 'comint)) - (let ((table (cape--nonessential-table - (completion-table-with-quoting - #'read-file-name-internal - comint-unquote-function - comint-requote-function)))) - `( ,beg ,end ,table - :company-location - ,(lambda (file) - (let* ((str (buffer-substring-no-properties beg (point))) - (pre (car (completion-boundaries str table nil ""))) - (file (file-name-concat (substring str 0 pre) file))) - (and (file-exists-p file) (list file)))) - ,@(when (or prefix (string-match-p "./" file)) - '(:company-prefix-length t)) - ,@cape--file-properties)))))) - -;;;;; cape-elisp-symbol - -(autoload 'elisp--company-kind "elisp-mode") -(autoload 'elisp--company-doc-buffer "elisp-mode") -(autoload 'elisp--company-doc-string "elisp-mode") -(autoload 'elisp--company-location "elisp-mode") - -(defvar cape--elisp-symbol-properties - (list :annotation-function #'cape--elisp-symbol-annotation - :exit-function #'cape--elisp-symbol-exit - :predicate #'cape--elisp-symbol-predicate - :company-kind #'elisp--company-kind - :company-doc-buffer #'elisp--company-doc-buffer - :company-docsig #'elisp--company-doc-string - :company-location #'elisp--company-location - :exclusive 'no - :category 'symbol) - "Completion extra properties for `cape-elisp-symbol'.") - -(defun cape--elisp-symbol-predicate (sym) - "Return t if SYM is bound, fbound or propertized." - (or (fboundp sym) (boundp sym) (symbol-plist sym))) - -(defun cape--elisp-symbol-exit (sym status) - "Wrap symbol SYM with `cape-elisp-symbol-wrapper' buffers. -STATUS is the exit status." - (when-let* (((not (eq status 'exact))) - (c (cl-loop for (m . c) in cape-elisp-symbol-wrapper - if (derived-mode-p m) return c)) - ((or (not (derived-mode-p 'emacs-lisp-mode)) - ;; Inside comment or string - (let ((s (syntax-ppss))) (or (nth 3 s) (nth 4 s))))) - (x (if (stringp (car c)) (car c) (string (car c)))) - (y (if (stringp (cadr c)) (cadr c) (string (cadr c))))) - (save-excursion - (backward-char (length sym)) - (unless (save-excursion - (and (ignore-errors (or (backward-char (length x)) t)) - (looking-at-p (regexp-quote x)))) - (insert x))) - (unless (looking-at-p (regexp-quote y)) - (insert y)))) - -(defun cape--elisp-symbol-annotation (sym) - "Return kind of SYM." - (setq sym (intern-soft sym)) - (cond - ((special-form-p sym) " Special") - ((macrop sym) " Macro") - ((commandp sym) " Command") - ((fboundp sym) " Function") - ((custom-variable-p sym) " Custom") - ((boundp sym) " Variable") - ((featurep sym) " Feature") - ((facep sym) " Face") - (t " Symbol"))) - -;;;###autoload -(defun cape-elisp-symbol (&optional interactive) - "Complete Elisp symbol at point. -If INTERACTIVE is nil the function acts like a Capf." - (interactive (list t)) - (if interactive - ;; No cycling since it breaks the :exit-function. - (let (completion-cycle-threshold) - (cape-interactive #'cape-elisp-symbol)) - (pcase-let ((`(,beg . ,end) (cape--bounds 'symbol))) - (when (eq (char-after beg) ?') - (setq beg (1+ beg) end (max beg end))) - `(,beg ,end ,obarray ,@cape--elisp-symbol-properties)))) - -;;;;; cape-elisp-block - -(declare-function org-element-context "org-element") -(declare-function markdown-code-block-lang "ext:markdown-mode") - -(defun cape--inside-block-p (&rest langs) - "Return non-nil if inside LANGS code block." - (when-let* ((face (get-text-property (point) 'face)) - (lang (or (and (if (listp face) - (memq 'org-block face) - (eq 'org-block face)) - (plist-get (cadr (org-element-context)) :language)) - (and (if (listp face) - (memq 'markdown-code-face face) - (eq 'markdown-code-face face)) - (save-excursion - (markdown-code-block-lang)))))) - (member lang langs))) - -;;;###autoload -(defun cape-elisp-block (&optional interactive) - "Complete Elisp in Org or Markdown code block. -This Capf is particularly useful for literate Emacs configurations. -If INTERACTIVE is nil the function acts like a Capf." - (interactive (list t)) - (cond - (interactive - ;; No code block check. Always complete Elisp when command was - ;; explicitly invoked interactively. - (cape-interactive #'elisp-completion-at-point)) - ((cape--inside-block-p "elisp" "emacs-lisp") - (elisp-completion-at-point)))) - -;;;;; cape-dabbrev - -(defvar cape--dabbrev-properties - (list :annotation-function (lambda (_) " Dabbrev") - :company-kind (lambda (_) 'text) - :exclusive 'no - :category 'cape-dabbrev) - "Completion extra properties for `cape-dabbrev'.") - -(defvar dabbrev-case-replace) -(defvar dabbrev-case-fold-search) -(defvar dabbrev-abbrev-char-regexp) -(defvar dabbrev-abbrev-skip-leading-regexp) -(declare-function dabbrev--find-all-expansions "dabbrev") -(declare-function dabbrev--reset-global-variables "dabbrev") - -(defun cape--dabbrev-list (input) - "Find all Dabbrev expansions for INPUT." - (cape--silent - (dlet ((dabbrev-check-other-buffers nil) - (dabbrev-check-all-buffers nil) - (dabbrev-backward-only nil) - (dabbrev-limit nil) - (dabbrev-search-these-buffers-only - (ensure-list (funcall cape-dabbrev-buffer-function)))) - (dabbrev--reset-global-variables) - (cons - (apply-partially #'string-prefix-p input) - (cl-loop - with ic = (cape--case-fold-p dabbrev-case-fold-search) - for w in (dabbrev--find-all-expansions input ic) - collect (cape--case-replace (and ic dabbrev-case-replace) input w)))))) - -(defun cape--dabbrev-bounds () - "Return bounds of abbreviation." - (unless (boundp 'dabbrev-abbrev-char-regexp) - (require 'dabbrev)) - (let ((re (or dabbrev-abbrev-char-regexp "\\sw\\|\\s_")) - (limit (minibuffer-prompt-end))) - (if (or (looking-at re) - (and (> (point) limit) - (save-excursion (forward-char -1) (looking-at re)))) - (cons (save-excursion - (while (and (> (point) limit) - (save-excursion (forward-char -1) (looking-at re))) - (forward-char -1)) - (when dabbrev-abbrev-skip-leading-regexp - (while (looking-at dabbrev-abbrev-skip-leading-regexp) - (forward-char 1))) - (point)) - (save-excursion - (while (looking-at re) - (forward-char 1)) - (point))) - (cons (point) (point))))) - -;;;###autoload -(defun cape-dabbrev (&optional interactive) - "Complete with Dabbrev at point. - -If INTERACTIVE is nil the function acts like a Capf. In case you -observe a performance issue with auto-completion and `cape-dabbrev' -it is strongly recommended to disable scanning in other buffers. -See the user option `cape-dabbrev-buffer-function'." - (interactive (list t)) - (if interactive - (cape-interactive #'cape-dabbrev) - (pcase-let ((`(,beg . ,end) (cape--dabbrev-bounds))) - `(,beg ,end - ,(completion-table-case-fold - (cape--dynamic-table beg end #'cape--dabbrev-list) - (not (cape--case-fold-p dabbrev-case-fold-search))) - ,@cape--dabbrev-properties)))) - -;;;;; cape-dict - -(defvar cape--dict-properties - (list :annotation-function (lambda (_) " Dict") - :company-kind (lambda (_) 'text) - :display-sort-function #'identity - :cycle-sort-function #'identity - :exclusive 'no - :category 'cape-dict) - "Completion extra properties for `cape-dict'.") - -(defun cape--dict-list (input) - "Return all words from `cape-dict-file' matching INPUT." - (let* ((inhibit-message t) - (message-log-max nil) - (default-directory - (if (and (not (file-remote-p default-directory)) - (file-directory-p default-directory)) - default-directory - user-emacs-directory)) - (files (mapcar #'expand-file-name - (ensure-list - (if (functionp cape-dict-file) - (funcall cape-dict-file) - cape-dict-file)))) - (words - (apply #'process-lines-ignore-status - "grep" - (concat "-Fh" - (and (cape--case-fold-p cape-dict-case-fold) "i") - (and cape-dict-limit (format "m%d" cape-dict-limit))) - input files))) - (cons - (apply-partially - (if (and cape-dict-limit (length= words cape-dict-limit)) - #'equal #'string-search) - input) - (cape--case-replace-list cape-dict-case-replace input words)))) - -;;;###autoload -(defun cape-dict (&optional interactive) - "Complete word from dictionary at point. -This completion function works best if the dictionary is sorted -by frequency. See the custom option `cape-dict-file'. If -INTERACTIVE is nil the function acts like a Capf." - (interactive (list t)) - (if interactive - (cape-interactive #'cape-dict) - (pcase-let ((`(,beg . ,end) (cape--bounds 'word))) - `( ,beg ,end - ,(completion-table-case-fold - (cape--dynamic-table beg end #'cape--dict-list) - (not (cape--case-fold-p cape-dict-case-fold))) - ,@cape--dict-properties)))) - -;;;;; cape-abbrev - -(defun cape--abbrev-list () - "Abbreviation list." - (delete "" (cl-loop for x in (abbrev--suggest-get-active-tables-including-parents) - nconc (all-completions "" x)))) - -(defun cape--abbrev-annotation (abbrev) - "Annotate ABBREV with expansion." - (concat " " - (truncate-string-to-width - (format - "%s" - (symbol-value - (cl-loop for x in (abbrev--suggest-get-active-tables-including-parents) - thereis (abbrev--symbol abbrev x)))) - 30 0 nil t))) - -(defun cape--abbrev-exit (_str status) - "Expand expansion if STATUS is not exact." - (unless (eq status 'exact) - (expand-abbrev))) - -(defvar cape--abbrev-properties - (list :annotation-function #'cape--abbrev-annotation - :exit-function #'cape--abbrev-exit - :company-kind (lambda (_) 'snippet) - :exclusive 'no - :category 'cape-abbrev) - "Completion extra properties for `cape-abbrev'.") - -;;;###autoload -(defun cape-abbrev (&optional interactive) - "Complete abbreviation at point. -If INTERACTIVE is nil the function acts like a Capf." - (interactive (list t)) - (if interactive - ;; No cycling since it breaks the :exit-function. - (let (completion-cycle-threshold) - (cape-interactive #'cape-abbrev)) - (when-let* ((abbrevs (cape--abbrev-list)) - (bounds (cape--bounds 'symbol))) - `(,(car bounds) ,(cdr bounds) ,abbrevs ,@cape--abbrev-properties)))) - -;;;;; cape-line - -(defvar cape--line-properties - (list :display-sort-function #'identity - :cycle-sort-function #'identity - :exclusive 'no - :category 'cape-line) - "Completion extra properties for `cape-line'.") - -(defun cape--line-list () - "Return all lines from buffer." - (let ((ht (make-hash-table :test #'equal)) - (curr-buf (current-buffer)) - (buffers (funcall cape-line-buffer-function)) - lines) - (dolist (buf (ensure-list buffers)) - (with-current-buffer buf - (let ((beg (point-min)) - (max (point-max)) - (pt (if (eq curr-buf buf) (point) -1)) - end) - (save-excursion - (while (< beg max) - (goto-char beg) - (setq end (pos-eol)) - (unless (<= beg pt end) - (let ((line (buffer-substring-no-properties beg end))) - (unless (or (string-blank-p line) (gethash line ht)) - (puthash line t ht) - (push line lines)))) - (setq beg (1+ end))))))) - (nreverse lines))) - -;;;###autoload -(defun cape-line (&optional interactive) - "Complete current line from other lines. -The buffers returned by `cape-line-buffer-function' are scanned for lines. -If INTERACTIVE is nil the function acts like a Capf." - (interactive (list t)) - (if interactive - (cape-interactive #'cape-line) - `(,(pos-bol) ,(point) ,(cape--line-list) ,@cape--line-properties))) - -;;;; Capf combinators - -(defun cape--company-call (&rest app) - "Apply APP and handle future return values." - ;; Backends are non-interruptible. Disable interrupts! - (let ((toi throw-on-input) - (throw-on-input nil)) - (pcase (apply app) - ;; Handle async future return values. - (`(:async . ,fetch) - (let ((res 'cape--waiting)) - (if toi - (unwind-protect - (progn - (funcall fetch - (lambda (arg) - (when (eq res 'cape--waiting) - (push 'cape--done unread-command-events) - (setq res arg)))) - (when (eq res 'cape--waiting) - (let ((ev (let ((input-method-function nil) - (echo-keystrokes 0)) - (read-event nil t)))) - (unless (eq ev 'cape--done) - (push (cons t ev) unread-command-events) - (setq res 'cape--cancelled) - (throw toi t))))) - (setq unread-command-events - (delq 'cape--done unread-command-events))) - (funcall fetch (lambda (arg) (setq res arg))) - ;; Force synchronization, not interruptible! We use polling - ;; here and ignore pending input since we don't use - ;; `sit-for'. This is the same method used by Company itself. - (while (eq res 'cape--waiting) - (sleep-for 0.01))) - res)) - ;; Plain old synchronous return value. - (res res)))) - -(defvar-local cape--company-init nil) - -;;;###autoload -(defun cape-company-to-capf (backend &optional valid) - "Convert Company BACKEND function to Capf. -VALID is a function taking the old and new input string. It should -return nil if the cached candidates became invalid. The default value -for VALID is `string-prefix-p' such that the candidates are only fetched -again if the input prefix changed." - (lambda () - (when (and (symbolp backend) (not (fboundp backend))) - (ignore-errors (require backend nil t))) - (when (bound-and-true-p company-mode) - (error "`cape-company-to-capf' should not be used with `company-mode', use the Company backend directly instead")) - (when (and (symbolp backend) (not (alist-get backend cape--company-init))) - (funcall backend 'init) - (put backend 'company-init t) - (setf (alist-get backend cape--company-init) t)) - (when-let* ((pre (pcase (cape--company-call backend 'prefix) - ((or `(,p ,_s) (and (pred stringp) p)) (cons p (length p))) - ((or `(,p ,_s ,l) `(,p . ,l)) (cons p l))))) - (let* ((end (point)) (beg (- end (length (car pre)))) - (valid (if (cape--company-call backend 'no-cache (car pre)) - #'equal (or valid #'string-prefix-p))) - (sort-fun (and (cape--company-call backend 'sorted) #'identity)) - restore-props) - (list beg end - (funcall - (if (cape--company-call backend 'ignore-case) - #'completion-table-case-fold - #'identity) - (cape--dynamic-table - beg end - (lambda (input) - (let ((cands (cape--company-call backend 'candidates input))) - ;; The candidate string including text properties should be - ;; restored in the :exit-function, unless the UI guarantees - ;; this itself, like Corfu. - (unless (bound-and-true-p corfu-mode) - (setq restore-props cands)) - (cons (apply-partially valid input) cands))))) - :category backend - :exclusive 'no - :company-prefix-length (cdr pre) - :company-doc-buffer (lambda (x) (cape--company-call backend 'doc-buffer x)) - :company-location (lambda (x) (cape--company-call backend 'location x)) - :company-docsig (lambda (x) (cape--company-call backend 'meta x)) - :company-deprecated (lambda (x) (cape--company-call backend 'deprecated x)) - :company-kind (lambda (x) (cape--company-call backend 'kind x)) - :display-sort-function sort-fun - :cycle-sort-function sort-fun - :annotation-function (lambda (x) - (when-let* ((ann (cape--company-call backend 'annotation x))) - (concat " " (string-trim ann)))) - :exit-function (lambda (x _status) - ;; Restore the candidate string including - ;; properties if restore-props is non-nil. See - ;; the comment above. - (setq x (or (car (member x restore-props)) x)) - (cape--company-call backend 'post-completion x))))))) - -;;;###autoload -(defun cape-interactive (&rest capfs) - "Complete interactively with the given CAPFS." - (let* ((ctx (and (consp (car capfs)) (car capfs))) - (capfs (if ctx (cdr capfs) capfs)) - (completion-at-point-functions - (if ctx - (mapcar (lambda (f) `(lambda () (let ,ctx (funcall ',f)))) capfs) - capfs))) - (unless (completion-at-point) - (user-error "%s: No completions" - (mapconcat (lambda (fun) - (if (symbolp fun) - (symbol-name fun) - "anonymous-capf")) - capfs ", "))))) - -;;;###autoload -(defun cape-capf-interactive (capf) - "Create interactive completion function from CAPF." - (lambda (&optional interactive) - (interactive (list t)) - (if interactive (cape-interactive capf) (funcall capf)))) - -(defvar cape--super-functions - '( :company-docsig :company-location :company-kind - :company-doc-buffer :company-deprecated - :annotation-function :exit-function) - "List of extra functions which are handled by `cape-wrap-super'.") - -;;;###autoload -(defun cape-wrap-super (&rest capfs) - "Call CAPFS and return merged completion result. -The CAPFS list can contain the keyword `:with' to mark the Capfs -afterwards as auxiliary. One of the non-auxiliary Capfs before `:with' -must return non-nil for the super Capf to set in and return a non-nil -result. Such behavior is useful when listing multiple super Capfs in -the `completion-at-point-functions': - - (setq completion-at-point-functions - (list (cape-capf-super \\='elisp-completion-at-point - :with \\='tempel-complete) - (cape-capf-super \\='cape-dabbrev - :with \\='tempel-complete))) - -See the dual `cape-wrap-choose' if you want to try multiple Capfs in -turn." - (when-let* ((results (cl-loop for capf in capfs until (eq capf :with) - for res = (funcall capf) - if res collect (cons t res)))) - (pcase-let* ((results (nconc results - (cl-loop for capf in (cdr (memq :with capfs)) - for res = (funcall capf) - if res collect (cons nil res)))) - (`((,_main ,beg ,end . ,_)) results) - (cand-ht nil) - (tables nil) - (exclusive nil) - (prefix-len nil)) - (cl-loop for (main beg2 end2 table . plist) in results do - ;; Note: `cape-capf-super' currently cannot merge Capfs which - ;; trigger at different beginning positions. In order to support - ;; this, take the smallest BEG value and then normalize all - ;; candidates by prefixing them such that they all start at the - ;; smallest BEG position. - (when (= beg beg2) - (push (list main (plist-get plist :predicate) table - ;; Plist attached to the candidates - (mapcan (lambda (f) - (when-let* ((v (plist-get plist f))) - (list f v))) - cape--super-functions)) - tables) - ;; The resulting merged Capf is exclusive if one of the main - ;; Capfs is exclusive. - (when (and main (not (eq (plist-get plist :exclusive) 'no))) - (setq exclusive t)) - (setq end (max end end2)) - (let ((plen (plist-get plist :company-prefix-length))) - (cond - ((eq plen t) - (setq prefix-len t)) - ((and (not prefix-len) (integerp plen)) - (setq prefix-len plen)) - ((and (integerp prefix-len) (integerp plen)) - (setq prefix-len (max prefix-len plen))))))) - (setq tables (nreverse tables)) - `( ,beg ,end - ,(lambda (str pred action) - (pcase action - ((or `(boundaries . ,_) 'metadata) nil) - ('t ;; all-completions - (let ((ht (make-hash-table :test #'equal)) - (candidates nil)) - (cl-loop for (main table-pred table cand-plist) in tables do - (let* ((pr (if (and table-pred pred) - (lambda (x) (and (funcall table-pred x) (funcall pred x))) - (or table-pred pred))) - (md (completion-metadata "" table pr)) - (sort (or (completion-metadata-get md 'display-sort-function) - #'identity)) - ;; Always compute candidates of the main Capf - ;; tables, which come first in the tables - ;; list. For the :with Capfs only compute - ;; candidates if we've already determined that - ;; main candidates are available. - (cands (when (or main (or exclusive cand-ht candidates)) - (funcall sort (all-completions str table pr))))) - ;; Handle duplicates with a hash table. - (cl-loop - for cand in-ref cands - for dup = (gethash cand ht t) do - (cond - ((eq dup t) - ;; Candidate does not yet exist. - (puthash cand cand-plist ht)) - ((not (equal dup cand-plist)) - ;; Duplicate candidate. Candidate plist is - ;; different, therefore disambiguate the - ;; candidates. - (setf cand (propertize cand 'cape-capf-super - (cons cand cand-plist)))))) - (when cands (push cands candidates)))) - (when (or cand-ht candidates) - (setq candidates (apply #'nconc (nreverse candidates)) - cand-ht ht) - candidates))) - (_ ;; try-completion and test-completion - (cl-loop for (_main table-pred table _cand-plist) in tables thereis - (complete-with-action - action table str - (if (and table-pred pred) - (lambda (x) (and (funcall table-pred x) (funcall pred x))) - (or table-pred pred))))))) - :category cape-super - :company-prefix-length ,prefix-len - :display-sort-function ,#'identity - :cycle-sort-function ,#'identity - ,@(and (not exclusive) '(:exclusive no)) - ,@(mapcan - (lambda (prop) - (list prop - (lambda (cand &rest args) - (if-let* ((ref (get-text-property 0 'cape-capf-super cand))) - (when-let* ((fun (plist-get (cdr ref) prop))) - (apply fun (car ref) args)) - (when-let* ((plist (and cand-ht (gethash cand cand-ht))) - (fun (plist-get plist prop))) - (apply fun cand args)))))) - cape--super-functions))))) - -;;;###autoload -(defun cape-wrap-choose (&rest capfs) - "Call each of CAPFS in turn and return first non-nil result. -Use `cape-wrap-choose' to create a single Capf from multiple Capfs. -Usually you want to add multiple non-exclusive Capfs to the variable -`completion-at-point-functions' directly instead. See the dual -`cape-wrap-super' if you want to merge multiple Capf results." - (cl-loop - for capf in capfs thereis - (pcase (funcall capf) - ((and result `(,beg ,end ,table . ,plist)) - (let* ((str (buffer-substring-no-properties beg end)) - (pt (- (point) beg)) - (pred (plist-get plist :predicate)) - (md (completion-metadata (substring str 0 pt) table pred))) - ;; Treat the Capfs always as non-exclusive. Return the first which - ;; returns non-nil. See also the comment in `corfu--capf-wrapper'. - (and (completion-try-completion str table pred pt md) - result)))))) - -;;;###autoload -(defun cape-wrap-debug (capf &optional name) - "Call CAPF and return a completion table which prints trace messages. -If CAPF is an anonymous lambda, pass the Capf NAME explicitly for -meaningful debugging output." - (unless name - (setq name (if (symbolp capf) capf "capf"))) - (setq name (format "%s@%s" name (incf cape--debug-id))) - (pcase (funcall capf) - (`(,beg ,end ,table . ,plist) - (let* ((limit (1+ cape--debug-length)) - (pred (plist-get plist :predicate)) - (cands - ;; Reset regexps for `all-completions' - (let (completion-ignore-case completion-regexp-list) - (all-completions - "" table - (lambda (&rest args) - (and (or (not pred) (apply pred args)) (>= (decf limit) 0)))))) - (plist-str "") - (plist-elt plist)) - (while (cdr plist-elt) - (setq plist-str (format "%s %s=%s" plist-str - (substring (symbol-name (car plist-elt)) 1) - (cape--debug-print (cadr plist-elt))) - plist-elt (cddr plist-elt))) - (cape--debug-message - "%s => input=%s:%s:%S table=%s%s" - name (+ beg 0) (+ end 0) (buffer-substring-no-properties beg end) - (cape--debug-print cands) - plist-str)) - `( ,beg ,end - ,(cape--debug-table - table name (copy-marker beg) (copy-marker end t)) - ,@(when-let* ((exit (plist-get plist :exit-function))) - (list :exit-function - (lambda (str status) - (cape--debug-message "%s:exit(status=%s string=%S)" - name status str) - (funcall exit str status)))) - . ,plist)) - (result - (cape--debug-message "%s() => %s (No completion)" - name (cape--debug-print result))))) - -;;;###autoload -(defun cape-wrap-buster (capf &optional valid) - "Call CAPF and return a completion table with cache busting. -This function can be used as an advice around an existing Capf. -The cache is busted when the input changes. The argument VALID -can be a function taking the old and new input string. It should -return nil if the new input requires that the completion table is -refreshed. The default value for VALID is `equal', such that the -completion table is refreshed on every input change." - (setq valid (or valid #'equal)) - (pcase (funcall capf) - (`(,beg ,end ,table . ,plist) - (setq plist `(:cape--buster t . ,plist)) - `( ,beg ,end - ,(let* ((beg (copy-marker beg)) - (end (copy-marker end t)) - (input (buffer-substring-no-properties beg end))) - (lambda (str pred action) - (let ((new-input (buffer-substring-no-properties beg end))) - (unless (or (not (eq action t)) - (cape--separator-p new-input) - (funcall valid input new-input)) - (pcase - ;; Reset in case `all-completions' is used inside CAPF - (let (completion-ignore-case completion-regexp-list) - (funcall capf)) - ((and `(,new-beg ,new-end ,new-table . ,new-plist) - (guard (and (= beg new-beg) (= end new-end)))) - (let (throw-on-input) ;; No interrupt during state update - (setf table new-table - input new-input - (cddr plist) new-plist)))))) - (complete-with-action action table str pred))) - ,@plist)))) - -;;;###autoload -(defun cape-wrap-passthrough (capf) - "Call CAPF and make sure that no completion style filtering takes place. -This function can be used as an advice around an existing Capf." - (pcase (funcall capf) - (`(,beg ,end ,table . ,plist) - `(,beg ,end ,(cape--passthrough-table table) ,@plist)))) - -;;;###autoload -(defun cape-wrap-properties (capf &rest properties) - "Call CAPF and add completion PROPERTIES. -Completion properties include :exclusive, :category, -:annotation-function, :affixation-function, :display-sort-function, -:company-kind, :company-doc-buffer, :company-docsig, :company-location, -:company-deprecated and :company-prefix-length." - (let ((keys (cl-loop for (k _) on properties by #'cddr - collect (intern (substring (symbol-name k) 1))))) - (pcase (funcall capf) - (`(,beg ,end ,table . ,plist) - `( ,beg ,end ,(cape--table-drop-metadata table keys) - ,@properties ,@plist))))) - -;;;###autoload -(defun cape-wrap-nonexclusive (capf) - "Call CAPF and ensure that it is marked as non-exclusive. -This function can be used as an advice around an existing Capf." - (cape-wrap-properties capf :exclusive 'no)) - -;;;###autoload -(defun cape-wrap-sort (capf &optional sort) - "Call CAPF and add SORT function as completion metadata. -If the SORT argument is nil or not given, the completion UI will use -its own default sorting algorithm. This function can be used as an -advice around an existing Capf." - (cape-wrap-properties - capf - :display-sort-function sort - :cycle-sort-function sort)) - -;;;###autoload -(defun cape-wrap-predicate (capf predicate) - "Call CAPF and add an additional candidate PREDICATE. -The PREDICATE is passed the candidate symbol or string." - (pcase (funcall capf) - (`(,beg ,end ,table . ,plist) - `( ,beg ,end ,table - :predicate - ,(if-let* ((pred (plist-get plist :predicate))) - ;; First argument is key, second is value for hash tables. - ;; The first argument can be a cons cell for alists. Then - ;; the candidate itself is either a string or a symbol. We - ;; normalize the calling convention here such that PREDICATE - ;; always receives a string or a symbol. - (lambda (&rest args) - (when (apply pred args) - (setq args (car args)) - (funcall predicate (if (consp args) (car args) args)))) - (lambda (key &optional _val) - (funcall predicate (if (consp key) (car key) key)))) - ,@plist)))) - -;;;###autoload -(defun cape-wrap-silent (capf) - "Call CAPF and silence it (no messages, no errors). -This function can be used as an advice around an existing Capf." - (pcase (cape--silent (funcall capf)) - (`(,beg ,end ,table . ,plist) - `(,beg ,end ,(cape--silent-table table) ,@plist)))) - -;;;###autoload -(defun cape-wrap-case-fold (capf &optional nofold) - "Call CAPF and return a case-insensitive completion table. -If NOFOLD is non-nil return a case sensitive table instead. This -function can be used as an advice around an existing Capf." - (pcase (funcall capf) - (`(,beg ,end ,table . ,plist) - `(,beg ,end ,(completion-table-case-fold table nofold) ,@plist)))) - -;;;###autoload -(defun cape-wrap-noninterruptible (capf) - "Call CAPF and return a non-interruptible completion table. -This function can be used as an advice around an existing Capf." - (pcase (let (throw-on-input) (funcall capf)) - (`(,beg ,end ,table . ,plist) - `(,beg ,end ,(cape--noninterruptible-table table) ,@plist)))) - -;;;###autoload -(defun cape-wrap-prefix-length (capf length) - "Call CAPF and ensure that prefix length is greater or equal than LENGTH. -If the prefix is long enough, enforce auto completion." - (pcase (funcall capf) - (`(,beg ,end ,table . ,plist) - (when (>= (- end beg) length) - `(,beg ,end ,table :company-prefix-length t ,@plist))))) - -;;;###autoload -(defun cape-wrap-inside-faces (capf &rest faces) - "Call CAPF only if inside FACES." - (when-let* (((> (point) (point-min))) - (fs (get-text-property (1- (point)) 'face)) - ((if (listp fs) - (cl-loop for f in fs thereis (memq f faces)) - (memq fs faces)))) - (funcall capf))) - -;;;###autoload -(defun cape-wrap-inside-code (capf) - "Call CAPF only if inside code, not inside a comment or string. -This function can be used as an advice around an existing Capf." - (let ((s (syntax-ppss))) - (and (not (nth 3 s)) (not (nth 4 s)) (funcall capf)))) - -;;;###autoload -(defun cape-wrap-inside-comment (capf) - "Call CAPF only if inside comment. -This function can be used as an advice around an existing Capf." - (and (nth 4 (syntax-ppss)) (funcall capf))) - -;;;###autoload -(defun cape-wrap-inside-string (capf) - "Call CAPF only if inside string. -This function can be used as an advice around an existing Capf." - (and (nth 3 (syntax-ppss)) (funcall capf))) - -;;;###autoload -(defun cape-wrap-accept-all (capf) - "Call CAPF and return a completion table which accepts every input. -This function can be used as an advice around an existing Capf." - (pcase (funcall capf) - (`(,beg ,end ,table . ,plist) - `(,beg ,end ,(cape--accept-all-table table) . ,plist)))) - -(defvar cape--trigger-syntax-table (make-syntax-table (syntax-table)) - "Syntax table used for the trigger character.") - -;;;###autoload -(defun cape-wrap-trigger (capf trigger) - "Ensure that TRIGGER character occurs before point and then call CAPF. -See also `corfu-auto-trigger'. -Example: - (setq corfu-auto-trigger \"/\" - completion-at-point-functions - (list (cape-capf-trigger \\='cape-abbrev ?/)))" - (when-let* ((pos (save-excursion (search-backward (char-to-string trigger) (pos-bol) 'noerror))) - ((save-excursion (not (re-search-backward "\\s-" pos 'noerror))))) - (pcase - ;; Treat the trigger character as punctuation. - (with-syntax-table cape--trigger-syntax-table - (unless (eq (char-syntax trigger) ?.) - (modify-syntax-entry trigger ".")) - (funcall capf)) - (`(,beg ,end ,table . ,plist) - (when (<= pos beg (1+ pos)) - `( ,(1+ pos) ,end ,table - :company-prefix-length t - :exit-function - ,(let ((pos (copy-marker pos)) - (end (copy-marker (1+ pos)))) - (lambda (str status) - (delete-region pos end) - (when-let* ((exit (plist-get plist :exit-function))) - (funcall exit str status)))) - . ,plist)))))) - -(dolist (wrapper (list #'cape-wrap-accept-all #'cape-wrap-buster - #'cape-wrap-case-fold #'cape-wrap-choose - #'cape-wrap-debug #'cape-wrap-inside-code - #'cape-wrap-inside-comment #'cape-wrap-inside-faces - #'cape-wrap-inside-string #'cape-wrap-nonexclusive - #'cape-wrap-noninterruptible #'cape-wrap-passthrough - #'cape-wrap-predicate #'cape-wrap-prefix-length - #'cape-wrap-properties #'cape-wrap-silent - #'cape-wrap-sort #'cape-wrap-super #'cape-wrap-trigger)) - (let ((name (string-remove-prefix "cape-wrap-" (symbol-name wrapper)))) - (defalias (intern (format "cape-capf-%s" name)) - (lambda (capf &rest args) (lambda () (apply wrapper capf args))) - (format "Create a %s Capf from CAPF. -The Capf calls `%s' with CAPF and ARGS as arguments. -See `%s' for documentation." name wrapper wrapper)))) - -;;;###autoload (autoload 'cape-capf-accept-all "cape") -;;;###autoload (autoload 'cape-capf-buster "cape") -;;;###autoload (autoload 'cape-capf-case-fold "cape") -;;;###autoload (autoload 'cape-capf-choose "cape") -;;;###autoload (autoload 'cape-capf-debug "cape") -;;;###autoload (autoload 'cape-capf-inside-code "cape") -;;;###autoload (autoload 'cape-capf-inside-comment "cape") -;;;###autoload (autoload 'cape-capf-inside-faces "cape") -;;;###autoload (autoload 'cape-capf-inside-string "cape") -;;;###autoload (autoload 'cape-capf-nonexclusive "cape") -;;;###autoload (autoload 'cape-capf-noninterruptible "cape") -;;;###autoload (autoload 'cape-capf-passthrough "cape") -;;;###autoload (autoload 'cape-capf-predicate "cape") -;;;###autoload (autoload 'cape-capf-prefix-length "cape") -;;;###autoload (autoload 'cape-capf-properties "cape") -;;;###autoload (autoload 'cape-capf-silent "cape") -;;;###autoload (autoload 'cape-capf-sort "cape") -;;;###autoload (autoload 'cape-capf-super "cape") -;;;###autoload (autoload 'cape-capf-trigger "cape") - -(defvar-keymap cape-prefix-map - :doc "Keymap used as completion entry point. -The keymap should be installed globally under a prefix." - "TAB" #'completion-at-point - "M-TAB" #'completion-at-point - "p" #'completion-at-point - "t" #'complete-tag - "d" #'cape-dabbrev - "h" #'cape-history - "f" #'cape-file - "s" #'cape-elisp-symbol - "e" #'cape-elisp-block - "a" #'cape-abbrev - "l" #'cape-line - "w" #'cape-dict - "k" 'cape-keyword - ":" 'cape-emoji - "\\" 'cape-tex - "_" 'cape-tex - "^" 'cape-tex - "&" 'cape-sgml - "r" 'cape-rfc1345) - -;;;###autoload (autoload 'cape-prefix-map "cape" nil t 'keymap) -(defalias 'cape-prefix-map cape-prefix-map) - -(provide 'cape) -;;; cape.el ends here 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 <mail@daniel-mendler.de> -;; 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 <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Consult implements a set of `consult-<thing>' commands, which aim to -;; improve the way you use Emacs. The commands are founded on -;; `completing-read', which selects from a list of candidate strings. -;; Consult provides an enhanced buffer switcher `consult-buffer' and -;; search and navigation commands like `consult-imenu' and -;; `consult-line'. Searching through multiple files is supported by the -;; asynchronous `consult-grep' command. Many Consult commands support -;; previewing candidates. If a candidate is selected in the completion -;; view, the buffer shows the candidate immediately. - -;; The Consult commands are compatible with multiple completion systems -;; based on the Emacs `completing-read' API, including the default -;; completion system, Vertico, Mct and Icomplete. - -;; See the README for an overview of the available Consult commands and -;; the documentation of the configuration and installation of the -;; package. - -;; The full list of contributors can be found in the acknowledgments -;; section of the README. - -;;; Code: - -(eval-when-compile - (require 'cl-lib) - (require 'subr-x)) -(require 'compat) -(require 'bookmark) - -(defgroup consult nil - "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 "<mode-line> <down-mouse-1>" - (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. - "<remap> <minibuffer-complete-word>" #'self-insert-command - ;; Remap Emacs 29 history and default completion for now - ;; (gh:minad/consult#613). - "<remap> <minibuffer-complete-defaults>" #'ignore - "<remap> <minibuffer-complete-history>" #'consult-history) - -(defvar-keymap consult-narrow-map - :doc "Narrowing keymap which is added to the local minibuffer map. -Note that `consult-narrow-key' and `consult-widen-key' are bound dynamically." - "SPC" consult--narrow-space - "DEL" consult--narrow-delete) - -;;;; Internal API: consult--read - -(defun consult--annotate-align (cand ann) - "Align annotation ANN by computing the maximum CAND width." - (setq consult--annotate-align-width - (max consult--annotate-align-width - (* (ceiling (consult--display-width cand) - consult--annotate-align-step) - consult--annotate-align-step))) - (when ann - (concat - #(" " 0 1 (display (space :align-to (+ left consult--annotate-align-width)))) - ann))) - -(defun consult--add-history (async items) - "Add ITEMS to the minibuffer future history. -ASYNC must be non-nil for async completion functions." - (setq items - (delete-dups - (append - ;; Defaults are at the beginning of the future history - (ensure-list minibuffer-default) - ;; Custom items - (remove "" (remq nil (ensure-list items))) - ;; Add all completions for non-async commands. For async commands - ;; this feature is not useful, since if one selects a completion - ;; candidate, the async search is restarted using that candidate - ;; string. This usually does not yield a desired result since the - ;; async input uses a special format, e.g., `#grep#filter'. - (unless async - (all-completions "" minibuffer-completion-table - minibuffer-completion-predicate))))) - ;; Prefix all items with the initial input from the async split style. - (when (and async (get-text-property (minibuffer-prompt-end) 'consult--split)) - (let* ((beg (minibuffer-prompt-end)) - (end (or (text-property-any beg (point-max) 'consult--split nil) - (point-max))) - (pre (buffer-substring beg end))) - (cl-loop for item in-ref items do - (unless (string-prefix-p pre item) - (setf item (concat pre item)))))) - items) - -(defun consult--setup-keymap (keymap async narrow preview-key) - "Setup minibuffer keymap. - -KEYMAP is a command-specific keymap. -ASYNC must be non-nil for async completion functions. -NARROW is the narrowing configuration. -PREVIEW-KEY are the preview keys." - (let ((old-map (current-local-map)) - (map (make-sparse-keymap))) - - ;; Add narrow keys - (when narrow - (consult--narrow-setup narrow map)) - - ;; Preview trigger keys - (when (and (consp preview-key) (memq :keys preview-key)) - (setq preview-key (plist-get preview-key :keys))) - (setq preview-key (mapcar #'car (consult--preview-key-normalize preview-key))) - (when preview-key - (dolist (key preview-key) - (unless (or (eq key 'any) (lookup-key old-map key)) - (define-key map key #'ignore)))) - - ;; Put the keymap together - (use-local-map - (make-composed-keymap - (delq nil (list keymap - (and async consult-async-map) - (and narrow consult-narrow-map) - map)) - old-map)))) - -(defun consult--tofu-hide-in-minibuffer (&rest _) - "Hide the tofus in the minibuffer." - (let* ((min (minibuffer-prompt-end)) - (max (point-max)) - (pos max)) - (while (and (> pos min) (consult--tofu-p (char-before pos))) - (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'." - "<remap> <isearch-forward>" #'consult-isearch-forward - "<remap> <isearch-backward>" #'consult-isearch-backward) - -(defun consult--isearch-history-candidates () - "Return Isearch history candidates." - ;; Do not throw an error on empty history, in order to allow starting a - ;; search. We do not :require-match here. - (let ((history (if (eq t search-default-mode) - (append regexp-search-ring search-ring) - (append search-ring regexp-search-ring)))) - (delete-dups - (mapcar - (lambda (cand) - ;; The search type can be distinguished via text properties. - (let* ((props (plist-member (text-properties-at 0 cand) - 'isearch-regexp-function)) - (type (pcase (cadr props) - ((and 'nil (guard (not props))) ?r) - ('nil ?l) - ('word-search-regexp ?w) - ('isearch-symbol-regexp ?s) - ('char-fold-to-regexp ?c) - (_ ?u)))) - ;; Disambiguate history items. The same string could - ;; occur with different search types. - (consult--tofu-append cand type))) - history)))) - -(defconst consult--isearch-history-narrow - '((?c . "Char") - (?u . "Custom") - (?l . "Literal") - (?r . "Regexp") - (?s . "Symbol") - (?w . "Word"))) - -;;;###autoload -(defun consult-isearch-history () - "Read a search string with completion from the Isearch history. - -This replaces the current search string if Isearch is active, and -starts a new Isearch session otherwise." - (interactive) - (consult--forbid-minibuffer) - (let* ((isearch-message-function #'ignore) - (cursor-in-echo-area t) ;; Avoid cursor flickering - (candidates (consult--isearch-history-candidates))) - (unless isearch-mode (isearch-mode t)) - (with-isearch-suspended - (setq isearch-new-string - (consult--read - candidates - :prompt "I-search: " - :category 'consult-isearch-history - :history t ;; disable history - :sort nil - :initial isearch-string - :keymap consult-isearch-history-map - :annotate - (lambda (cand) - (consult--annotate-align - cand - (alist-get (consult--tofu-get cand) consult--isearch-history-narrow))) - :group - (lambda (cand transform) - (if transform - cand - (alist-get (consult--tofu-get cand) consult--isearch-history-narrow))) - :lookup - (lambda (selected candidates &rest _) - (if-let* ((found (member selected candidates))) - (substring (car found) 0 -1) - selected)) - :state - (lambda (action cand) - (when (and (eq action 'preview) cand) - (setq isearch-string cand) - (isearch-update-from-string-properties cand) - (isearch-update))) - :narrow - (list :predicate - (lambda (cand) (= (consult--tofu-get cand) consult--narrow)) - :keys consult--isearch-history-narrow)) - isearch-new-message - (mapconcat #'isearch-text-char-description isearch-new-string ""))) - ;; Setting `isearch-regexp' etc only works outside of `with-isearch-suspended'. - (unless (plist-member (text-properties-at 0 isearch-string) 'isearch-regexp-function) - (setq isearch-regexp t - isearch-regexp-function nil)))) - -;;;;; Command: consult-minor-mode-menu - -(defun consult--minor-mode-candidates () - "Return list of minor-mode candidate strings." - (mapcar - (pcase-lambda (`(,name . ,sym)) - (propertize - name - 'consult--candidate sym - 'consult--minor-mode-narrow - (logior - (ash (if (local-variable-if-set-p sym) ?l ?g) 8) - (if (and (boundp sym) (symbol-value sym)) ?i ?o)) - 'consult--minor-mode-group - (concat - (if (local-variable-if-set-p sym) "Local " "Global ") - (if (and (boundp sym) (symbol-value sym)) "On" "Off")))) - (nconc - ;; according to describe-minor-mode-completion-table-for-symbol - ;; the minor-mode-list contains *all* minor modes - (mapcar (lambda (sym) (cons (symbol-name sym) sym)) minor-mode-list) - ;; take the lighters from minor-mode-alist - (delq nil - (mapcar (pcase-lambda (`(,sym ,lighter)) - (when (and lighter (not (equal "" lighter))) - (let (message-log-max) - (setq lighter (string-trim (format-mode-line lighter))) - (unless (string-blank-p lighter) - (cons lighter sym))))) - minor-mode-alist))))) - -(defconst consult--minor-mode-menu-narrow - '((?l . "Local") - (?g . "Global") - (?i . "On") - (?o . "Off"))) - -;;;###autoload -(defun consult-minor-mode-menu () - "Enable or disable minor mode. - -This is an alternative to `minor-mode-menu-from-indicator'." - (interactive) - (call-interactively - (consult--read - (consult--minor-mode-candidates) - :prompt "Minor mode: " - :require-match t - :category 'minor-mode - :group - (lambda (cand transform) - (if transform cand (get-text-property 0 'consult--minor-mode-group cand))) - :narrow - (list :predicate - (lambda (cand) - (let ((narrow (get-text-property 0 'consult--minor-mode-narrow cand))) - (or (= (logand narrow 255) consult--narrow) - (= (ash narrow -8) consult--narrow)))) - :keys - consult--minor-mode-menu-narrow) - :lookup #'consult--lookup-candidate - :history 'consult--minor-mode-menu-history))) - -;;;;; Command: consult-theme - -;;;###autoload -(defun consult-theme (theme) - "Disable current themes and enable THEME from `consult-themes'. - -The command supports previewing the currently selected theme." - (interactive - (list - (let* ((regexp (consult--regexp-filter - (mapcar (lambda (x) (if (stringp x) x (format "\\`%s\\'" x))) - consult-themes))) - (avail-themes (seq-filter - (lambda (x) (string-match-p regexp (symbol-name x))) - (cons 'default (custom-available-themes)))) - (saved-theme (car custom-enabled-themes))) - (consult--read - (mapcar #'symbol-name avail-themes) - :prompt "Theme: " - :require-match t - :category 'theme - :history 'consult--theme-history - :lookup (lambda (selected &rest _) - (setq selected (and selected (intern-soft selected))) - (or (and selected (car (memq selected avail-themes))) - saved-theme)) - :state (lambda (action theme) - (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 diff --git a/.config/emacs/lisp/minadstack/corfu-history.el b/.config/emacs/lisp/minadstack/corfu-history.el deleted file mode 100644 index ba7af47..0000000 --- a/.config/emacs/lisp/minadstack/corfu-history.el +++ /dev/null @@ -1,114 +0,0 @@ -;;; corfu-history.el --- Sorting by history for Corfu -*- lexical-binding: t -*- - -;; Copyright (C) 2022-2026 Free Software Foundation, Inc. - -;; Author: Daniel Mendler <mail@daniel-mendler.de> -;; Maintainer: Daniel Mendler <mail@daniel-mendler.de> -;; Created: 2022 -;; Version: 2.10 -;; Package-Requires: ((emacs "29.1") (compat "31") (corfu "2.10")) -;; URL: https://github.com/minad/corfu - -;; This file is part of GNU Emacs. - -;; This program is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Enable `corfu-history-mode' to sort candidates by their history position. -;; The recently selected candidates are stored in the `corfu-history' variable. -;; If `history-delete-duplicates' is nil, duplicate elements are ranked higher -;; with exponential decay. In order to save the history across Emacs sessions, -;; enable `savehist-mode'. -;; -;; (corfu-history-mode) -;; (savehist-mode) - -;;; Code: - -(require 'corfu) -(eval-when-compile - (require 'cl-lib)) - -(defvar corfu-history nil - "History of Corfu candidates. -The maximum length is determined by the variable `history-length' -or the property `history-length' of `corfu-history'.") - -(defvar corfu-history--hash nil - "Hash table of Corfu candidates.") - -(defcustom corfu-history-duplicate 10 - "History position shift for duplicate history elements. -The more often a duplicate element occurs in the history, the earlier it -appears in the completion list. The shift decays exponentially with -`corfu-history-decay'. Note that duplicates occur only if -`history-delete-duplicates' is disabled." - :type 'number - :group 'corfu) - -(defcustom corfu-history-decay 10 - "Exponential decay for the position shift of duplicate elements. -The shift will decay away after `corfu-history-duplicate' times -`corfu-history-decay' history elements." - :type 'number - :group 'corfu) - -(defun corfu-history--sort-predicate (x y) - "Sorting predicate which compares X and Y." - (or (< (cdr x) (cdr y)) - (and (= (cdr x) (cdr y)) - (corfu--length-string< (car x) (car y))))) - -(defun corfu-history--sort (cands) - "Sort CANDS by history." - (unless corfu-history--hash - (let ((ht (make-hash-table :test #'equal :size (length corfu-history))) - (decay (/ -1.0 (* corfu-history-duplicate corfu-history-decay)))) - (cl-loop for elem in corfu-history for idx from 0 - for r = (if-let* ((r (gethash elem ht))) - ;; Reduce duplicate rank with exponential decay. - (- r (round (* corfu-history-duplicate (exp (* decay idx))))) - ;; Never outrank the most recent element. - (if (= idx 0) (/ most-negative-fixnum 2) idx)) - do (puthash elem r ht)) - (setq corfu-history--hash ht))) - (cl-loop for ht = corfu-history--hash for max = most-positive-fixnum - for cand on cands do - (setcar cand (cons (car cand) (gethash (car cand) ht max)))) - (setq cands (sort cands #'corfu-history--sort-predicate)) - (cl-loop for cand on cands do (setcar cand (caar cand))) - cands) - -;;;###autoload -(define-minor-mode corfu-history-mode - "Update Corfu history and sort completions by history." - :global t :group 'corfu - (if corfu-history-mode - (add-function :override corfu-sort-function #'corfu-history--sort) - (remove-function corfu-sort-function #'corfu-history--sort))) - -(cl-defmethod corfu--insert :before (_status &context (corfu-history-mode (eql t))) - (when (>= corfu--index 0) - (unless (or (not (bound-and-true-p savehist-mode)) - (memq 'corfu-history (bound-and-true-p savehist-ignored-variables))) - (defvar savehist-minibuffer-history-variables) - (add-to-list 'savehist-minibuffer-history-variables 'corfu-history)) - (add-to-history 'corfu-history - (substring-no-properties - (nth corfu--index corfu--candidates))) - (setq corfu-history--hash nil))) - -(provide 'corfu-history) -;;; corfu-history.el ends here diff --git a/.config/emacs/lisp/minadstack/corfu.el b/.config/emacs/lisp/minadstack/corfu.el deleted file mode 100644 index bd3b314..0000000 --- a/.config/emacs/lisp/minadstack/corfu.el +++ /dev/null @@ -1,1444 +0,0 @@ -;;; corfu.el --- COmpletion in Region FUnction -*- lexical-binding: t -*- - -;; Copyright (C) 2021-2026 Free Software Foundation, Inc. - -;; Author: Daniel Mendler <mail@daniel-mendler.de> -;; Maintainer: Daniel Mendler <mail@daniel-mendler.de> -;; Created: 2021 -;; Version: 2.10 -;; Package-Requires: ((emacs "29.1") (compat "31")) -;; URL: https://github.com/minad/corfu -;; Keywords: abbrev, convenience, matching, completion, text - -;; This file is part of GNU Emacs. - -;; This program is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Corfu enhances in-buffer completion with a small completion popup. -;; The current candidates are shown in a popup below or above the -;; point. The candidates can be selected by moving up and down. -;; Corfu is the minimalistic in-buffer completion counterpart of the -;; Vertico minibuffer UI. - -;;; Code: - -(require 'compat) -(eval-when-compile - (require 'cl-lib) - (require 'subr-x)) - -(defgroup corfu nil - "COmpletion in Region FUnction." - :link '(info-link :tag "Info Manual" "(corfu)") - :link '(url-link :tag "Website" "https://github.com/minad/corfu") - :link '(url-link :tag "Wiki" "https://github.com/minad/corfu/wiki") - :link '(emacs-library-link :tag "Library Source" "corfu.el") - :group 'convenience - :group 'tools - :group 'matching - :prefix "corfu-") - -(defcustom corfu-count 10 - "Maximal number of candidates to show." - :type 'natnum) - -(defcustom corfu-scroll-margin 2 - "Number of lines at the top and bottom when scrolling. -The value should lie between 0 and corfu-count/2." - :type 'natnum) - -(defcustom corfu-min-width 15 - "Popup minimum width in characters." - :type 'natnum) - -(defcustom corfu-max-width 100 - "Popup maximum width in characters." - :type 'natnum) - -(defcustom corfu-cycle nil - "Enable cycling for `corfu-next' and `corfu-previous'." - :type 'boolean) - -(defcustom corfu-on-exact-match nil - "Configure how a single exact match should be handled. -- nil: No special handling, continue completion. -- insert: Insert candidate, quit and call the `:exit-function'. -- quit: Quit completion without further action. -- show: Initiate completion even for a single match only." - :type '(choice (const insert) (const show) (const quit) (const nil))) - -(defcustom corfu-continue-commands - '(ignore universal-argument universal-argument-more digit-argument - "\\`corfu-" "\\`scroll-other-window") - "Continue Corfu completion after executing these commands. -The list can contain either command symbols or regular expressions." - :type '(repeat (choice regexp symbol))) - -(defcustom corfu-preview-current 'insert - "Preview currently selected candidate. -If the variable has the value `insert', the candidate is automatically -inserted on further input." - :type '(choice boolean (const insert))) - -(defcustom corfu-preselect 'valid - "Configure if the prompt or first candidate is preselected. -- prompt: Always select the prompt. -- first: Always select the first candidate. -- valid: Only select the prompt if valid and not equal to the first candidate. -- directory: Like first, but select the prompt if it is a directory." - :type '(choice (const prompt) (const valid) (const first) (const directory))) - -(defcustom corfu-separator ?\s - "Component separator character. -The character used for separating components in the input. The presence -of this separator character will inhibit quitting at completion -boundaries, so that any further characters can be entered. To enter the -first separator character, call `corfu-insert-separator' (bound to M-SPC -by default). Useful for multi-component completion styles such as -Orderless." - :type 'character) - -(defcustom corfu-quit-at-boundary 'separator - "Automatically quit at completion boundary. -nil: Never quit at completion boundary. -t: Always quit at completion boundary. -separator: Quit at boundary if no `corfu-separator' has been inserted." - :type '(choice boolean (const separator))) - -(defcustom corfu-quit-no-match 'separator - "Automatically quit if no matching candidate is found. -When staying alive even if there is no match a warning message is -shown in the popup. -nil: Stay alive even if there is no match. -t: Quit if there is no match. -separator: Only stay alive if there is no match and -`corfu-separator' has been inserted." - :type '(choice boolean (const separator))) - -(defcustom corfu-left-margin-width 0.5 - "Width of the left margin in units of the character width." - :type 'float) - -(defcustom corfu-right-margin-width 0.5 - "Width of the right margin in units of the character width." - :type 'float) - -(defcustom corfu-bar-width 0.2 - "Width of the bar in units of the character width." - :type 'float) - -(defcustom corfu-border-width 1 - "Width of the border in pixels, only applies to GUI Emacs." - :type 'natnum) - -(defcustom corfu-margin-formatters nil - "Registry for margin formatter functions. -Each function of the list is called with the completion metadata as -argument until an appropriate formatter is found. The function should -return a formatter function, which takes the candidate string and must -return a string, possibly an icon. In order to preserve correct popup -alignment, the length and display width of the returned string must -precisely span the same number of characters of the fixed-width popup -font. For example the kind-icon package returns a string of length 3 -with a display width of 3 characters." - :type 'hook) - -(defcustom corfu-sort-function #'corfu-sort-length-alpha - "Default sorting function. -This function is used if the completion table does not specify a -`display-sort-function'." - :type `(choice - (const :tag "No sorting" nil) - (const :tag "By length and alpha" ,#'corfu-sort-length-alpha) - (function :tag "Custom function"))) - -(defcustom corfu-sort-override-function nil - "Override sort function which overrides the `display-sort-function'. -This function is used even if a completion table specifies its -own sort function." - :type '(choice (const nil) function)) - -(defcustom corfu-auto nil - "Enable auto completion. -Auto completion is disabled by default for safety and unobtrusiveness. -Note that auto completion is particularly dangerous in untrusted files -since some completion functions may perform arbitrary code execution, -notably the Emacs built-in `elisp-completion-at-point'. See also the -settings `corfu-auto-delay', `corfu-auto-prefix' and -`corfu-auto-commands'." - :type 'boolean) - -(defgroup corfu-faces nil - "Faces used by Corfu." - :group 'corfu - :group 'faces) - -(defface corfu-default - '((((class color) (min-colors 88) (background dark)) :background "#191a1b") - (((class color) (min-colors 88) (background light)) :background "#f0f0f0") - (((background dark)) :background "gray" :foreground "black") - (t :background "gray")) - "Default face, foreground and background colors used for the popup.") - -(defface corfu-current - '((((class color) (min-colors 88) (background dark)) - :background "#00415e" :foreground "white" :extend t) - (((class color) (min-colors 88) (background light)) - :background "#c0efff" :foreground "black" :extend t) - (t :background "magenta" :foreground "white" :extend t)) - "Face used to highlight the currently selected candidate.") - -(defface corfu-bar - '((((class color) (min-colors 88) (background dark)) :background "#a8a8a8") - (((class color) (min-colors 88) (background light)) :background "#505050") - (t :background "black")) - "The background color is used for the scrollbar indicator.") - -(defface corfu-border - '((((class color) (min-colors 88) (background dark)) :background "#323232") - (((class color) (min-colors 88) (background light)) :background "#d7d7d7") - (t :background "gray")) - "The background color used for the thin border.") - -(defface corfu-annotations - '((t :inherit completions-annotations)) - "Face used for annotations.") - -(defface corfu-deprecated - '((t :inherit shadow :strike-through t)) - "Face used for deprecated candidates.") - -(defvar-keymap corfu-mode-map - :doc "Keymap used when `corfu-mode' is active.") - -(defvar-keymap corfu-map - :doc "Keymap used when popup is shown." - "<remap> <move-beginning-of-line>" #'corfu-prompt-beginning - "<remap> <move-end-of-line>" #'corfu-prompt-end - "<remap> <beginning-of-buffer>" #'corfu-first - "<remap> <end-of-buffer>" #'corfu-last - "<remap> <scroll-down-command>" #'corfu-scroll-down - "<remap> <scroll-up-command>" #'corfu-scroll-up - "<remap> <next-line>" #'corfu-next - "<remap> <previous-line>" #'corfu-previous - "<remap> <completion-at-point>" #'corfu-complete - "<remap> <keyboard-escape-quit>" #'corfu-reset - "<down>" #'corfu-next - "<up>" #'corfu-previous - "M-n" #'corfu-next - "M-p" #'corfu-previous - "C-g" #'corfu-quit - "RET" #'corfu-insert - "TAB" #'corfu-complete - "M-TAB" #'corfu-expand - "M-g" 'corfu-info-location - "M-h" 'corfu-info-documentation - "M-SPC" #'corfu-insert-separator) - -(defvar corfu--candidates nil - "List of candidates.") - -(defvar corfu--metadata nil - "Completion metadata.") - -(defvar corfu--base "" - "Base string, which is concatenated with the candidate.") - -(defvar corfu--total 0 - "Length of the candidate list `corfu--candidates'.") - -(defvar corfu--hilit #'identity - "Lazy candidate highlighting function.") - -(defvar corfu--index -1 - "Index of current candidate or negative for prompt selection.") - -(defvar corfu--preselect -1 - "Index of preselected candidate, negative for prompt selection.") - -(defvar corfu--scroll 0 - "Scroll position.") - -(defvar corfu--input nil - "Cons of last prompt contents and point.") - -(defvar corfu--preview-ov nil - "Current candidate overlay.") - -(defvar corfu--change-group nil - "Undo change group.") - -(defvar corfu--frame nil - "Popup frame.") - -(defvar corfu--width 0 - "Popup width of current completion to reduce width fluctuations.") - -(defconst corfu--initial-state - (mapcar - (lambda (k) (cons k (symbol-value k))) - '(corfu--base - corfu--candidates - corfu--hilit - corfu--index - corfu--preselect - corfu--scroll - corfu--input - corfu--total - corfu--preview-ov - corfu--change-group - corfu--metadata - corfu--width)) - "Initial Corfu state.") - -(defvar corfu--frame-parameters - '((no-accept-focus . t) - (no-focus-on-map . t) - (min-width . t) - (min-height . t) - (border-width . 0) - (outer-border-width . 0) - (vertical-scroll-bars . nil) - (horizontal-scroll-bars . nil) - (menu-bar-lines . 0) - (tool-bar-lines . 0) - (tab-bar-lines . 0) - (tab-bar-lines-keep-state . t) - (no-other-frame . t) - (unsplittable . t) - (undecorated . t) - (fullscreen . nil) - (cursor-type . nil) - (no-special-glyphs . t) - (desktop-dont-save . t) - (inhibit-double-buffering . t)) ;; Avoid display artifacts on X/Gtk builds - "Default child frame parameters. -It is recommended to avoid changing these parameters.") - -(defvar corfu--buffer-parameters - '((mode-line-format . nil) - (header-line-format . nil) - (tab-line-format . nil) - (tab-bar-format . nil) - (frame-title-format . "") - (truncate-lines . t) - (cursor-in-non-selected-windows . nil) - (cursor-type . nil) - (show-trailing-whitespace . nil) - (display-line-numbers . nil) - (left-fringe-width . 0) - (right-fringe-width . 0) - (left-margin-width . 0) - (right-margin-width . 0) - (fringes-outside-margins . 0) - (fringe-indicator-alist (continuation) (truncation)) - (indicate-empty-lines . nil) - (indicate-buffer-boundaries . nil) - (buffer-read-only . t) - (pixel-scroll-precision-mode . nil)) - "Default child frame buffer parameters. -It is recommended to avoid changing these parameters.") - -(defvar corfu--mouse-ignore-map - (let ((map (define-keymap "<touchscreen-begin>" #'ignore))) - (dotimes (i 7) - (dolist (k '(mouse down-mouse drag-mouse double-mouse triple-mouse)) - (keymap-set map (format "<%s-%s>" k (1+ i)) #'ignore))) - map) - "Ignore all mouse clicks.") - -(defun corfu--replace (beg end str) - "Replace range between BEG and END with STR." - (unless (equal str (buffer-substring-no-properties beg end)) - (completion--replace beg end str))) - -(defun corfu--capf-wrapper (fun &optional prefix) - "Wrapper for `completion-at-point' FUN. -The wrapper determines if the Capf is applicable at the current -position, performs sanity checking on the returned result and computes -the initial completion state. PREFIX is the minimum prefix length." - (pcase (funcall fun) - (`(,beg ,end ,table . ,plist) - (and (integer-or-marker-p beg) ;; Valid Capf result - (<= beg (point) end) ;; Sanity checking - ;; Check minimal prefix length if given. - (or (not prefix) - (let ((len (or (plist-get plist :company-prefix-length) - (- (point) beg)))) - (or (eq len t) (>= len prefix)))) - (let* ((str (buffer-substring-no-properties beg end)) - (pt (- (point) beg)) - (pred (plist-get plist :predicate)) - (state (corfu--compute (cons str pt) table pred))) - (cond ((alist-get 'corfu--candidates state) - `(,fun ,beg ,end ,table :corfu--state ,state ,@plist)) - ;; Stop with empty result for exclusive Capf. - ((not (eq 'no (plist-get plist :exclusive))) - '(nil)))))))) - -(defun corfu--make-buffer (name) - "Create buffer with NAME." - (let ((fr face-remapping-alist) - (ls line-spacing) - (buffer (get-buffer-create name))) - (with-current-buffer buffer - ;;; XXX HACK install mouse ignore map - (use-local-map corfu--mouse-ignore-map) - (dolist (var corfu--buffer-parameters) - (set-local (car var) (cdr var))) - (setq-local face-remapping-alist (copy-tree fr) - line-spacing ls) - (cl-pushnew 'corfu-default (alist-get 'default face-remapping-alist)) - buffer))) - -(defvar corfu--gtk-resize-child-frames - (let ((case-fold-search t)) - ;; XXX HACK to fix resizing on gtk3/gnome taken from posframe.el - ;; More information: - ;; * https://github.com/minad/corfu/issues/17 - ;; * https://gitlab.gnome.org/GNOME/mutter/-/issues/840 - ;; * https://lists.gnu.org/archive/html/emacs-devel/2020-02/msg00001.html - (and (string-match-p "gtk3" system-configuration-features) - (string-match-p "gnome\\|cinnamon" - (or (getenv "XDG_CURRENT_DESKTOP") - (getenv "DESKTOP_SESSION") "")) - 'resize-mode))) - -;; Not present on non-gtk/non-x builds -(defvar x-gtk-resize-child-frames) -(defvar x-fast-protocol-requests) - -;; Function adapted from posframe.el by tumashu -(defun corfu--make-frame (frame x y width height) - "Show current buffer in child frame at X/Y with WIDTH/HEIGHT. -FRAME is the existing frame." - (when-let* (((frame-live-p frame)) - (timer (frame-parameter frame 'corfu--hide-timer))) - (cancel-timer timer) - (set-frame-parameter frame 'corfu--hide-timer nil)) - (let* ((window-min-height 1) - (window-min-width 1) - (inhibit-redisplay t) - (x-fast-protocol-requests t) - (x-gtk-resize-child-frames corfu--gtk-resize-child-frames) - (before-make-frame-hook) - (after-make-frame-functions) - (parent (window-frame)) - (graphic (display-graphic-p parent)) - (params `((background-color - . ,(face-attribute 'corfu-default :background nil 'default)) - (font . ,(frame-parameter parent 'font)) - (right-fringe . ,right-fringe-width) - (left-fringe . ,left-fringe-width) - (internal-border-width . ,corfu-border-width) - (child-frame-border-width . ,corfu-border-width) - ,@corfu--frame-parameters))) - (unless (and (frame-live-p frame) - (eq (frame-parent frame) - (and (not (and graphic (bound-and-true-p exwm--connection))) - parent)) - ;; Handle mixed tty/graphical sessions - (eq graphic (display-graphic-p frame)) - ;; If there is more than one window, `frame-root-window' may - ;; return nil. Recreate the frame in this case. - (window-live-p (frame-root-window frame))) - (when frame (delete-frame frame)) - (setq frame (make-frame - `((name . ,(if graphic "EmacsCorfuGUI" "EmacsCorfuTTY")) - (parent-frame . ,parent) - (minibuffer . ,(minibuffer-window parent)) - (width . 0) (height . 0) (visibility . nil) - ,@params)))) - ;; XXX HACK Setting the same frame-parameter/face-background is not a nop. - ;; Check before applying the setting. Without the check, the frame flickers - ;; on Mac. We have to apply the face background before adjusting the frame - ;; parameter, otherwise the border is not updated. - (let ((new (face-attribute 'corfu-border :background nil 'default))) - (unless (equal (face-attribute 'internal-border :background frame 'default) new) - (set-face-background 'internal-border new frame)) - ;; XXX The Emacs Mac Port does not support `internal-border', we also have - ;; to set `child-frame-border'. - (unless (equal (face-attribute 'child-frame-border :background frame 'default) new) - (set-face-background 'child-frame-border new frame))) - ;; Reset frame parameters if they changed. For example `tool-bar-mode' - ;; overrides the parameter `tool-bar-lines' for every frame, including child - ;; frames. The child frame API is a pleasure to work with. It is full of - ;; lovely surprises. - (let* ((win (frame-root-window frame)) - (is (frame-parameters frame)) - (diff (cl-loop for p in params for (k . v) = p - unless (equal (alist-get k is) v) collect p))) - (when diff (modify-frame-parameters frame diff)) - ;; XXX HACK: `set-window-buffer' must be called to force fringe update. - (when (or diff (not (eq (window-buffer win) (current-buffer)))) - (set-window-buffer win (current-buffer))) - ;; Disallow selection of root window (gh:minad/corfu#63) - (set-window-parameter win 'no-delete-other-windows t) - (set-window-parameter win 'no-other-window t) - ;; Mark window as dedicated to prevent frame reuse (gh:minad/corfu#60) - (set-window-dedicated-p win t)) - (redirect-frame-focus frame parent) - (pcase-let* ((`(,ox ,oy ,right ,bottom) (frame-edges frame 'outer-edges)) - (border (* 2 corfu-border-width)) - (ow (- (- right ox) left-fringe-width right-fringe-width border)) - (oh (- (- bottom oy) border)) - (pos-change (or (/= x ox) (/= y oy))) - (size-change (or (/= ow width) (/= oh height)))) - (cond - ((and pos-change size-change) - ;; TODO: New Emacs 31 function for faster resizing/movement in one go. - ;; Add this function to Compat 31 as backport. - (static-if (fboundp 'set-frame-size-and-position-pixelwise) - (set-frame-size-and-position-pixelwise frame width height x y) - (set-frame-size frame width height t) - (set-frame-position frame x y))) - (pos-change (set-frame-position frame x y)) - (size-change (set-frame-size frame width height t))))) - (make-frame-visible frame) - ;; Unparent child frame if EXWM is used, otherwise EXWM buffers are drawn on - ;; top of the Corfu child frame. - (when (and (bound-and-true-p exwm--connection) - (display-graphic-p frame) (frame-parent frame)) - (redisplay t) - (set-frame-parameter frame 'parent-frame nil)) - frame) - -(defun corfu--hide-frame-deferred (frame) - "Deferred hiding of child FRAME." - (when (and (frame-live-p frame) (frame-visible-p frame)) - (set-frame-parameter frame 'corfu--hide-timer nil) - (make-frame-invisible frame) - (with-current-buffer (window-buffer (frame-root-window frame)) - (with-silent-modifications - (delete-region (point-min) (point-max)))))) - -(defun corfu--hide-frame (frame) - "Hide child FRAME." - (when (and (frame-live-p frame) (frame-visible-p frame)) - (cond - ((not (display-graphic-p frame)) - (corfu--hide-frame-deferred frame)) - ((not (frame-parameter frame 'corfu--hide-timer)) - (set-frame-parameter - frame 'corfu--hide-timer - (run-at-time 0 nil #'corfu--hide-frame-deferred frame)))))) - -(defun corfu--move-to-front (elem list) - "Move all ELEM (also duplicates) to front of LIST." - (if (member elem list) - (nconc (cl-loop for x in list if (equal x elem) collect x) - (delete elem list)) - list)) - -(defun corfu--filter-completions (&rest args) - "Compute all completions for ARGS with lazy highlighting." - (dlet ((completion-lazy-hilit t) (completion-lazy-hilit-fn nil)) - (static-if (>= emacs-major-version 30) - (cons (apply #'completion-all-completions args) completion-lazy-hilit-fn) - (cl-letf* ((orig-pcm (symbol-function #'completion-pcm--hilit-commonality)) - (orig-flex (symbol-function #'completion-flex-all-completions)) - ((symbol-function #'completion-flex-all-completions) - (lambda (&rest args) - ;; Unfortunately for flex we have to undo the lazy highlighting, since flex uses - ;; the completion-score for sorting, which is applied during highlighting. - (cl-letf (((symbol-function #'completion-pcm--hilit-commonality) orig-pcm)) - (apply orig-flex args)))) - ((symbol-function #'completion-pcm--hilit-commonality) - (lambda (pattern cands) - (setq completion-lazy-hilit-fn - (lambda (x) - ;; `completion-pcm--hilit-commonality' sometimes throws an internal error - ;; for example when entering "/sudo:://u". - (condition-case nil - (car (completion-pcm--hilit-commonality pattern (list x))) - (t x)))) - cands)) - ((symbol-function #'completion-hilit-commonality) - (lambda (cands prefix &optional base) - (setq completion-lazy-hilit-fn - (lambda (x) (car (completion-hilit-commonality (list x) prefix base)))) - (and cands (nconc cands base))))) - (cons (apply #'completion-all-completions args) completion-lazy-hilit-fn))))) - -(defun corfu--try-completion (str table pred pt &optional md) - "Complete STR given TABLE, predicate PRED, point PT and optional metadata MD." - (setq md (or md (completion-metadata (substring str 0 pt) table pred))) - (completion-try-completion str table pred pt md)) - -(defsubst corfu--length-string< (x y) - "Sorting predicate which compares X and Y first by length then by `string<'." - (or (< (length x) (length y)) (and (= (length x) (length y)) (string< x y)))) - -(defmacro corfu--partition! (list form) - "Evaluate FORM for every element and partition LIST." - (cl-with-gensyms (head1 head2 tail1 tail2) - `(let* ((,head1 (cons nil nil)) - (,head2 (cons nil nil)) - (,tail1 ,head1) - (,tail2 ,head2)) - (while ,list - (if (let ((it (car ,list))) ,form) - (progn - (setcdr ,tail1 ,list) - (pop ,tail1)) - (setcdr ,tail2 ,list) - (pop ,tail2)) - (pop ,list)) - (setcdr ,tail1 (cdr ,head2)) - (setcdr ,tail2 nil) - (setq ,list (cdr ,head1))))) - -(defun corfu--move-prefix-candidates-to-front (field cands) - "Move CANDS which match prefix of FIELD to the beginning." - (let* ((word (substring field 0 - (seq-position field corfu-separator))) - (len (length word))) - (corfu--partition! - cands - (and (>= (length it) len) - (eq t (compare-strings word 0 len it 0 len - completion-ignore-case)))))) - -(defun corfu--delete-dups (list) - "Delete `equal-including-properties' consecutive duplicates from LIST." - (let ((beg list)) - (while (cdr beg) - (let ((end (cdr beg))) - (while (equal (car beg) (car end)) (pop end)) - ;; The deduplication is quadratic in the number of duplicates. We could - ;; avoid this via a hash table taking properties into account. - (while (not (eq beg end)) - (let ((dup beg)) - (while (not (eq (cdr dup) end)) - (if (equal-including-properties (car beg) (cadr dup)) - (setcdr dup (cddr dup)) - (pop dup)))) - (pop beg))))) - list) - -(defun corfu--sort-function () - "Return the sorting function." - (or corfu-sort-override-function - (corfu--metadata-get 'display-sort-function) - corfu-sort-function)) - -(defun corfu--compute (input table pred) - "Compute state from INPUT, TABLE and PRED." - (pcase-let* ((`(,str . ,pt) input) - (before (substring str 0 pt)) - (after (substring str pt)) - (corfu--metadata (completion-metadata before table pred)) - ;; bug#47678: `completion-boundaries' fails for `partial-completion' - ;; if the cursor is moved before the slashes of "~//". - ;; See also vertico.el which has the same issue. - (bounds (condition-case nil - (completion-boundaries before table pred after) - (t (cons 0 (length after))))) - (field (substring str (car bounds) (+ pt (cdr bounds)))) - (completing-file (eq (corfu--metadata-get 'category) 'file)) - (`(,all . ,hl) (corfu--filter-completions str table pred pt corfu--metadata)) - (base (or (when-let* ((z (last all))) (prog1 (cdr z) (setcdr z nil))) 0)) - (corfu--base (substring str 0 base)) - (pre nil)) - ;; Filter the ignored file extensions. We cannot use modified predicate for - ;; this filtering, since this breaks the special casing in the - ;; `completion-file-name-table' for `file-exists-p' and `file-directory-p'. - (when completing-file (setq all (completion-pcm--filename-try-filter all))) - ;; Sort using the `display-sort-function' or the Corfu sort functions, and - ;; delete duplicates with respect to `equal-including-properties'. This is - ;; a deviation from the Vertico completion UI with more aggressive - ;; deduplication, where candidates are compared with `equal'. Corfu - ;; preserves candidates which differ in their text properties. Corfu tries - ;; to preserve text properties as much as possible, when calling the - ;; `:exit-function' to help Capfs with candidate disambiguation. This - ;; matters in particular for Lsp backends, which produce duplicates for - ;; overloaded methods. - (setq all (funcall (or (corfu--sort-function) #'identity) all) - all (corfu--move-prefix-candidates-to-front field all)) - (when (and completing-file (not (string-suffix-p "/" field))) - (setq all (corfu--move-to-front (concat field "/") all))) - (setq all (corfu--delete-dups (corfu--move-to-front field all)) - pre (if (or (eq corfu-preselect 'prompt) (not all) - (and completing-file (eq corfu-preselect 'directory) - (= (length corfu--base) (length str)) - (test-completion str table pred)) - (and (eq corfu-preselect 'valid) - (not (equal field (car all))) - (not (and completing-file (equal (concat field "/") (car all)))) - (test-completion str table pred))) - -1 0)) - `((corfu--input . ,input) - (corfu--base . ,corfu--base) - (corfu--metadata . ,corfu--metadata) - (corfu--candidates . ,all) - (corfu--total . ,(length all)) - (corfu--hilit . ,(or hl #'identity)) - (corfu--preselect . ,pre) - (corfu--index . ,(or (and (>= corfu--index 0) (/= corfu--index corfu--preselect) - (seq-position all (nth corfu--index corfu--candidates))) - pre))))) - -(defun corfu--update (&optional interruptible) - "Update state, optionally INTERRUPTIBLE." - (pcase-let* ((`(,beg ,end ,table ,pred . ,_) completion-in-region--data) - (pt (- (point) beg)) - (str (buffer-substring-no-properties beg end)) - (input (cons str pt))) - (unless (equal corfu--input input) - ;; Redisplay such that the input is immediately shown before the expensive - ;; candidate recomputation (gh:minad/corfu#48). See also corresponding - ;; issue gh:minad/vertico#89. - (when interruptible (redisplay)) - ;; Bind non-essential=t to prevent Tramp from opening new connections, - ;; without the user explicitly requesting it via M-TAB. - (pcase (let ((non-essential t)) - (if interruptible - (while-no-input (corfu--compute input table pred)) - (corfu--compute input table pred))) - ('nil (keyboard-quit)) - ((and state (pred consp)) - (dolist (s state) (set (car s) (cdr s)))))) - input)) - -(defun corfu--match-symbol-p (pattern sym) - "Return non-nil if SYM is matching an element of the PATTERN list." - (cl-loop with case-fold-search = nil - for x in (and (symbolp sym) pattern) - thereis (if (symbolp x) - (eq sym x) - (string-match-p x (symbol-name sym))))) - -(defun corfu--metadata-get (prop) - "Return PROP from completion metadata." - ;; Marginalia and various icon packages advise `completion-metadata-get' to - ;; inject their annotations, but are meant only for minibuffer completion. - ;; Therefore call `completion-metadata-get' without advices here. - (let ((completion-extra-properties (nth 4 completion-in-region--data))) - (funcall (advice--cd*r (symbol-function (compat-function completion-metadata-get))) - corfu--metadata prop))) - -(defun corfu--format-candidates (cands) - "Format annotated CANDS." - (cl-loop for c in cands do - (cl-loop for s in-ref c do - (setf s (replace-regexp-in-string "[ \t]*\n[ \t]*" " " s)))) - (let* ((cw (cl-loop for x in cands maximize (string-width (car x)))) - (pw (cl-loop for x in cands maximize (string-width (cadr x)))) - (sw (cl-loop for x in cands maximize (string-width (caddr x)))) - (width (min (max corfu--width corfu-min-width (+ pw cw sw)) - ;; -4 because of margins and some additional safety - corfu-max-width (- (frame-width) 4))) - (trunc (not (display-graphic-p)))) - (setq corfu--width width) - (list pw width - (cl-loop - for (cand prefix suffix) in cands collect - (let ((s (concat - prefix (make-string (- pw (string-width prefix)) ?\s) cand - (when (> sw 0) - (make-string (max 0 (- width pw (string-width cand) - (string-width suffix))) - ?\s)) - suffix))) - (if trunc (truncate-string-to-width s width) s)))))) - -(defun corfu--compute-scroll () - "Compute new scroll position." - (let ((off (max (min corfu-scroll-margin (/ corfu-count 2)) 0)) - (corr (if (= corfu-scroll-margin (/ corfu-count 2)) (1- (mod corfu-count 2)) 0))) - (setq corfu--scroll (min (max 0 (- corfu--total corfu-count)) - (max 0 (+ corfu--index off 1 (- corfu-count)) - (min (- corfu--index off corr) corfu--scroll)))))) - -(defun corfu--candidates-popup (pos) - "Show candidates popup at POS." - (corfu--compute-scroll) - (pcase-let* ((last (min (+ corfu--scroll corfu-count) corfu--total)) - (bar (ceiling (* corfu-count corfu-count) corfu--total)) - (lo (min (- corfu-count bar 1) (floor (* corfu-count corfu--scroll) corfu--total))) - (`(,mf . ,acands) - (corfu--affixate - (cl-loop - repeat corfu-count for c in (nthcdr corfu--scroll corfu--candidates) - collect (funcall corfu--hilit - ;; bug#77754: Highlight unquoted string. - (substring (or (get-text-property - 0 'completion--unquoted c) c)))))) - (`(,pw ,width ,fcands) (corfu--format-candidates acands)) - ;; Disable the left margin if a margin formatter is active. - (corfu-left-margin-width (if mf 0 corfu-left-margin-width))) - ;; Nonlinearity at the end and the beginning - (when (/= corfu--scroll 0) - (setq lo (max 1 lo))) - (when (/= last corfu--total) - (setq lo (min (- corfu-count bar 2) lo))) - (corfu--popup-show pos pw width fcands (- corfu--index corfu--scroll) - (and (> corfu--total corfu-count) lo) bar))) - -(defun corfu--range-valid-p () - "Check the completion range, return non-nil if valid." - (pcase-let ((buf (current-buffer)) - (pt (point)) - (`(,beg ,end . ,_) completion-in-region--data)) - (and beg end - (eq buf (marker-buffer end)) (eq buf (window-buffer)) - (<= beg pt end) - (save-excursion (goto-char beg) (<= (pos-bol) pt (pos-eol)))))) - -(defun corfu--continue-p () - "Check if completion should continue after a command. -Corfu bails out if the current buffer changed unexpectedly or if -point moved out of range, see `corfu--range-valid-p'. Also the -input must satisfy the `completion-in-region-mode--predicate' and -the last command must be listed in `corfu-continue-commands'." - (and (corfu--range-valid-p) - ;; We keep Corfu alive if a `overriding-terminal-local-map' is - ;; installed, e.g., the `universal-argument-map'. It would be good to - ;; think about a better criterion instead. Unfortunately relying on - ;; `this-command' alone is insufficient, since the value of - ;; `this-command' gets clobbered in the case of transient keymaps. - (or overriding-terminal-local-map - ;; Check if it is an explicitly listed continue command - (corfu--match-symbol-p corfu-continue-commands this-command) - (pcase-let ((`(,beg ,end . ,_) completion-in-region--data)) - (and (or (equal (or (car corfu--input) "") "") (< beg end)) ;; Check for empty input - (or (not corfu-quit-at-boundary) ;; Check separator or predicate - (and (eq corfu-quit-at-boundary 'separator) - (or (eq this-command #'corfu-insert-separator) - ;; with separator, any further chars allowed - (seq-contains-p (car corfu--input) corfu-separator))) - (funcall completion-in-region-mode--predicate))))))) - -(defun corfu--preview-current-p () - "Return t if the selected candidate is previewed." - (and corfu-preview-current (>= corfu--index 0) (/= corfu--index corfu--preselect))) - -(defun corfu--preview-current (beg end) - "Show current candidate as overlay given BEG and END." - (when (corfu--preview-current-p) - (corfu--preview-delete) - (setq beg (+ beg (length corfu--base)) - corfu--preview-ov (make-overlay beg end nil)) - (overlay-put corfu--preview-ov 'priority 1000) - (overlay-put corfu--preview-ov 'window (selected-window)) - (overlay-put corfu--preview-ov (if (= beg end) 'after-string 'display) - (substring-no-properties (nth corfu--index corfu--candidates))))) - -(defun corfu--preview-delete () - "Delete the preview overlay." - (when corfu--preview-ov - (delete-overlay corfu--preview-ov) - (setq corfu--preview-ov nil))) - -(defun corfu--window-change (_) - "Window and buffer change hook which quits Corfu." - (unless (corfu--range-valid-p) - (corfu-quit))) - -(defun corfu--debug (&rest _) - "Debugger used by `corfu--protect'." - (let ((inhibit-message t)) - (require 'backtrace) - (declare-function backtrace-to-string "backtrace") - (message "Corfu detected an error:\n%s" (backtrace-to-string))) - (let (message-log-max) - (message "%s %s" - (propertize "Corfu detected an error:" 'face 'error) - (substitute-command-keys "Press \\[view-echo-area-messages] to see the stack trace"))) - nil) - -(defun corfu--protect (fun) - "Protect FUN such that errors are caught. -If an error occurs, the FUN is retried with `debug-on-error' enabled and -the stack trace is shown in the *Messages* buffer." - (static-if (fboundp 'handler-bind) ;; Available on Emacs 30 - (ignore-errors - (handler-bind ((error #'corfu--debug)) - (funcall fun))) - (when (or debug-on-error (condition-case nil - (progn (funcall fun) nil) - (error t))) - (let ((debug-on-error t) - (debugger #'corfu--debug)) - (condition-case nil - (funcall fun) - ((debug error) nil)))))) - -(defun corfu--post-command () - "Refresh Corfu after last command." - (corfu--protect - (lambda () - (if (corfu--continue-p) - (corfu--exhibit) - (corfu-quit))))) - -(defun corfu--goto (index) - "Go to candidate with INDEX." - (setq corfu--index (max corfu--preselect (min index (1- corfu--total))))) - -(defun corfu--exit-function (str status cands) - "Call the `:exit-function' with STR and STATUS. -Lookup STR in CANDS to restore text properties." - (when-let* ((exit (plist-get completion-extra-properties :exit-function))) - (funcall exit (or (car (member str cands)) str) status))) - -(defun corfu--done (str status cands) - "Exit completion and call the exit function with STR and STATUS. -Lookup STR in CANDS to restore text properties." - (let ((completion-extra-properties (nth 4 completion-in-region--data))) - ;; For successful completions, amalgamate undo operations, - ;; such that completion can be undone in a single step. - (undo-amalgamate-change-group corfu--change-group) - (corfu-quit) - (corfu--exit-function str status cands))) - -(defun corfu--setup (beg end table pred) - "Setup Corfu completion state. -See `completion-in-region' for the arguments BEG, END, TABLE, PRED." - (let ((props completion-extra-properties)) - (when (eq (car props) :corfu--state) - (dolist (s (cadr props)) (set (car s) (cdr s))) - (setq props (cddr props))) - (setq end (if (and (markerp end) (marker-insertion-type end)) end (copy-marker end t)) - completion-in-region--data (list (+ 0 beg) end table pred props))) - (completion-in-region-mode) - (activate-change-group (setq corfu--change-group (prepare-change-group))) - (setcdr (assq #'completion-in-region-mode minor-mode-overriding-map-alist) corfu-map) - (add-hook 'pre-command-hook #'corfu--prepare nil 'local) - (add-hook 'window-selection-change-functions #'corfu--window-change nil 'local) - (add-hook 'window-buffer-change-functions #'corfu--window-change nil 'local) - (add-hook 'post-command-hook #'corfu--post-command) - ;; Disable default post-command handling, since we have our own - ;; checks in `corfu--post-command'. - (remove-hook 'post-command-hook #'completion-in-region--postch) - (let ((sym (make-symbol "corfu--teardown")) - (buf (current-buffer))) - (fset sym (lambda () - ;; Ensure that the tear-down runs in the correct buffer, if still alive. - (unless completion-in-region-mode - (remove-hook 'completion-in-region-mode-hook sym) - (corfu--teardown buf)))) - (add-hook 'completion-in-region-mode-hook sym))) - -(defun corfu--in-region (&rest args) - "Corfu completion in region function called with ARGS." - ;; XXX We can get an endless loop when `completion-in-region-function' is set - ;; globally to `corfu--in-region'. This should never happen. - (apply (if (corfu--popup-support-p) #'corfu--in-region-1 - (default-value 'completion-in-region-function)) - args)) - -(defun corfu--in-region-1 (beg end table pred) - "Complete in region, see `completion-in-region' for BEG, END, TABLE, PRED." - (barf-if-buffer-read-only) - ;; Restart the completion. This can happen for example if C-M-/ - ;; (`dabbrev-completion') is pressed while the Corfu popup is already open. - (when completion-in-region-mode (corfu-quit)) - (let* ((pt (max 0 (- (point) beg))) - (str (buffer-substring-no-properties beg end)) - (input (cons str pt)) - (md (completion-metadata (substring str 0 pt) table pred)) - (threshold (completion--cycle-threshold md)) - (completion-in-region-mode-predicate - (or completion-in-region-mode-predicate #'always))) - (pcase (corfu--try-completion str table pred pt md) - ('nil (corfu--message "No match") nil) - ('t (goto-char end) - (corfu--message "Sole match") - (if (eq corfu-on-exact-match 'show) - (corfu--setup beg end table pred) - (corfu--exit-function - str 'finished - (alist-get 'corfu--candidates (corfu--compute input table pred)))) - t) - ((and newinp `(,newstr . ,newpt)) - (setq end (copy-marker end t)) - (corfu--replace beg end newstr) - (goto-char (+ beg newpt)) - (let* ((state (corfu--compute newinp table pred)) - (base (alist-get 'corfu--base state)) - (total (alist-get 'corfu--total state)) - (cands (alist-get 'corfu--candidates state))) - (cond - ((= total 0) - (when (test-completion newstr table pred) - (corfu--exit-function newstr 'finished nil))) - ((= total 1) - ;; Setup popup if `corfu-on-exact-match' is `show' or if completion - ;; can continue. - (if (or (eq corfu-on-exact-match 'show) - (consp (corfu--try-completion newstr table pred newpt))) - (corfu--setup beg end table pred) - (corfu--exit-function (car cands) 'finished nil))) - ;; Too many candidates for cycling -> Setup popup. - ((or (not threshold) (and (not (eq threshold t)) (< threshold total))) - (corfu--setup beg end table pred)) - (t - ;; Cycle through candidates. - (corfu--cycle-candidates total cands (+ (length base) beg) end) - ;; Do not show Corfu when completion is finished after the candidate. - (unless (equal (completion-boundaries (car cands) table pred "") '(0 . 0)) - (corfu--setup beg end table pred))))) - t)))) - -(defun corfu--message (&rest msg) - "Show completion MSG." - (let (message-log-max) (apply #'message msg))) - -(defun corfu--cycle-candidates (total cands beg end) - "Cycle between TOTAL number of CANDS. -See `completion-in-region' for the arguments BEG, END, TABLE, PRED." - (let* ((idx 0) - (map (make-sparse-keymap)) - (replace (lambda () - (interactive) - (corfu--replace beg end (nth idx cands)) - (corfu--message "Cycling %d/%d..." (1+ idx) total) - (setq idx (mod (1+ idx) total)) - (set-transient-map map)))) - (define-key map [remap completion-at-point] replace) - (define-key map [remap corfu-complete] replace) - (define-key map (vector last-command-event) replace) - (funcall replace))) - -(cl-defgeneric corfu--popup-show (pos off width lines &optional curr lo bar) - "Show LINES as popup at POS - OFF. -WIDTH is the width of the popup. -The current candidate CURR is highlighted. -A scroll bar is displayed from LO to LO+BAR." - (let ((lh (max (default-line-height) (cdr (posn-object-width-height pos))))) - (with-current-buffer (corfu--make-buffer " *corfu*") - (let* ((ch (default-line-height)) - (cw (default-font-width)) - ;; bug#74214, bug#37755, bug#37689: Even for larger fringes, fringe - ;; bitmaps can only have a width between 1 and 16. Therefore we - ;; restrict the fringe width to 16 pixel. This restriction may - ;; cause problem on HDPi systems. Hopefully Emacs will adopt - ;; larger fringe bitmaps in the future and lift the restriction. - (ml (min 16 (ceiling (* cw corfu-left-margin-width)))) - (mr (min 16 (ceiling (* cw corfu-right-margin-width)))) - (bw (min mr (ceiling (* cw corfu-bar-width)))) - (graphic (display-graphic-p)) - (marginl (and (not graphic) (propertize " " 'display `(space :width (,ml))))) - (sbar (if graphic - #(" " 0 1 (display (right-fringe corfu--bar corfu--bar))) - (concat - (propertize " " 'display `(space :align-to (- right (,bw)))) - (propertize " " 'face 'corfu-bar 'display `(space :width (,bw)))))) - (cbar (if graphic - #(" " 0 1 (display (left-fringe corfu--nil corfu-current)) - 1 2 (display (right-fringe corfu--bar corfu--cbar))) - sbar)) - (cmargin (and graphic - #(" " 0 1 (display (left-fringe corfu--nil corfu-current)) - 1 2 (display (right-fringe corfu--nil corfu-current))))) - (pos (posn-x-y pos)) - (width (+ (* width cw) (if graphic 0 (+ ml mr)))) - ;; XXX HACK: Minimum popup height must be at least 1 line of the - ;; parent frame (gh:minad/corfu#261). - (height (max lh (* (length lines) ch))) - (edge (window-inside-pixel-edges)) - (border (if graphic corfu-border-width 0)) - (x (max 0 (min (+ (car edge) (- (or (car pos) 0) ml (* cw off) border)) - (- (frame-pixel-width) width - (if graphic (+ ml mr (* 2 border)) 0))))) - (yb (+ (cadr edge) (or (cdr pos) 0) lh - (static-if (< emacs-major-version 31) (window-tab-line-height) 0))) - (y (if (> (+ yb (* corfu-count ch) lh lh) (frame-pixel-height)) - (- yb height lh border border) - yb)) - (bmp (logxor (1- (ash 1 mr)) (1- (ash 1 bw))))) - (setq left-fringe-width (if graphic ml 0) right-fringe-width (if graphic mr 0)) - ;; Define an inverted corfu--bar face - (unless (equal (and (facep 'corfu--bar) (face-attribute 'corfu--bar :foreground)) - (face-attribute 'corfu-bar :background)) - (set-face-attribute (make-face 'corfu--bar) nil - :foreground (face-attribute 'corfu-bar :background))) - (unless (or (= right-fringe-width 0) (eq (get 'corfu--bar 'corfu--bmp) bmp)) - (put 'corfu--bar 'corfu--bmp bmp) - (define-fringe-bitmap 'corfu--bar (vector (lognot bmp)) 1 mr '(top periodic)) - (define-fringe-bitmap 'corfu--nil [0] 1 1) - ;; Fringe bitmaps require symbol face specification, define internal face. - (set-face-attribute (make-face 'corfu--cbar) nil - :inherit '(corfu--bar corfu-current))) - (with-silent-modifications - (delete-region (point-min) (point-max)) - (apply #'insert - (cl-loop for row from 0 for line in lines collect - (let ((str (concat marginl line - (if (and lo (<= lo row (+ lo bar))) - (if (eq row curr) cbar sbar) - (and (eq row curr) cmargin)) - "\n"))) - (when (eq row curr) - (add-face-text-property - 0 (length str) 'corfu-current 'append str)) - str))) - (goto-char (point-min))) - (setq corfu--frame (corfu--make-frame corfu--frame x y width height)))))) - -(cl-defgeneric corfu--popup-hide () - "Hide Corfu popup." - (corfu--hide-frame corfu--frame)) - -(cl-defgeneric corfu--popup-support-p () - "Return non-nil if child frames are supported." - (or (display-graphic-p) (featurep 'tty-child-frames))) - -(cl-defgeneric corfu--insert (status) - "Insert current candidate, exit with STATUS if non-nil." - ;; XXX There is a small bug here, depending on interpretation. - ;; When completing "~/emacs/master/li|/calc" where "|" is the - ;; cursor, then the candidate only includes the prefix - ;; "~/emacs/master/lisp/", but not the suffix "/calc". Default - ;; completion has the same problem when selecting in the - ;; *Completions* buffer. See bug#48356. - (pcase-let* ((`(,beg ,end . ,_) completion-in-region--data) - (str (concat corfu--base (nth corfu--index corfu--candidates)))) - (corfu--replace beg end str) - (corfu--goto -1) ;; Reset selection, completion may continue. - (when status (corfu--done str status nil)) - str)) - -(cl-defgeneric corfu--affixate (cands) - "Annotate CANDS with annotation function." - (let* ((dep (corfu--metadata-get 'company-deprecated)) - (mf (let ((completion-extra-properties (nth 4 completion-in-region--data))) - (run-hook-with-args-until-success 'corfu-margin-formatters corfu--metadata)))) - (setq cands - (if-let* ((aff (corfu--metadata-get 'affixation-function))) - (funcall aff cands) - (if-let* ((ann (corfu--metadata-get 'annotation-function))) - (cl-loop for cand in cands collect - (let ((suff (or (funcall ann cand) ""))) - ;; The default completion UI adds the - ;; `completions-annotations' face if no other faces are - ;; present. We use a custom `corfu-annotations' face to - ;; allow further styling which fits better for popups. - (unless (text-property-not-all 0 (length suff) 'face nil suff) - (setq suff (propertize suff 'face 'corfu-annotations))) - (list cand "" suff))) - (cl-loop for cand in cands collect (list cand "" ""))))) - (cl-loop for x in cands for (c . _) = x do - (when mf - (setf (cadr x) (funcall mf c))) - (when (and dep (funcall dep c)) - (setcar x (setq c (substring c))) - (add-face-text-property 0 (length c) 'corfu-deprecated 'append c))) - (cons mf cands))) - -(cl-defgeneric corfu--prepare () - "Insert selected candidate unless command is marked to continue completion." - (corfu--preview-delete) - ;; Ensure that state is initialized before next Corfu command - (when (and (symbolp this-command) (string-prefix-p "corfu-" (symbol-name this-command))) - (corfu--update)) - ;; If the next command is not listed in `corfu-continue-commands', insert the - ;; currently selected candidate and bail out of completion. This way you can - ;; continue typing after selecting a candidate. The candidate will be inserted - ;; and your new input will be appended. - (and (corfu--preview-current-p) (eq corfu-preview-current 'insert) - ;; See the comment about `overriding-local-map' in `corfu--post-command'. - (not (or overriding-terminal-local-map - (corfu--match-symbol-p corfu-continue-commands this-command))) - (corfu--insert 'exact))) - -(cl-defgeneric corfu--exhibit () - "Exhibit Corfu UI." - (pcase-let ((`(,beg ,end ,table ,pred . ,_) completion-in-region--data) - (`(,str . ,pt) (corfu--update 'interruptible))) - (cond - ;; 1) Single exactly matching candidate and no further completion is possible. - ((and corfu-on-exact-match - (not (eq corfu-on-exact-match 'show)) - (equal corfu--candidates (list str)) - (not (consp (corfu--try-completion str table pred pt)))) - (if (eq corfu-on-exact-match 'quit) - (corfu-quit) - (corfu--done (car corfu--candidates) 'finished nil))) - ;; 2) There exist candidates => Show candidates popup. - (corfu--candidates - (let ((pos (posn-at-point (min (point-max) (+ beg (length corfu--base)))))) - (corfu--preview-current beg end) - (corfu--candidates-popup pos))) - ;; 3) No candidates & `corfu-quit-no-match' & initialized => Confirmation popup. - ((pcase-exhaustive corfu-quit-no-match - ('t nil) - ('nil corfu--input) - ('separator (seq-contains-p (car corfu--input) corfu-separator))) - (corfu--popup-show (posn-at-point beg) 0 8 '(#("No match" 0 8 (face italic))))) - ;; 4) No candidates & initialized => Quit. - (corfu--input (corfu-quit))))) - -(cl-defgeneric corfu--teardown (buffer) - "Tear-down Corfu in BUFFER, which might be dead at this point." - (corfu--popup-hide) - (corfu--preview-delete) - (remove-hook 'post-command-hook #'corfu--post-command) - (when (buffer-live-p buffer) - (with-current-buffer buffer - (remove-hook 'window-selection-change-functions #'corfu--window-change 'local) - (remove-hook 'window-buffer-change-functions #'corfu--window-change 'local) - (remove-hook 'pre-command-hook #'corfu--prepare 'local) - (accept-change-group corfu--change-group))) - (cl-loop for (k . v) in corfu--initial-state do (set k v))) - -(defun corfu-sort-length-alpha (list) - "Sort LIST by length and alphabetically." - (sort list #'corfu--length-string<)) - -(defun corfu-quit () - "Quit Corfu completion." - (interactive) - (completion-in-region-mode -1)) - -(defun corfu-reset () - "Reset Corfu completion. -This command can be executed multiple times by hammering the ESC key. If a -candidate is selected, unselect the candidate. Otherwise reset the input. If -there hasn't been any input, then quit." - (interactive) - (if (/= corfu--index corfu--preselect) - (progn - (corfu--goto -1) - (setq this-command #'corfu-first)) - ;; Cancel all changes and start new change group. - (pcase-let* ((`(,beg ,end . ,_) completion-in-region--data) - (str (buffer-substring-no-properties beg end))) - (cancel-change-group corfu--change-group) - (goto-char end) - (activate-change-group (setq corfu--change-group (prepare-change-group))) - ;; Quit when resetting, when input did not change. - (when (equal str (buffer-substring-no-properties beg end)) - (corfu-quit))))) - -(defun corfu-insert-separator () - "Insert a separator character, inhibiting quit on completion boundary. -If the currently selected candidate is previewed, jump to the input -prompt instead. See `corfu-separator' for more details." - (interactive) - (if (not (corfu--preview-current-p)) - (insert corfu-separator) - (corfu--goto -1) - (unless (or (= (car completion-in-region--data) (point)) - (= (char-before) corfu-separator)) - (insert corfu-separator)))) - -(defun corfu-next (&optional n) - "Go forward N candidates." - (interactive "p") - (let ((index (+ corfu--index (or n 1)))) - (corfu--goto - (cond - ((not corfu-cycle) index) - ((= corfu--total 0) -1) - ((< corfu--preselect 0) (1- (mod (1+ index) (1+ corfu--total)))) - (t (mod index corfu--total)))))) - -(defun corfu-previous (&optional n) - "Go backward N candidates." - (interactive "p") - (corfu-next (- (or n 1)))) - -(defun corfu-scroll-down (&optional n) - "Go back by N pages." - (interactive "p") - (corfu--goto (max 0 (- corfu--index (* (or n 1) corfu-count))))) - -(defun corfu-scroll-up (&optional n) - "Go forward by N pages." - (interactive "p") - (corfu-scroll-down (- (or n 1)))) - -(defun corfu-first () - "Go to first candidate. -If the first candidate is already selected, go to the prompt." - (interactive) - (corfu--goto (if (> corfu--index 0) 0 -1))) - -(defun corfu-last () - "Go to last candidate." - (interactive) - (corfu--goto (1- corfu--total))) - -(defun corfu-prompt-beginning (arg) - "Move to beginning of the prompt line. -If the point is already the beginning of the prompt move to the -beginning of the line. If ARG is not 1 or nil, move backward ARG - 1 -lines first." - (interactive "^p") - (let ((beg (car completion-in-region--data))) - (if (or (not (eq arg 1)) - (and (= corfu--preselect corfu--index) (= (point) beg))) - (move-beginning-of-line arg) - (corfu--goto -1) - (goto-char beg)))) - -(defun corfu-prompt-end (arg) - "Move to end of the prompt line. -If the point is already the end of the prompt move to the end of -the line. If ARG is not 1 or nil, move forward ARG - 1 lines -first." - (interactive "^p") - (let ((end (cadr completion-in-region--data))) - (if (or (not (eq arg 1)) - (and (= corfu--preselect corfu--index) (= (point) end))) - (move-end-of-line arg) - (corfu--goto -1) - (goto-char end)))) - -(defun corfu-complete () - "Complete current input. -If a candidate is selected, insert it. Otherwise invoke -`corfu-expand'. Return non-nil if the input has been expanded." - (interactive) - (if (< corfu--index 0) - (corfu-expand) - ;; Continue completion with selected candidate. Exit with status 'finished - ;; if input is a valid match and no further completion is possible. - (pcase-let ((`(,_beg ,_end ,table ,pred . ,_) completion-in-region--data) - (newstr (corfu--insert nil))) - (and (test-completion newstr table pred) - (or (not (consp (corfu--try-completion newstr table pred (length newstr)))) - ;; Additionally finish completion if at the end of a boundary, - ;; even if other longer candidates match, since the user invoked - ;; `corfu-complete' with an explicitly selected candidate! - (equal (completion-boundaries newstr table pred "") '(0 . 0))) - (corfu--done newstr 'finished nil)) - t))) - -(defun corfu-expand () - "Expands the common prefix of all candidates. -If the currently selected candidate is previewed, invoke -`corfu-complete' instead. Expansion relies on the completion -styles via `completion-try-completion'. Return non-nil if the -input has been expanded." - (interactive) - (if (corfu--preview-current-p) - (corfu-complete) - (pcase-let* ((`(,beg ,end ,table ,pred . ,_) completion-in-region--data) - (pt (max 0 (- (point) beg))) - (str (buffer-substring-no-properties beg end))) - (pcase (corfu--try-completion str table pred pt) - ('t - (goto-char end) - (corfu--done str 'finished corfu--candidates) - t) - ((and `(,newstr . ,newpt) (guard (not (and (= pt newpt) (equal newstr str))))) - (corfu--replace beg end newstr) - (goto-char (+ beg newpt)) - ;; Exit with status 'finished if input is a valid match - ;; and no further completion is possible. - (and (test-completion newstr table pred) - (not (consp (corfu--try-completion newstr table pred newpt))) - (corfu--done newstr 'finished corfu--candidates)) - t))))) - -(defun corfu-insert () - "Insert current candidate. -Quit if no candidate is selected." - (interactive) - (if (>= corfu--index 0) - (corfu--insert 'finished) - (corfu-quit))) - -(defun corfu-send () - "Insert current candidate and send it when inside comint or eshell." - (interactive) - (corfu-insert) - (cond - ((and (derived-mode-p 'eshell-mode) (fboundp 'eshell-send-input)) - (eshell-send-input)) - ((and (derived-mode-p 'comint-mode) (fboundp 'comint-send-input)) - (comint-send-input)))) - -;;;###autoload -(define-minor-mode corfu-mode - "COmpletion in Region FUnction." - :group 'corfu :keymap corfu-mode-map - (cond - (corfu-mode - (when corfu-auto - (require 'corfu-auto) - (add-hook 'post-command-hook 'corfu-auto--post-command 10 'local)) - (setq-local completion-in-region-function #'corfu--in-region)) - (t - (remove-hook 'post-command-hook 'corfu-auto--post-command 'local) - (kill-local-variable 'completion-in-region-function)))) - -(defcustom global-corfu-minibuffer t - "Corfu should be enabled in the minibuffer by `global-corfu-mode'. -The variable can either be t, nil or a custom predicate function. If -the variable is set to t, Corfu is only enabled if the minibuffer has -local `completion-at-point-functions'." - :type '(choice (const t) (const nil) function) - :group 'corfu) - -;;;###autoload -(define-globalized-minor-mode global-corfu-mode - corfu-mode corfu--on - :group 'corfu - :predicate t - (remove-hook 'minibuffer-setup-hook #'corfu--minibuffer-on) - (when (and global-corfu-mode global-corfu-minibuffer) - (add-hook 'minibuffer-setup-hook #'corfu--minibuffer-on 100))) - -(defun corfu--on () - "Enable `corfu-mode' in the current buffer respecting `global-corfu-modes'." - (unless (or noninteractive buffer-read-only (eq (aref (buffer-name) 0) ?\s)) - (corfu-mode))) - -(defun corfu--minibuffer-on () - "Enable `corfu-mode' in the minibuffer respecting `global-corfu-minibuffer'." - (when (and global-corfu-minibuffer (not noninteractive) - (if (functionp global-corfu-minibuffer) - (funcall global-corfu-minibuffer) - (local-variable-p 'completion-at-point-functions))) - (corfu-mode))) - -;; Do not show Corfu commands with M-X -(dolist (sym '( corfu-next corfu-previous corfu-first corfu-last corfu-quit corfu-reset - corfu-complete corfu-insert corfu-scroll-up corfu-scroll-down corfu-expand - corfu-send corfu-insert-separator corfu-prompt-beginning corfu-prompt-end - corfu-info-location corfu-info-documentation ;; autoloads in corfu-info.el - corfu-quick-jump corfu-quick-insert corfu-quick-complete)) ;; autoloads in corfu-quick.el - (put sym 'completion-predicate #'ignore)) - -(defun corfu--capf-wrapper-advice (orig fun which) - "Around advice for `completion--capf-wrapper'. -The ORIG function takes the FUN and WHICH arguments." - (if corfu-mode (corfu--capf-wrapper fun) (funcall orig fun which))) - -(defun corfu--eldoc-advice () - "Return non-nil if Corfu is currently not active." - (not (and corfu-mode completion-in-region-mode))) - -;; Install advice which fixes `completion--capf-wrapper', such that it respects -;; the completion styles for non-exclusive Capfs. See also the fixme comment in -;; the `completion--capf-wrapper' function in minibuffer.el. -(advice-add #'completion--capf-wrapper :around #'corfu--capf-wrapper-advice) - -;; Register Corfu with ElDoc -(advice-add #'eldoc-display-message-no-interference-p - :before-while #'corfu--eldoc-advice) -(eldoc-add-command #'corfu-complete #'corfu-insert #'corfu-expand #'corfu-send) - -(with-eval-after-load 'corfu-terminal - (when (featurep 'tty-child-frames) - (display-warning 'corfu "`corfu-terminal' is not needed on Emacs 31"))) - -(provide 'corfu) -;;; corfu.el ends here diff --git a/.config/emacs/lisp/minadstack/marginalia.el b/.config/emacs/lisp/minadstack/marginalia.el deleted file mode 100644 index 3c49eed..0000000 --- a/.config/emacs/lisp/minadstack/marginalia.el +++ /dev/null @@ -1,1461 +0,0 @@ -;;; marginalia.el --- Enrich existing commands with completion annotations -*- lexical-binding: t -*- - -;; Copyright (C) 2021-2026 Free Software Foundation, Inc. - -;; Author: Omar Antolín Camarena <omar@matem.unam.mx>, Daniel Mendler <mail@daniel-mendler.de> -;; Maintainer: Omar Antolín Camarena <omar@matem.unam.mx>, Daniel Mendler <mail@daniel-mendler.de> -;; Created: 2020 -;; Version: 2.10 -;; Package-Requires: ((emacs "29.1") (compat "30")) -;; URL: https://github.com/minad/marginalia -;; Keywords: docs, help, matching, completion - -;; This file is part of GNU Emacs. - -;; This program is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Enrich existing commands with completion annotations. The information -;; associated with the completion candidates is shown in the minibuffer or the -;; *Completions* buffer. For files the owner and permissions are shown, for -;; buffers the major mode and modification status and for functions or commands -;; the docstring is shown. - -;;; Code: - -(require 'compat) -(eval-when-compile - (require 'subr-x) - (require 'cl-lib)) - -;;;; Customization - -(defgroup marginalia nil - "Enrich existing commands with completion annotations." - :link '(info-link :tag "Info Manual" "(marginalia)") - :link '(url-link :tag "Website" "https://github.com/minad/marginalia") - :link '(emacs-library-link :tag "Library Source" "marginalia.el") - :group 'help - :group 'docs - :group 'minibuffer - :prefix "marginalia-") - -(defcustom marginalia-field-width 80 - "Maximum truncation width of annotation fields. - -This value is adjusted depending on the `window-width'." - :type 'natnum) - -(defcustom marginalia-separator " " - "Annotation field separator." - :type 'string) - -(defcustom marginalia-align 'left - "Alignment of the annotations." - :type '(choice (const :tag "Left" left) - (const :tag "Center" center) - (const :tag "Right" right))) - -(defcustom marginalia-align-offset 0 - "Additional offset added to the alignment." - :type 'natnum) - -(defcustom marginalia-max-relative-age (* 60 60 24 14) - "Maximum relative age in seconds displayed by the file annotator. - -Set to `most-positive-fixnum' to always use a relative age, or 0 to never show -a relative age." - :type 'natnum) - -(defcustom marginalia-remote-file-regexps - '("\\`/\\([^/|:]+\\):") ;; Tramp path - "List of remote file regexps where the files should not be annotated. - -The first match group is displayed instead of the detailed file -attribute information. For Tramp paths, the protocol is -displayed instead." - :type '(repeat regexp)) - -(defcustom marginalia-annotators - (mapcar - (lambda (x) (append x (list 'builtin 'none))) - `((command ,#'marginalia-annotate-command ,#'marginalia-annotate-binding) - (embark-keybinding ,#'marginalia-annotate-embark-keybinding) - (customize-group ,#'marginalia-annotate-customize-group) - (variable ,#'marginalia-annotate-variable) - (function ,#'marginalia-annotate-function) - (face ,#'marginalia-annotate-face) - (color ,#'marginalia-annotate-color) - (unicode-name ,#'marginalia-annotate-char) - (minor-mode ,#'marginalia-annotate-minor-mode) - (symbol ,#'marginalia-annotate-symbol) - (environment-variable ,#'marginalia-annotate-environment-variable) - (input-method ,#'marginalia-annotate-input-method) - (coding-system ,#'marginalia-annotate-coding-system) - (charset ,#'marginalia-annotate-charset) - (package ,#'marginalia-annotate-package) - (imenu ,#'marginalia-annotate-imenu) - (bookmark ,#'marginalia-annotate-bookmark) - (file ,#'marginalia-annotate-file) - (project-file ,#'marginalia-annotate-project-file) - (project-buffer ,#'marginalia-annotate-buffer) - (buffer ,#'marginalia-annotate-buffer) - (library ,#'marginalia-annotate-library) - (theme ,#'marginalia-annotate-theme) - (tab ,#'marginalia-annotate-tab) - (frame ,#'marginalia-annotate-frame) - (multi-category ,#'marginalia-annotate-multi-category))) - "Annotator function registry. -Associates completion categories with annotation functions. Each -annotation function must return a string, which is appended to the -completion candidate. The annotation functions are executed in the -original window and the original buffer, if still alive." - :type '(alist :key-type symbol :value-type (repeat symbol))) - -(defcustom marginalia-classifiers - (list #'marginalia-classify-by-command-name - #'marginalia-classify-original-category - #'marginalia-classify-by-prompt - #'marginalia-classify-symbol) - "List of functions to determine current completion category. -Each function should take no arguments and return a symbol -indicating the category, or nil to indicate it could not -determine it." - :type 'hook) - -(defcustom marginalia-prompt-categories - '(("\\<customize group\\>" . customize-group) - ("\\<M-x\\>" . command) - ("\\<package\\>" . package) - ("\\<bookmark\\>" . bookmark) - ("\\<color\\>" . color) - ("\\<face\\>" . face) - ("\\<environment variable\\>" . environment-variable) - ("\\<function\\|\\(?:hook\\|advice\\) to remove\\>" . function) - ("\\<variable\\>" . variable) - ("\\<input method\\>" . input-method) - ("\\<charset\\>" . charset) - ("\\<coding system\\>" . coding-system) - ("\\<minor mode\\>" . minor-mode) - ("\\<kill-ring\\>" . kill-ring) - ("\\<tab by name\\>" . tab) - ("\\<frame\\>" . frame) - ("\\<library\\>" . library) - ("\\<theme\\>" . theme)) - "Associates regexps to match against minibuffer prompts with categories. -The prompts are matched case-insensitively." - :type '(alist :key-type regexp :value-type symbol)) - -(defcustom marginalia-censor-variables - '("pass\\|auth-source-netrc-cache\\|auth-source-.*-nonce\\|api-?key") - "The value of variables matching any of these regular expressions is not shown. -This configuration variable is useful to hide variables which may -hold sensitive data, e.g., passwords. The variable names are -matched case-sensitively." - :type '(repeat (choice symbol regexp))) - -(defcustom marginalia-command-categories - `((,#'imenu . imenu) - (,#'recentf-open . file) - (,#'where-is . command)) - "Associate commands with a completion category. -The value of `this-command' is used as key for the lookup." - :type '(alist :key-type symbol :value-type symbol)) - -(defgroup marginalia-faces nil - "Faces used by `marginalia-mode'." - :group 'marginalia - :group 'faces) - -(defface marginalia-key - '((t :inherit font-lock-keyword-face)) - "Face used to highlight keys.") - -(defface marginalia-type - '((t :inherit marginalia-key)) - "Face used to highlight types.") - -(defface marginalia-char - '((t :inherit marginalia-key)) - "Face used to highlight character annotations.") - -(defface marginalia-lighter - '((t :inherit marginalia-size)) - "Face used to highlight minor mode lighters.") - -(defface marginalia-on - '((t :inherit success)) - "Face used to signal enabled modes.") - -(defface marginalia-off - '((t :inherit error)) - "Face used to signal disabled modes.") - -(defface marginalia-documentation - '((t :inherit completions-annotations)) - "Face used to highlight documentation strings.") - -(defface marginalia-value - '((t :inherit marginalia-key)) - "Face used to highlight general variable values.") - -(defface marginalia-null - '((t :inherit font-lock-comment-face)) - "Face used to highlight null or unbound variable values.") - -(defface marginalia-true - '((t :inherit font-lock-builtin-face)) - "Face used to highlight true variable values.") - -(defface marginalia-function - '((t :inherit font-lock-function-name-face)) - "Face used to highlight function symbols.") - -(defface marginalia-symbol - '((t :inherit font-lock-type-face)) - "Face used to highlight general symbols.") - -(defface marginalia-list - '((t :inherit font-lock-constant-face)) - "Face used to highlight list expressions.") - -(defface marginalia-mode - '((t :inherit marginalia-key)) - "Face used to highlight buffer major modes.") - -(defface marginalia-date - '((t :inherit marginalia-key)) - "Face used to highlight dates.") - -(defface marginalia-version - '((t :inherit marginalia-number)) - "Face used to highlight package versions.") - -(defface marginalia-archive - '((t :inherit warning)) - "Face used to highlight package archives.") - -(defface marginalia-installed - '((t :inherit success)) - "Face used to highlight the status of packages.") - -(defface marginalia-size - '((t :inherit marginalia-number)) - "Face used to highlight sizes.") - -(defface marginalia-number - '((t :inherit font-lock-constant-face)) - "Face used to highlight numeric values.") - -(defface marginalia-string - '((t :inherit font-lock-string-face)) - "Face used to highlight string values.") - -(defface marginalia-modified - '((t :inherit font-lock-negation-char-face)) - "Face used to highlight buffer modification indicators.") - -(defface marginalia-file-name - '((t :inherit marginalia-documentation)) - "Face used to highlight file names.") - -(defface marginalia-file-owner - '((t :inherit font-lock-preprocessor-face)) - "Face used to highlight file owner and group names.") - -(defface marginalia-file-priv-no - '((t :inherit shadow)) - "Face used to highlight the no file privilege attribute.") - -(defface marginalia-file-priv-dir - '((t :inherit font-lock-keyword-face)) - "Face used to highlight the dir file privilege attribute.") - -(defface marginalia-file-priv-link - '((t :inherit font-lock-keyword-face)) - "Face used to highlight the link file privilege attribute.") - -(defface marginalia-file-priv-read - '((t :inherit font-lock-type-face)) - "Face used to highlight the read file privilege attribute.") - -(defface marginalia-file-priv-write - '((t :inherit font-lock-builtin-face)) - "Face used to highlight the write file privilege attribute.") - -(defface marginalia-file-priv-exec - '((t :inherit font-lock-function-name-face)) - "Face used to highlight the exec file privilege attribute.") - -(defface marginalia-file-priv-other - '((t :inherit font-lock-constant-face)) - "Face used to highlight some other file privilege attribute.") - -(defface marginalia-file-priv-rare - '((t :inherit font-lock-variable-name-face)) - "Face used to highlight a rare file privilege attribute.") - -;;;; Pre-declarations for external packages - -(declare-function bookmark-prop-get "bookmark") - -(declare-function project-current "project") -(declare-function project-root "project") - -(defvar package--builtins) -(defvar package-archive-contents) -(declare-function package--from-builtin "package") -(declare-function package-desc-archive "package") -(declare-function package-desc-status "package") -(declare-function package-desc-summary "package") -(declare-function package-desc-version "package") -(declare-function package-version-join "package") - -(declare-function color-rgb-to-hex "color") -(declare-function color-rgb-to-hsl "color") -(declare-function color-hsl-to-rgb "color") - -;;;; Marginalia mode - -(defalias 'marginalia--orig-completion-metadata-get - (symbol-function - (if (fboundp 'marginalia--orig-completion-metadata-get) - 'marginalia--orig-completion-metadata-get - (compat-function completion-metadata-get))) - "Original `completion-metadata-get' function.") - -(defvar marginalia--pangram "Cwm fjord bank glyphs vext quiz.") - -(defvar marginalia--bookmark-type-transforms - (let ((words (regexp-opt '("handle" "handler" "jump" "bookmark")))) - `((,(format "-+%s-+" words) . "-") - (,(format "\\`%s-+" words) . "") - (,(format "-%s\\'" words) . "") - ("\\`default\\'" . "File") - (".*" . ,#'capitalize))) - "List of bookmark type transformers. -Relying on this mechanism is discouraged in favor of the -`bookmark-handler-type' property. The function names are matched -case-sensitively.") - -(defvar marginalia--cand-width-step 10 - "Round candidate width.") - -(defvar-local marginalia--cand-width-max 20 - "Maximum width of candidates.") - -(defvar marginalia--fontified-file-modes nil - "List of fontified file modes.") - -(defvar-local marginalia--cache nil - "The cache, pair of list and hashtable.") - -(defvar marginalia--cache-size 100 - "Size of the cache, set to 0 to disable the cache. -Disabling the cache is useful on non-incremental UIs like default completion or -for performance profiling of the annotators.") - -(defvar-local marginalia--command nil - "Last command symbol saved in order to allow annotations.") - -(defvar-local marginalia--base-position 0 - "Last completion base position saved to get full file paths.") - -(defvar marginalia--metadata nil - "Completion metadata from the current completion.") - -(defvar marginalia--ellipsis nil) -(defun marginalia--ellipsis () - "Return ellipsis." - (with-memoization marginalia--ellipsis - (cond - ((bound-and-true-p truncate-string-ellipsis)) - ((char-displayable-p ?…) "…") - ("...")))) - -(defun marginalia--abbreviate-file-name (file) - "Abbreviate FILE name without Tramp slowdown." - (let (file-name-handler-alist) - (abbreviate-file-name file))) - -(defun marginalia--truncate (str width) - "Truncate string STR to WIDTH." - (when (floatp width) (setq width (round (* width marginalia-field-width)))) - (when-let* ((pos (string-search "\n" str))) - (setq str (substring str 0 pos))) - (let* ((face (and (not (equal str "")) - (get-text-property (1- (length str)) 'face str))) - (ell (if face - (propertize (marginalia--ellipsis) 'face face) - (marginalia--ellipsis))) - (trunc - (if (< width 0) - (nreverse (truncate-string-to-width (reverse str) (- width) 0 ?\s ell)) - (truncate-string-to-width str width 0 ?\s ell)))) - (unless (string-prefix-p str trunc) - (put-text-property 0 (length trunc) 'help-echo str trunc)) - trunc)) - -(cl-defmacro marginalia--field (field &key truncate face width format) - "Format FIELD as a string according to some options. -TRUNCATE is the truncation width. -WIDTH is the field width. -FORMAT is a format string. -FACE is the name of the face, with which the field should be propertized." - (setq field (if format `(format ,format ,field) `(or ,field ""))) - (when width (setq field `(format ,(format "%%%ds" (- width)) ,field))) - (when truncate (setq field `(marginalia--truncate ,field ,truncate))) - (when face - (setq field (if (or format width truncate) - (cl-with-gensyms (f) - `(let ((,f ,field)) - (put-text-property 0 (length ,f) 'face ,face ,f) - ,f)) - `(propertize ,field 'face ,face)))) - field) - -(defmacro marginalia--fields (&rest fields) - "Format annotation FIELDS as a string with separators in between." - (let ((left t)) - (cons 'concat - (mapcan - (lambda (field) - (if (not (eq (car field) :left)) - `(,@(when left (setq left nil) `(#(" " 0 1 (marginalia--align t)))) - marginalia-separator (marginalia--field ,@field)) - (unless left (error "Left fields must come first")) - `((marginalia--field ,@(cdr field))))) - fields)))) - -(defmacro marginalia--in-minibuffer (&rest body) - "Run BODY inside minibuffer if minibuffer is active. -Otherwise stay within current buffer." - (declare (indent 0)) - `(with-current-buffer (if-let* ((win (active-minibuffer-window))) - (window-buffer win) - (current-buffer)) - ,@body)) - -(defun marginalia--documentation (str) - "Format documentation string STR." - (when str - (marginalia--fields - (str :truncate 1.0 :face 'marginalia-documentation)))) - -(defun marginalia-annotate-binding (cand) - "Annotate command CAND with keybinding." - (when-let* ((sym (intern-soft cand)) - (key (and (commandp sym) (where-is-internal sym nil 'first-only)))) - (format #(" (%s)" 1 5 (face marginalia-key)) (key-description key)))) - -(defun marginalia--annotator (cat) - "Return annotation function for category CAT." - (pcase (car (alist-get cat marginalia-annotators)) - ('none #'ignore) - ('builtin nil) - (fun fun))) - -(defun marginalia-annotate-multi-category (cand) - "Annotate multi-category CAND, dispatching to the appropriate annotator." - (if-let* ((multi (get-text-property 0 'multi-category cand)) - (fun (marginalia--annotator (car multi)))) - ;; Use the Marginalia annotator corresponding to the multi category. - (funcall fun (cdr multi)) - ;; Apply the original annotation function on the original candidate. Bypass - ;; our `marginalia--completion-metadata-get' advice. - (if-let* ((fun (marginalia--orig-completion-metadata-get - marginalia--metadata 'affixation-function))) - (caddar (funcall fun (list cand))) - (when-let* ((fun (marginalia--orig-completion-metadata-get - marginalia--metadata 'annotation-function))) - (funcall fun cand))))) - -(defconst marginalia--advice-regexp - (rx bos - (1+ (seq (? "This function has ") - (or ":before" ":after" ":around" ":override" - ":before-while" ":before-until" ":after-while" - ":after-until" ":filter-args" ":filter-return") - " advice: " (0+ nonl) "\n")) - "\n") - "Regexp to match lines about advice in function documentation strings.") - -;; Taken from advice--make-docstring, is this robust? -(defun marginalia--advised (fun) - "Return t if function FUN is advised." - (let ((flist (indirect-function fun))) - (advice--p (if (eq 'macro (car-safe flist)) (cdr flist) flist)))) - -(defun marginalia--symbol-class (s) - "Return symbol class characters for symbol S. - -This function is an extension of `help--symbol-class'. It returns -more fine-grained and more detailed symbol information. - -Function: -f function -c command -C interactive-only command -m macro -F special-form -M module function -P primitive -g cl-generic -p pure -s side-effect-free -@ autoloaded -! advised -- obsolete -& alias - -Variable: -u custom (U modified compared to global value) -v variable -l local (L modified compared to default value) -- obsolete -& alias - -Other: -G custom group -a face -t cl-type" - (let ((class - (append - (when (fboundp s) - (list - (cond - ((get s 'pure) '("p" . "pure")) - ((get s 'side-effect-free) '("s" . "side-effect-free"))) - (cond - ((commandp s) - (if (get s 'interactive-only) - '("C" . "interactive-only command") - '("c" . "command"))) - ((cl-generic-p s) '("g" . "cl-generic")) - ((macrop (symbol-function s)) '("m" . "macro")) - ((special-form-p (symbol-function s)) '("F" . "special-form")) - ((subr-primitive-p (symbol-function s)) '("P" . "primitive")) - ((module-function-p (symbol-function s)) '("M" . "module function")) - (t '("f" . "function"))) - (and (autoloadp (symbol-function s)) '("@" . "autoload")) - (and (marginalia--advised s) '("!" . "advised")) - (and (symbolp (symbol-function s)) - (cons "&" (format "alias for `%s'" (symbol-function s)))) - (and (get s 'byte-obsolete-info) '("-" . "obsolete")))) - (when (boundp s) - (list - (when (local-variable-if-set-p s) - (if (ignore-errors - (not (equal (symbol-value s) - (default-value s)))) - '("L" . "local, modified from global") - '("l" . "local, unmodified"))) - (if (get s 'standard-value) - (if (ignore-errors - (not (equal (symbol-value s) - (eval (car (get s 'standard-value)))))) - '("U" . "custom, modified from standard") - '("u" . "custom, unmodified")) - '("v" . "variable")) - (and (not (eq (ignore-errors (indirect-variable s)) s)) - (cons "&" (format "alias for `%s'" (ignore-errors (indirect-variable s))))) - (and (get s 'byte-obsolete-variable) '("-" . "obsolete")))) - (list - (and (get s 'group-documentation) '("G" . "custom group")) - (and (facep s) '("a" . "face")) - (and (get s 'cl--class) '("t" . "cl-type")))))) ;; cl-find-class, cl--find-class - (setq class (delq nil class)) - (propertize - (format "%-6s" (mapconcat #'car class "")) - 'help-echo - (mapconcat (pcase-lambda (`(,x . ,y)) (concat x " " y)) class "\n")))) - -(defun marginalia--definition-prefix (sym) - "Return annotation string if SYM is a definition prefix. -Sometimes symbols which are not yet loaded appear in completion tables -if `help-enable-completion-autoload' is enabled. These symbols -originate from the `definition-prefixes' hash table." - (when-let* (((bound-and-true-p help-enable-completion-autoload)) - (files (gethash (symbol-name sym) definition-prefixes))) - (format "[Not yet loaded from %s. See `help-enable-completion-autoload'.]" - (string-join files ", ")))) - -(defun marginalia--function-doc (sym) - "Documentation string of function SYM." - (if-let* ((str (ignore-errors (documentation sym)))) - (save-match-data - (if (string-match marginalia--advice-regexp str) - (substring str (match-end 0)) - str)) - (marginalia--definition-prefix sym))) - -;; Derived from elisp-get-fnsym-args-string -(defun marginalia--function-args (sym) - "Return function arguments for SYM." - (let (tmp) - (elisp-function-argstring - (cond - ((listp (setq tmp (gethash (indirect-function sym) - advertised-signature-table t))) - tmp) - ((setq tmp (help-split-fundoc - (ignore-errors (documentation sym t)) - sym)) - (car tmp)) - ((setq tmp (help-function-arglist sym)) - (if (and (stringp tmp) (string-search "not available" tmp)) - ;; A shorter text fits better into the limited Marginalia space. - "[autoload]" - tmp)))))) - -(defun marginalia-annotate-symbol (cand) - "Annotate symbol CAND with its documentation string." - (when-let* ((sym (intern-soft cand))) - (marginalia--fields - (:left (marginalia-annotate-binding cand)) - ((marginalia--symbol-class sym) :face 'marginalia-type) - ((if (fboundp sym) - (marginalia--function-doc sym) - (or (cl-loop - for doc in '(variable-documentation - face-documentation - group-documentation) - thereis (ignore-errors (documentation-property sym doc))) - (marginalia--definition-prefix sym))) - :truncate 1.0 :face 'marginalia-documentation) - ((marginalia--abbreviate-file-name (or (symbol-file sym) "")) - :truncate -0.5 :face 'marginalia-file-name)))) - -(defun marginalia-annotate-command (cand) - "Annotate command CAND with its documentation string. -Similar to `marginalia-annotate-symbol', but does not show symbol class." - (when-let* ((sym (intern-soft cand))) - (concat - (marginalia-annotate-binding cand) - (marginalia--documentation (marginalia--function-doc sym))))) - -(defun marginalia-annotate-embark-keybinding (cand) - "Annotate Embark keybinding CAND with its documentation string. -Similar to `marginalia-annotate-command', but does not show the -keybinding since CAND includes it." - (when-let* ((cmd (get-text-property 0 'embark-command cand)) - ((symbolp cmd))) - (marginalia--documentation (marginalia--function-doc cmd)))) - -(defun marginalia-annotate-imenu (cand) - "Annotate imenu CAND with its documentation string." - (when (derived-mode-p 'emacs-lisp-mode) - ;; Strip until the last whitespace in order to support flat imenu - (marginalia-annotate-symbol (replace-regexp-in-string "\\`.* " "" cand)))) - -(defun marginalia-annotate-function (cand) - "Annotate function CAND with its documentation string." - (when-let* ((sym (intern-soft cand))) - (marginalia--fields - (:left (marginalia-annotate-binding cand)) - ((marginalia--symbol-class sym) :face 'marginalia-type) - ((marginalia--function-args sym) :face 'marginalia-value - :truncate 0.5) - ((marginalia--function-doc sym) - :truncate 1.0 :face 'marginalia-documentation)))) - -(defun marginalia--variable-value (sym) - "Return the variable value of SYM as string." - (cond - ((not (boundp sym)) - (propertize "#<unbound>" 'face 'marginalia-null)) - ((and marginalia-censor-variables - (let ((name (symbol-name sym)) - case-fold-search) - (cl-loop for r in marginalia-censor-variables - thereis (if (symbolp r) - (eq r sym) - (string-match-p r name))))) - (propertize "*****" - 'face 'marginalia-null - 'help-echo "Hidden due to `marginalia-censor-variables'")) - (t - (let ((val (symbol-value sym))) - (pcase val - ('nil (propertize "nil" 'face 'marginalia-null)) - ('t (propertize "t" 'face 'marginalia-true)) - ((pred keymapp) (propertize "#<keymap>" 'face 'marginalia-value)) - ((pred bool-vector-p) (propertize "#<bool-vector>" 'face 'marginalia-value)) - ((pred hash-table-p) (propertize "#<hash-table>" 'face 'marginalia-value)) - ((pred syntax-table-p) (propertize "#<syntax-table>" 'face 'marginalia-value)) - ;; Emacs bug#53988: abbrev-table-p throws an error - ((guard (static-if (< emacs-major-version 30) - (and (vectorp val) (ignore-errors (abbrev-table-p val))) - (abbrev-table-p val))) - (propertize "#<abbrev-table>" 'face 'marginalia-value)) - ((pred char-table-p) (propertize "#<char-table>" 'face 'marginalia-value)) - ;; Callable objects or object closures (OClosures) - ((guard (oclosure-type val)) - (format (propertize "#<oclosure %s>" 'face 'marginalia-function) (oclosure-type val))) - ((pred byte-code-function-p) (propertize "#<byte-code-function>" 'face 'marginalia-function)) - ((and (pred functionp) (pred symbolp)) - ;; We are not consistent here, values are generally printed - ;; unquoted. But we make an exception for function symbols to visually - ;; distinguish them from symbols. I am not entirely happy with this, - ;; but we should not add quotation to every type. - (format (propertize "#'%s" 'face 'marginalia-function) val)) - ((pred recordp) (format (propertize "#<record %s>" 'face 'marginalia-value) (type-of val))) - ((pred symbolp) (propertize (symbol-name val) 'face 'marginalia-symbol)) - ((pred numberp) - (propertize (number-to-string val) - 'face 'marginalia-number - 'help-echo (and (integerp val) - (format "%d, #o%o, #x%x%s" val val val - (if (characterp val) (format ", ?%c" val) ""))))) - (_ (let ((print-escape-newlines t) - (print-escape-control-characters t) - ;;(print-escape-multibyte t) - (print-level 3) - (print-length marginalia-field-width)) - (propertize - (replace-regexp-in-string - ;; `print-escape-control-characters' does not escape Unicode control characters. - "[\x0-\x1F\x7f-\x9f\x061c\x200e\x200f\x202a-\x202e\x2066-\x2069]" - (lambda (x) (format "\\x%x" (string-to-char x))) - (prin1-to-string - (if (stringp val) - ;; Get rid of string properties to save some of the precious space - (substring-no-properties - val 0 - (min (length val) marginalia-field-width)) - val)) - 'fixedcase 'literal) - 'face - (cond - ((listp val) 'marginalia-list) - ((stringp val) 'marginalia-string) - (t 'marginalia-value)))))))))) - -(defun marginalia-annotate-variable (cand) - "Annotate variable CAND with its documentation string." - (when-let* ((sym (intern-soft cand))) - (marginalia--fields - ((marginalia--symbol-class sym) :face 'marginalia-type) - ((marginalia--variable-value sym) :truncate 0.5) - ((or (documentation-property sym 'variable-documentation) - (marginalia--definition-prefix sym)) - :truncate 1.0 :face 'marginalia-documentation)))) - -(defun marginalia-annotate-environment-variable (cand) - "Annotate environment variable CAND with its current value." - (when-let* ((val (getenv cand))) - (marginalia--fields - (val :truncate 1.0 :face 'marginalia-value)))) - -(defun marginalia-annotate-face (cand) - "Annotate face CAND with its documentation string and face example." - (when-let* ((sym (intern-soft cand))) - (marginalia--fields - ;; HACK: Manual alignment to fix misalignment due to face - ((concat marginalia--pangram #(" " 0 1 (display (space :align-to center)))) - :face sym) - ((documentation-property sym 'face-documentation) - :truncate 1.0 :face 'marginalia-documentation)))) - -(defun marginalia-annotate-color (cand) - "Annotate face CAND with its documentation string and face example." - (when-let* ((rgb (color-name-to-rgb cand))) - (pcase-let* ((`(,r ,g ,b) rgb) - (`(,h ,s ,l) (apply #'color-rgb-to-hsl rgb)) - (cr (color-rgb-to-hex r 0 0)) - (cg (color-rgb-to-hex 0 g 0)) - (cb (color-rgb-to-hex 0 0 b)) - (ch (apply #'color-rgb-to-hex (color-hsl-to-rgb h 1 0.5))) - (cs (apply #'color-rgb-to-hex (color-hsl-to-rgb h s 0.5))) - (cl (apply #'color-rgb-to-hex (color-hsl-to-rgb 0 0 l)))) - (marginalia--fields - (" " :face `(:background ,(apply #'color-rgb-to-hex rgb))) - ((format - "%s%s%s %s" - (propertize "r" 'face `(:background ,cr :foreground ,(readable-foreground-color cr))) - (propertize "g" 'face `(:background ,cg :foreground ,(readable-foreground-color cg))) - (propertize "b" 'face `(:background ,cb :foreground ,(readable-foreground-color cb))) - (color-rgb-to-hex r g b 2))) - ((format - "%s%s%s %3s° %3s%% %3s%%" - (propertize "h" 'face `(:background ,ch :foreground ,(readable-foreground-color ch))) - (propertize "s" 'face `(:background ,cs :foreground ,(readable-foreground-color cs))) - (propertize "l" 'face `(:background ,cl :foreground ,(readable-foreground-color cl))) - (round (* 360 h)) - (round (* 100 s)) - (round (* 100 l)))))))) - -(defun marginalia-annotate-char (cand) - "Annotate character CAND with its general character category and character code." - (when-let* ((char (char-from-name cand t))) - (marginalia--fields - (:left char :format" (%c)" :face 'marginalia-char) - (char :format "%06X" :face 'marginalia-number) - ((char-code-property-description - 'general-category - (get-char-code-property char 'general-category)) - :width 30 :face 'marginalia-documentation)))) - -(defun marginalia-annotate-minor-mode (cand) - "Annotate minor-mode CAND with status and documentation string." - (let* ((sym (intern-soft cand)) - (message-log-max nil) - (mode (if (and sym (boundp sym)) - sym - (lookup-minor-mode-from-indicator cand))) - (lighter (cdr (assq mode minor-mode-alist))) - (lighter-str (and lighter (string-trim (format-mode-line (cons t lighter)))))) - (marginalia--fields - ((if (and (boundp mode) (symbol-value mode)) - (propertize "On" 'face 'marginalia-on) - (propertize "Off" 'face 'marginalia-off)) :width 3) - ((if (local-variable-if-set-p mode) "Local" "Global") :width 6 :face 'marginalia-type) - (lighter-str :width 20 :face 'marginalia-lighter) - ((marginalia--function-doc mode) - :truncate 1.0 :face 'marginalia-documentation)))) - -(defun marginalia-annotate-package (cand) - "Annotate package CAND with its description summary." - (when-let* ((pkg-alist (bound-and-true-p package-alist)) - ;; See `package-get-version'. - (name (replace-regexp-in-string - "-[0-9]\\(?:[0-9.]\\|pre\\|beta\\|alpha\\|snapshot\\)+\\'" "" cand)) - (pkg (intern-soft name)) - (desc (or (unless (equal name cand) - (cl-loop with version = (substring cand (1+ (length name))) - for d in (alist-get pkg pkg-alist) - if (equal (package-version-join (package-desc-version d)) version) - return d)) - ;; taken from `describe-package-1' - (car (alist-get pkg pkg-alist)) - (if-let* ((built-in (assq pkg package--builtins))) - (package--from-builtin built-in) - (car (alist-get pkg package-archive-contents)))))) - (marginalia--fields - ((package-version-join (package-desc-version desc)) :truncate 16 :face 'marginalia-version) - ((cond - ((package-desc-archive desc) (propertize (package-desc-archive desc) 'face 'marginalia-archive)) - (t (propertize (or (package-desc-status desc) "orphan") 'face 'marginalia-installed))) :truncate 12) - ((package-desc-summary desc) :truncate 1.0 :face 'marginalia-documentation)))) - -(defun marginalia--bookmark-type (bm) - "Return bookmark type string of BM. -The string is transformed according to `marginalia--bookmark-type-transforms'." - (let ((handler (or (bookmark-prop-get bm 'handler) 'bookmark-default-handler))) - (and - ;; Some libraries use lambda handlers instead of symbols. For - ;; example the function `xwidget-webkit-bookmark-make-record' is - ;; affected. I consider this bad style since then the lambda is - ;; persisted. - (symbolp handler) - (or (get handler 'bookmark-handler-type) - (let ((str (symbol-name handler)) - case-fold-search) - (dolist (transformer marginalia--bookmark-type-transforms str) - (when (string-match-p (car transformer) str) - (setq str - (if (stringp (cdr transformer)) - (replace-regexp-in-string (car transformer) (cdr transformer) str) - (funcall (cdr transformer) str)))))))))) - -(defun marginalia-annotate-bookmark (cand) - "Annotate bookmark CAND with its file name and front context string." - (when-let* ((bm (assoc cand (bound-and-true-p bookmark-alist)))) - (marginalia--fields - ((marginalia--bookmark-type bm) :width 10 :face 'marginalia-type) - ((or (bookmark-prop-get bm 'filename) - (bookmark-prop-get bm 'location)) - :truncate (if (bookmark-prop-get bm 'filename) -0.5 0.5) - :face 'marginalia-file-name) - ((let ((front (or (bookmark-prop-get bm 'front-context-string) "")) - (rear (or (bookmark-prop-get bm 'rear-context-string) ""))) - (unless (and (string-blank-p front) (string-blank-p rear)) - (string-clean-whitespace - (concat front (marginalia--ellipsis) rear)))) - :truncate 0.5 :face 'marginalia-documentation)))) - -(defun marginalia-annotate-customize-group (cand) - "Annotate customization group CAND with its documentation string." - (marginalia--documentation (documentation-property (intern cand) 'group-documentation))) - -(defun marginalia-annotate-input-method (cand) - "Annotate input method CAND with its description." - (marginalia--documentation (nth 4 (assoc cand input-method-alist)))) - -(defun marginalia-annotate-charset (cand) - "Annotate charset CAND with its description." - (marginalia--documentation (charset-description (intern cand)))) - -(defun marginalia-annotate-coding-system (cand) - "Annotate coding system CAND with its description." - (marginalia--documentation (coding-system-doc-string (intern cand)))) - -(defun marginalia--buffer-status (buffer) - "Return the status of BUFFER as a string." - (format-mode-line '((:propertize "%1*%1+%1@" face marginalia-modified) - marginalia-separator - (7 (:propertize "%I" face marginalia-size)) - marginalia-separator - ;; InactiveMinibuffer has 18 letters, but there are longer names. - ;; For example Org-Agenda produces very long mode names. - ;; Therefore we have to truncate. - (20 (-20 (:propertize mode-name face marginalia-mode)))) - nil nil buffer)) - -(defun marginalia--buffer-file (buffer) - "Return the file or process name of BUFFER." - (if-let* ((proc (get-buffer-process buffer))) - (format "(%s %s) %s" - proc (process-status proc) - (marginalia--abbreviate-file-name (buffer-local-value 'default-directory buffer))) - (marginalia--abbreviate-file-name - (or (cond - ;; see ibuffer-buffer-file-name - ((buffer-file-name buffer)) - ((when-let* ((dir (and (local-variable-p 'dired-directory buffer) - (buffer-local-value 'dired-directory buffer)))) - (expand-file-name (if (stringp dir) dir (car dir)) - (buffer-local-value 'default-directory buffer)))) - ((local-variable-p 'list-buffers-directory buffer) - (buffer-local-value 'list-buffers-directory buffer))) - "")))) - -(defun marginalia-annotate-buffer (cand) - "Annotate buffer CAND with modification status, file name and major mode." - ;; Emacs 31: `project--read-project-buffer' uses `uniquify-get-unique-names' - (when-let* ((buffer (or (and (stringp cand) - (get-text-property 0 'uniquify-orig-buffer cand)) - (get-buffer cand)))) - (if (buffer-live-p buffer) - (marginalia--fields - ((marginalia--buffer-status buffer)) - ((marginalia--buffer-file buffer) - :truncate -0.5 :face 'marginalia-file-name)) - (marginalia--fields ("(dead buffer)" :face 'error))))) - -(defun marginalia--full-candidate (cand) - "Return completion candidate CAND in full. -For some completion tables, the completion candidates offered are -meant to be only a part of the full minibuffer contents. For -example, during file name completion the candidates are one path -component of a full file path." - (if-let* ((win (active-minibuffer-window))) - (with-current-buffer (window-buffer win) - (concat (let ((end (minibuffer-prompt-end))) - (buffer-substring-no-properties - end (+ end marginalia--base-position))) - cand)) - ;; no minibuffer is active, trust that cand already conveys all - ;; necessary information (there's not much else we can do) - cand)) - -(defun marginalia--remote-file-p (file) - "Return non-nil if FILE is remote. -The return value is a string describing the remote location, -e.g., the protocol." - (save-match-data - (setq file (let (file-name-handler-alist) - (substitute-in-file-name file))) - (cl-loop for r in marginalia-remote-file-regexps - if (string-match r file) - return (or (match-string 1 file) "remote")))) - -(defun marginalia--annotate-local-file (cand) - "Annotate local file CAND." - (marginalia--in-minibuffer - (when-let* ((attrs (ignore-errors - ;; may throw permission denied errors - (file-attributes (substitute-in-file-name - (marginalia--full-candidate cand)) - 'integer)))) - ;; HACK: Format differently accordingly to alignment, since the file owner - ;; is usually not displayed. Otherwise we will see an excessive amount of - ;; whitespace in front of the file permissions. Furthermore the alignment - ;; in `consult-buffer' will look ugly. Find a better solution! - (if (eq marginalia-align 'right) - (marginalia--fields - ;; File owner at the left - ((marginalia--file-owner attrs) :face 'marginalia-file-owner) - ((marginalia--file-modes attrs)) - ((marginalia--file-size attrs) :face 'marginalia-size :width -7) - ((marginalia--time (file-attribute-modification-time attrs)) - :face 'marginalia-date :width -12)) - (marginalia--fields - ((marginalia--file-modes attrs)) - ((marginalia--file-size attrs) :face 'marginalia-size :width -7) - ((marginalia--time (file-attribute-modification-time attrs)) - :face 'marginalia-date :width -12) - ;; File owner at the right - ((marginalia--file-owner attrs) :face 'marginalia-file-owner)))))) - -(defun marginalia-annotate-file (cand) - "Annotate file CAND with its size, modification time and other attributes. -These annotations are skipped for remote paths." - (if-let* ((remote (or (marginalia--remote-file-p cand) - (when-let* ((win (active-minibuffer-window))) - (with-current-buffer (window-buffer win) - (marginalia--remote-file-p (minibuffer-contents-no-properties))))))) - (marginalia--fields (remote :format "*%s*" :face 'marginalia-documentation)) - (marginalia--annotate-local-file cand))) - -(defun marginalia--file-owner (attrs) - "Return file owner given ATTRS." - (let ((uid (file-attribute-user-id attrs)) - (gid (file-attribute-group-id attrs))) - (when (or (/= (user-uid) uid) (/= (group-gid) gid)) - (format "%s:%s" - (or (user-login-name uid) uid) - (or (group-name gid) gid))))) - -(defun marginalia--file-size (attrs) - "Return formatted file size given ATTRS." - (propertize (file-size-human-readable (file-attribute-size attrs)) - 'help-echo (number-to-string (file-attribute-size attrs)))) - -(defun marginalia--file-modes (attrs) - "Return fontified file modes given the ATTRS." - ;; Without caching this can a be significant portion of the time - ;; `marginalia-annotate-file' takes to execute. Caching improves performance - ;; by about a factor of 20. - (setq attrs (file-attribute-modes attrs)) - (or (car (member attrs marginalia--fontified-file-modes)) - (progn - (setq attrs (substring attrs)) ;; copy because attrs is about to be modified - (dotimes (i (length attrs)) - (put-text-property - i (1+ i) 'face - (pcase (aref attrs i) - (?- 'marginalia-file-priv-no) - (?d 'marginalia-file-priv-dir) - (?l 'marginalia-file-priv-link) - (?r 'marginalia-file-priv-read) - (?w 'marginalia-file-priv-write) - (?x 'marginalia-file-priv-exec) - ((or ?s ?S ?t ?T) 'marginalia-file-priv-other) - (_ 'marginalia-file-priv-rare)) - attrs)) - (push attrs marginalia--fontified-file-modes) - attrs))) - -(defconst marginalia--time-relative - `((100 "sec" 1) - (,(* 60 100) "min" 60.0) - (,(* 3600 30) "hour" 3600.0) - (,(* 3600 24 400) "day" ,(* 3600.0 24.0)) - (nil "year" ,(* 365.25 24 3600))) - "Formatting used by the function `marginalia--time-relative'.") - -;; Taken from `seconds-to-string'. -(defun marginalia--time-relative (time) - "Format TIME as a relative age." - (setq time (max 0 (float-time (time-since time)))) - (let ((sts marginalia--time-relative) here) - (while (and (car (setq here (pop sts))) (<= (car here) time))) - (setq time (round time (caddr here))) - (format "%s %s%s ago" time (cadr here) (if (= time 1) "" "s")))) - -(defun marginalia--time-absolute (time) - "Format TIME as an absolute age." - (let ((system-time-locale "C")) - (format-time-string - (if (> (decoded-time-year (decode-time (current-time))) - (decoded-time-year (decode-time time))) - " %Y %b %d" - "%b %d %H:%M") - time))) - -(defun marginalia--time (time) - "Format file age TIME, suitably for use in annotations." - (propertize - (if (< (float-time (time-since time)) marginalia-max-relative-age) - (marginalia--time-relative time) - (marginalia--time-absolute time)) - 'help-echo (format-time-string "%Y-%m-%d %T" time))) - -(defvar-local marginalia--project-root 'unset) -(defun marginalia--project-root () - "Return project root." - (marginalia--in-minibuffer - (when (eq marginalia--project-root 'unset) - (setq marginalia--project-root - (or (let ((prompt (minibuffer-prompt)) - case-fold-search) - (and (string-match - "\\`\\(?:Dired\\|Find file\\) in \\(.*\\): \\'" - prompt) - (match-string 1 prompt))) - (when-let* ((proj (project-current))) - (project-root proj))))) - marginalia--project-root)) - -(defun marginalia-annotate-project-file (cand) - "Annotate file CAND with its size, modification time and other attributes." - ;; Absolute project directories also report project-file category - (if (file-name-absolute-p cand) - (marginalia-annotate-file cand) - (when-let* ((root (marginalia--project-root))) - (marginalia-annotate-file (expand-file-name cand root))))) - -(defvar-local marginalia--library-cache nil) -(defun marginalia--library-cache () - "Return hash table from library name to library file." - (marginalia--in-minibuffer - ;; `locate-file' and `locate-library' are bottlenecks for the - ;; annotator. Therefore we compute all the library paths first. - (unless marginalia--library-cache - (setq marginalia--library-cache (make-hash-table :test #'equal)) - (dolist (dir (delete-dups - (reverse ;; Reverse because of shadowing - (append load-path (custom-theme--load-path))))) ;; Include themes - (dolist (file (ignore-errors - (directory-files dir 'full - "\\.el\\(?:\\.gz\\)?\\'"))) - (puthash (marginalia--library-name file) - file marginalia--library-cache)))) - marginalia--library-cache)) - -(defun marginalia--library-name (file) - "Get name of library FILE." - (replace-regexp-in-string "\\(\\.gz\\|\\.elc?\\)+\\'" "" - (file-name-nondirectory file))) - -(defun marginalia--library-doc (file) - "Return library documentation string for FILE." - (let ((doc (get-text-property 0 'marginalia--library-doc file))) - (unless doc - ;; Extract documentation string. We cannot use `lm-summary' here, - ;; since it decompresses the whole file, which is slower. - (setq doc (or (ignore-errors - (let ((shell-file-name "sh") - (shell-command-switch "-c")) - (shell-command-to-string - (format (if (string-suffix-p ".gz" file) - "gzip -c -q -d %s | head -n1" - "head -n1 %s") - (shell-quote-argument file))))) - "")) - (cond - ((string-match "\\`(define-package\\s-+\"\\([^\"]+\\)\"" doc) - (setq doc (format "Generated package description from %s.el" - (match-string 1 doc)))) - ((string-match "\\`;+\\s-*" doc) - (setq doc (substring doc (match-end 0))) - (when (string-match "\\`[^ \t]+\\s-+-+\\s-+" doc) - (setq doc (substring doc (match-end 0)))) - (when (string-match "\\s-*-\\*-" doc) - (setq doc (substring doc 0 (match-beginning 0))))) - (t (setq doc ""))) - ;; Add the documentation string to the cache - (put-text-property 0 1 'marginalia--library-doc doc file)) - doc)) - -(defun marginalia-annotate-library (cand) - "Annotate library CAND with documentation and path." - (setq cand (marginalia--library-name cand)) - (when-let* ((file (gethash cand (marginalia--library-cache)))) - (marginalia--fields - ;; Display if the corresponding feature is loaded. - ;; feature/=library file, but better than nothing. - ((when-let* ((sym (intern-soft cand))) - (when (memq sym features) - (propertize "Loaded" 'face 'marginalia-on))) - :width 8) - ((marginalia--library-doc file) - :truncate 1.0 :face 'marginalia-documentation) - ((marginalia--abbreviate-file-name (file-name-directory file)) - :truncate -0.5 :face 'marginalia-file-name)))) - -(defun marginalia-annotate-theme (cand) - "Annotate theme CAND with documentation and path." - (when-let* ((file (gethash (concat cand "-theme") (marginalia--library-cache)))) - (marginalia--fields - ((marginalia--library-doc file) - :truncate 1.0 :face 'marginalia-documentation) - ((marginalia--abbreviate-file-name (file-name-directory file)) - :truncate -1.0 :face 'marginalia-file-name)))) - -(defun marginalia-annotate-frame (cand) - "Annotate frame named CAND with window and buffer information." - (when-let* ((frame (cl-loop - for f in (frame-list) - if (or (equal cand (frame-parameter f 'name)) - ;; `frame-id' is an Emacs 31 addition - (when (fboundp 'frame-id) - (equal cand (number-to-string (frame-id f))))) - return f))) - (let ((wins (window-list frame))) - (marginalia--fields - ((length wins) :format "win:%s" :face 'marginalia-size) - ((if (eq frame (selected-frame)) - "(current frame)" - (mapconcat (lambda (w) (buffer-name (window-buffer w))) wins " ")) - :face 'marginalia-documentation))))) - -(defun marginalia-annotate-tab (cand) - "Annotate named tab CAND with tab index, window and buffer information." - (when-let* ((tabs (funcall tab-bar-tabs-function)) - (index (seq-position - tabs nil - (lambda (tab _) (equal (alist-get 'name tab) cand))))) - (let* ((tab (nth index tabs)) - (ws (alist-get 'ws tab)) - (bufs (window-state-buffers ws))) - ;; When the buffer key is present in the window state it is added in front - ;; of the window buffer list and gets duplicated. - (when (cadr (assq 'buffer ws)) (pop bufs)) - (marginalia--fields - (:left (1+ index) :format " (%s)" :face 'marginalia-key) - ((if (eq (car tab) 'current-tab) - (length (window-list nil 'no-minibuf)) - (length bufs)) - :format "win:%s" :face 'marginalia-size) - ((or (alist-get 'group tab) 'none) - :format "group:%s" :face 'marginalia-type :truncate 20) - ((if (eq (car tab) 'current-tab) - "(current tab)" - (string-join bufs " ")) - :face 'marginalia-documentation))))) - -(defun marginalia-classify-by-command-name () - "Lookup category for current command." - (and marginalia--command - (or (alist-get marginalia--command marginalia-command-categories) - ;; The command can be an alias, e.g., `recentf' -> `recentf-open'. - (when-let* ((chain (function-alias-p marginalia--command))) - (alist-get (car (last chain)) marginalia-command-categories))))) - -(defun marginalia-classify-original-category () - "Return original category reported by completion metadata." - ;; Bypass our `marginalia--completion-metadata-get' advice. - (when-let* ((cat (marginalia--orig-completion-metadata-get marginalia--metadata 'category))) - ;; Ignore `symbol-help' category in order to ensure that the categories are - ;; refined to our categories function and variable. - (and (not (eq cat 'symbol-help)) cat))) - -(defun marginalia-classify-symbol () - "Determine if currently completing symbols." - (when-let* ((mct minibuffer-completion-table)) - (when (or (eq mct 'help--symbol-completion-table) - (obarrayp mct) - (and (not (functionp mct)) (consp mct) (symbolp (car mct)))) ; assume list of symbols - 'symbol))) - -(defun marginalia-classify-by-prompt () - "Determine category by matching regexps against the minibuffer prompt. -This runs through the `marginalia-prompt-categories' alist -looking for a regexp that matches the prompt." - (when-let* ((prompt (minibuffer-prompt))) - (setq prompt - (replace-regexp-in-string "(.*?default.*?)\\|\\[.*?\\]" "" prompt)) - (cl-loop with case-fold-search = t - for (regexp . category) in marginalia-prompt-categories - when (string-match-p regexp prompt) - return category))) - -(defun marginalia--cache-reset (&rest _) - "Reset the cache." - (setq marginalia--cache (and marginalia--cache (> marginalia--cache-size 0) - (cons nil (make-hash-table :test #'equal - :size marginalia--cache-size))))) - -(defun marginalia--cached (cache fun key) - "Cached application of function FUN with KEY. -The CACHE keeps around the last `marginalia--cache-size' computed -annotations. The cache is mainly useful when scrolling in -completion UIs like Vertico or Icomplete." - (if cache - (let ((ht (cdr cache))) - (or (gethash key ht) - (let ((val (funcall fun key))) - (push key (car cache)) - (puthash key val ht) - (when (>= (hash-table-count ht) marginalia--cache-size) - (let ((end (last (car cache) 2))) - (remhash (cadr end) ht) - (setcdr end nil))) - val))) - (funcall fun key))) - -(defun marginalia--align (cands) - "Align annotations of CANDS according to `marginalia-align'." - (cl-loop - for (cand . ann) in cands do - (when-let* ((align (text-property-any 0 (length ann) 'marginalia--align t ann))) - (setq marginalia--cand-width-max - (max marginalia--cand-width-max - (* (ceiling (+ (string-width cand) (string-width ann 0 align)) - marginalia--cand-width-step) - marginalia--cand-width-step))))) - (cl-loop - for (cand . ann) in cands collect - (progn - (when-let* ((align (text-property-any 0 (length ann) 'marginalia--align t ann))) - (put-text-property - align (1+ align) 'display - `(space :align-to - ,(pcase-exhaustive marginalia-align - ('center `(+ center ,marginalia-align-offset)) - ('left `(+ left ,(+ marginalia-align-offset marginalia--cand-width-max))) - ('right `(+ right ,(+ marginalia-align-offset 1 - (- (string-width ann 0 align) - (string-width ann))))))) - ann)) - (list cand "" ann)))) - -(defun marginalia--affixate (metadata annotator cands) - "Affixate CANDS given METADATA and Marginalia ANNOTATOR." - ;; Compute minimum width of windows, which display the minibuffer, including - ;; the miniwindow. In general the computed width corresponds to the full - ;; frame width, since the miniwindow spans the full frame. For example - ;; `vertico-buffer' displays the minibuffer in a separate window. Similarly, - ;; we could detect other types of completion buffers, e.g., Embark Collect or - ;; the default completion buffer, and compute smaller widths. - (let* ((width (cl-loop for win in (get-buffer-window-list) minimize (window-width win))) - (marginalia-field-width (min (/ width 2) marginalia-field-width)) - (marginalia--metadata metadata) - (cache marginalia--cache) - (orig-buf minibuffer--original-buffer)) - (marginalia--align - ;; Run the annotators in the original window. `with-selected-window' - ;; is necessary because of `lookup-minor-mode-from-indicator'. - ;; Otherwise it would suffice to only change the current buffer. We - ;; need the `selected-window' fallback for Embark Occur. - (with-selected-window (or (minibuffer-selected-window) (selected-window)) - (with-current-buffer (if (buffer-live-p orig-buf) orig-buf (current-buffer)) - (cl-loop for cand in cands collect - (let ((ann (or (marginalia--cached cache annotator cand) ""))) - (cons cand (if (string-blank-p ann) "" ann))))))))) - -(defun marginalia--completion-metadata-get (metadata prop) - "Meant as :before-until advice for `completion-metadata-get'. -METADATA is the metadata. -PROP is the property which is looked up." - (pcase prop - ('affixation-function - ;; We do want the advice triggered for `completion-metadata-get'. - (when-let* ((cat (completion-metadata-get metadata 'category)) - (annotator (marginalia--annotator cat))) - (apply-partially #'marginalia--affixate metadata annotator))) - ('category - ;; Find the completion category by trying each of our classifiers. - ;; Store the metadata for `marginalia-classify-original-category'. - (let ((marginalia--metadata metadata)) - (run-hook-with-args-until-success 'marginalia-classifiers))))) - -(defun marginalia--minibuffer-setup () - "Setup the minibuffer for Marginalia. -Remember `this-command' for `marginalia-classify-by-command-name'." - (setq marginalia--cache t marginalia--command this-command) - ;; Reset cache if window size changes, recompute alignment - (add-hook 'window-state-change-hook #'marginalia--cache-reset nil 'local) - (add-hook 'context-menu-functions #'marginalia--context-menu nil t) - (marginalia--cache-reset)) - -(defun marginalia--base-position (completions) - "Record the base position of COMPLETIONS." - ;; As a small optimization we track the base position only for file - ;; completions, since `marginalia--full-candidate' is currently used only by - ;; the file annotation function. - ;; bug#75910: category instead of `minibuffer-completing-file-name' - (when minibuffer-completing-file-name - (let ((base (or (cdr (last completions)) 0))) - (unless (= marginalia--base-position base) - (marginalia--cache-reset) - (setq marginalia--base-position base - marginalia--cand-width-max (default-value 'marginalia--cand-width-max))))) - completions) - -;;;###autoload -(define-minor-mode marginalia-mode - "Annotate completion candidates with richer information." - :global t :group 'marginalia - (if marginalia-mode - (progn - ;; Remember `this-command' in order to select the annotation function. - (add-hook 'minibuffer-setup-hook #'marginalia--minibuffer-setup) - ;; Replace the metadata function. - (advice-add (compat-function completion-metadata-get) :before-until #'marginalia--completion-metadata-get) - (advice-add #'completion-metadata-get :before-until #'marginalia--completion-metadata-get) - ;; Record completion base position, for `marginalia--full-candidate' - (advice-add #'completion-all-completions :filter-return #'marginalia--base-position)) - (advice-remove #'completion-all-completions #'marginalia--base-position) - (advice-remove (compat-function completion-metadata-get) #'marginalia--completion-metadata-get) - (advice-remove #'completion-metadata-get #'marginalia--completion-metadata-get) - (remove-hook 'minibuffer-setup-hook #'marginalia--minibuffer-setup))) - -(defun marginalia--completion-metadata () - "Get completion metadata." - (let* ((end (minibuffer-prompt-end)) - (pt (max 0 (- (point) end)))) - (completion-metadata (buffer-substring-no-properties end (+ end pt)) - minibuffer-completion-table - minibuffer-completion-predicate))) - -(defun marginalia--builtin-annotator-p (md) - "Builtin annotator available in metadata MD?" - (or (marginalia--orig-completion-metadata-get md 'annotation-function) - (marginalia--orig-completion-metadata-get md 'affixation-function))) - -;;;###autoload -(defun marginalia-cycle () - "Cycle between annotators in `marginalia-annotators'." - ;; Only show `marginalia-cycle' in M-x in recursive minibuffers - (declare (completion (lambda (&rest _) (> (minibuffer-depth) 1)))) - (interactive) - (with-current-buffer (window-buffer - (or (active-minibuffer-window) - (user-error "Marginalia: No active minibuffer"))) - (let* ((md (marginalia--completion-metadata)) - (cat (or (completion-metadata-get md 'category) - (user-error "Marginalia: Unknown completion category"))) - (ann (or (assq cat marginalia-annotators) - (user-error "Marginalia: No annotators found for category `%s'" cat)))) - (setcdr ann (append (cddr ann) (list (cadr ann)))) - ;; When the builtin annotator is selected and no builtin function is - ;; available, skip to the next annotator. Bypass the - ;; `marginalia--completion-metadata-get' advice. - (when (and (eq (cadr ann) 'builtin) (not (marginalia--builtin-annotator-p md))) - (setcdr ann (append (cddr ann) (list (cadr ann))))) - (marginalia--cache-reset) - (message "Marginalia: Use annotator `%s' for category `%s'" (cadr ann) cat)))) - -(defun marginalia--context-menu (menu _event) - "Add Marginalia commands to context MENU." - (when-let* ((md (marginalia--completion-metadata)) - (cat (completion-metadata-get md 'category)) - (ann (assq cat marginalia-annotators)) - (items (cl-loop - for fun in (cdr ann) for i from 0 - if (or (not (eq fun 'builtin)) (marginalia--builtin-annotator-p md)) - collect - (vector - (thread-last (symbol-name fun) - (replace-regexp-in-string ".*?-+annotate-+" "") - (replace-regexp-in-string "-+" " ") - capitalize) - (let ((i i)) - (lambda () - (interactive) - (setcdr ann (append (drop i (cdr ann)) (take i (cdr ann)))) - (marginalia--cache-reset) - (message "Marginalia: Use annotator `%s' for category `%s'" (cadr ann) cat))) - :style 'radio :selected (eq fun (cadr ann)))))) - (define-key menu [marginalia] - `("Marginalia" . ,(easy-menu-create-menu - "" `(["Cycle" marginalia-cycle] "---" ,@items))))) - menu) - -(provide 'marginalia) -;;; marginalia.el ends here diff --git a/.config/emacs/lisp/minadstack/orderless.el b/.config/emacs/lisp/minadstack/orderless.el deleted file mode 100644 index 7cee5c8..0000000 --- a/.config/emacs/lisp/minadstack/orderless.el +++ /dev/null @@ -1,672 +0,0 @@ -;;; orderless.el --- Completion style for matching regexps in any order -*- lexical-binding: t; -*- - -;; Copyright (C) 2021-2026 Free Software Foundation, Inc. - -;; Author: Omar Antolín Camarena <omar@matem.unam.mx> -;; Maintainer: Omar Antolín Camarena <omar@matem.unam.mx>, Daniel Mendler <mail@daniel-mendler.de> -;; Keywords: matching, completion -;; Version: 1.6 -;; URL: https://github.com/oantolin/orderless -;; Package-Requires: ((emacs "27.1") (compat "30")) - -;; This file is part of GNU Emacs. - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This package provides an `orderless' completion style that divides -;; the pattern into components (space-separated by default), and -;; matches candidates that match all of the components in any order. - -;; Completion styles are used as entries in the variables -;; `completion-styles' and `completion-category-overrides', see their -;; documentation. - -;; To use this completion style you can use the following minimal -;; configuration: - -;; (setq completion-styles '(orderless basic)) - -;; You can customize the `orderless-component-separator' to decide how -;; the input pattern is split into component regexps. The default -;; splits on spaces. You might want to add hyphens and slashes, for -;; example, to ease completion of symbols and file paths, -;; respectively. - -;; Each component can match in any one of several matching styles: -;; literally, as a regexp, as an initialism, in the flex style, or as -;; word prefixes. It is easy to add new styles: they are functions -;; from strings to strings that map a component to a regexp to match -;; against. The variable `orderless-matching-styles' lists the -;; matching styles to be used for components, by default it allows -;; literal and regexp matching. - -;;; Code: - -(require 'compat) -(eval-when-compile (require 'cl-lib)) - -(defgroup orderless nil - "Completion method that matches space-separated regexps in any order." - :link '(info-link :tag "Info Manual" "(orderless)") - :link '(url-link :tag "Website" "https://github.com/oantolin/orderless") - :link '(emacs-library-link :tag "Library Source" "orderless.el") - :group 'minibuffer) - -(defface orderless-match-face-0 - '((default :weight bold) - (((class color) (min-colors 88) (background dark)) :foreground "#72a4ff") - (((class color) (min-colors 88) (background light)) :foreground "#223fbf") - (t :foreground "blue")) - "Face for matches of components numbered 0 mod 4.") - -(defface orderless-match-face-1 - '((default :weight bold) - (((class color) (min-colors 88) (background dark)) :foreground "#ed92f8") - (((class color) (min-colors 88) (background light)) :foreground "#8f0075") - (t :foreground "magenta")) - "Face for matches of components numbered 1 mod 4.") - -(defface orderless-match-face-2 - '((default :weight bold) - (((class color) (min-colors 88) (background dark)) :foreground "#90d800") - (((class color) (min-colors 88) (background light)) :foreground "#145a00") - (t :foreground "green")) - "Face for matches of components numbered 2 mod 4.") - -(defface orderless-match-face-3 - '((default :weight bold) - (((class color) (min-colors 88) (background dark)) :foreground "#f0ce43") - (((class color) (min-colors 88) (background light)) :foreground "#804000") - (t :foreground "yellow")) - "Face for matches of components numbered 3 mod 4.") - -(defcustom orderless-component-separator #'orderless-escapable-split-on-space - "Component separators for orderless completion. -This can either be a string, which is passed to `split-string', -or a function of a single string argument." - :type `(choice (const :tag "Spaces" " +") - (const :tag "Spaces, hyphen or slash" " +\\|[-/]") - (const :tag "Escapable space" - ,#'orderless-escapable-split-on-space) - (const :tag "Quotable spaces" ,#'split-string-and-unquote) - (regexp :tag "Custom regexp") - (function :tag "Custom function"))) - -(defcustom orderless-match-faces - [orderless-match-face-0 - orderless-match-face-1 - orderless-match-face-2 - orderless-match-face-3] - "Vector of faces used (cyclically) for component matches." - :type '(vector face)) - -(defcustom orderless-matching-styles - (list #'orderless-literal #'orderless-regexp) - "List of component matching styles. -If this variable is nil, regexp matching is assumed. - -A matching style is simply a function from strings to regexps. -The returned regexps can be either strings or s-expressions in -`rx' syntax. If the resulting regexp has no capturing groups, -the entire match is highlighted, otherwise just the captured -groups are. Several are provided with this package: try -customizing this variable to see a list of them." - :type '(repeat function) - :options (list #'orderless-regexp - #'orderless-literal - #'orderless-initialism - #'orderless-prefixes - #'orderless-flex)) - -(defcustom orderless-affix-dispatch-alist - `((?% . ,#'char-fold-to-regexp) - (?! . ,#'orderless-not) - (?& . ,#'orderless-annotation) - (?, . ,#'orderless-initialism) - (?= . ,#'orderless-literal) - (?^ . ,#'orderless-literal-prefix) - (?~ . ,#'orderless-flex)) - "Alist associating characters to matching styles. -The function `orderless-affix-dispatch' uses this list to -determine how to match a pattern component: if the component -either starts or ends with a character used as a key in this -alist, the character is removed from the component and the rest is -matched according the style associated to it." - :type `(alist - :key-type character - :value-type (choice - (const :tag "Annotation" ,#'orderless-annotation) - (const :tag "Literal" ,#'orderless-literal) - (const :tag "Without literal" ,#'orderless-without-literal) - (const :tag "Literal prefix" ,#'orderless-literal-prefix) - (const :tag "Regexp" ,#'orderless-regexp) - (const :tag "Not" ,#'orderless-not) - (const :tag "Flex" ,#'orderless-flex) - (const :tag "Initialism" ,#'orderless-initialism) - (const :tag "Prefixes" ,#'orderless-prefixes) - (const :tag "Ignore diacritics" ,#'char-fold-to-regexp) - (function :tag "Custom matching style")))) - -(defun orderless-affix-dispatch (component _index _total) - "Match COMPONENT according to the styles in `orderless-affix-dispatch-alist'. -If the COMPONENT starts or ends with one of the characters used -as a key in `orderless-affix-dispatch-alist', then that character -is removed and the remainder of the COMPONENT is matched in the -style associated to the character." - (let ((len (length component)) - (alist orderless-affix-dispatch-alist)) - (when (> len 0) - (cond - ;; Ignore single dispatcher character - ((and (= len 1) (alist-get (aref component 0) alist)) #'ignore) - ;; Prefix - ((when-let* ((style (alist-get (aref component 0) alist))) - (cons style (substring component 1)))) - ;; Suffix - ((when-let* ((style (alist-get (aref component (1- len)) alist))) - (cons style (substring component 0 -1)))))))) - -(defcustom orderless-style-dispatchers (list #'orderless-affix-dispatch) - "List of style dispatchers. -Style dispatchers are used to override the matching styles -based on the actual component and its place in the list of -components. A style dispatcher is a function that takes a string -and two integers as arguments, it gets called with a component, -the 0-based index of the component and the total number of -components. It can decide what matching styles to use for the -component and optionally replace the component with a different -string, or it can decline to handle the component leaving it for -future dispatchers. For details see `orderless--dispatch'. - -For example, a style dispatcher could arrange for the first -component to match as an initialism and subsequent components to -match as literals. As another example, a style dispatcher could -arrange for a component starting with `~' to match the rest of -the component in the `orderless-flex' style. See -`orderless-affix-dispatch' and `orderless-affix-dispatch-alist' -for such a configuration. For more information on how this -variable is used, see `orderless-compile'." - :type '(repeat function)) - -(defcustom orderless-smart-case t - "Whether to use smart case. -If this variable is t, then case-sensitivity is decided as -follows: if any component contains upper case letters, the -matches are case sensitive; otherwise case-insensitive. This -is like the behavior of `isearch' when `search-upper-case' is -non-nil. - -On the other hand, if this variable is nil, then case-sensitivity -is determined by the values of `completion-ignore-case', -`read-file-name-completion-ignore-case' and -`read-buffer-completion-ignore-case', as usual for completion." - :type 'boolean) - -(defcustom orderless-expand-substring 'prefix - "Whether to perform literal substring expansion. -This configuration option affects the behavior of some completion -interfaces when pressing TAB. If enabled `orderless-try-completion' -will first attempt literal substring expansion. If disabled, -expansion is only performed for single unique matches. For -performance reasons only `prefix' expansion is enabled by default. -Set the variable to `substring' for full substring expansion." - :type '(choice (const :tag "No expansion" nil) - (const :tag "Substring" substring) - (const :tag "Prefix (efficient)" prefix))) - -;;; Matching styles - -(defun orderless-regexp (component) - "Match COMPONENT as a regexp." - (condition-case nil - (progn (string-match-p component "") component) - (invalid-regexp nil))) - -(defun orderless-literal (component) - "Match COMPONENT as a literal string." - ;; Do not use (literal component) here, such that `delete-dups' in - ;; `orderless--compile-component' has a chance to delete duplicates for - ;; literal input. The default configuration of `orderless-matching-styles' - ;; with `orderless-regexp' and `orderless-literal' leads to duplicates. - (regexp-quote component)) - -(defun orderless-literal-prefix (component) - "Match COMPONENT as a literal prefix string." - `(seq bos (literal ,component))) - -(defun orderless--separated-by (sep rxs &optional before after) - "Return a regexp to match the rx-regexps RXS with SEP in between. -If BEFORE is specified, add it to the beginning of the rx -sequence. If AFTER is specified, add it to the end of the rx -sequence." - (declare (indent 1)) - `(seq - ,(or before "") - ,@(cl-loop for (sexp . more) on rxs - collect `(group ,sexp) - when more collect sep) - ,(or after ""))) - -(defun orderless-flex (component) - "Match a component in flex style. -This means the characters in COMPONENT must occur in the -candidate in that order, but not necessarily consecutively." - `(seq - ,@(cdr (cl-loop for char across component - append `((zero-or-more (not ,char)) (group ,char)))))) - -(defun orderless-initialism (component) - "Match a component as an initialism. -This means the characters in COMPONENT must occur in the -candidate, in that order, at the beginning of words." - (orderless--separated-by '(zero-or-more nonl) - (cl-loop for char across component collect `(seq word-start ,char)))) - -(defun orderless-prefixes (component) - "Match a component as multiple word prefixes. -The COMPONENT is split at word endings, and each piece must match -at a word boundary in the candidate. This is similar to the -`partial-completion' completion style." - (orderless--separated-by '(zero-or-more nonl) - (cl-loop for prefix in (split-string component "\\>") - collect `(seq word-boundary ,prefix)))) - -(defun orderless-without-literal (component) - "Match strings that do *not* contain COMPONENT as a literal match. -You may prefer to use the more general `orderless-not' instead -which can invert any predicate or regexp." - `(seq - (group string-start) ; highlight nothing! - (zero-or-more - (or ,@(cl-loop for i below (length component) - collect `(seq ,(substring component 0 i) - (or (not (any ,(aref component i))) - string-end))))) - string-end)) - -(defsubst orderless--match-p (pred regexp str) - "Return t if STR matches PRED and REGEXP." - (and str - (or (not pred) (funcall pred str)) - (or (not regexp) - (let ((case-fold-search completion-ignore-case)) - (string-match-p regexp str))))) - -(defun orderless-not (pred regexp) - "Match strings that do *not* match PRED and REGEXP." - (lambda (str) - (not (orderless--match-p pred regexp str)))) - -(defun orderless--metadata () - "Return completion metadata iff inside minibuffer." - (when-let* (((minibufferp)) - (table minibuffer-completion-table)) - ;; Return non-nil metadata iff inside minibuffer - (or (completion-metadata (buffer-substring-no-properties - (minibuffer-prompt-end) (point)) - table minibuffer-completion-predicate) - '((nil . nil))))) - -(defun orderless-annotation (pred regexp) - "Match candidates where the annotation matches PRED and REGEXP." - (let ((md (orderless--metadata))) - (if-let* ((fun (compat-call completion-metadata-get md 'affixation-function))) - (lambda (str) - (cl-loop for s in (cdar (funcall fun (list str))) - thereis (orderless--match-p pred regexp s))) - (when-let* ((fun (compat-call completion-metadata-get md 'annotation-function))) - (lambda (str) (orderless--match-p pred regexp (funcall fun str))))))) - -;;; Highlighting matches - -(defun orderless--highlight (regexps ignore-case string) - "Destructively propertize STRING to highlight a match of each of the REGEXPS. -The search is case insensitive if IGNORE-CASE is non-nil." - (cl-loop with case-fold-search = ignore-case - with n = (length orderless-match-faces) - for regexp in regexps and i from 0 - when (string-match regexp string) do - (cl-loop - for (x y) on (let ((m (match-data))) (or (cddr m) m)) by #'cddr - when x do - (add-face-text-property - x y - (aref orderless-match-faces (mod i n)) - nil string))) - string) - -(defun orderless-highlight-matches (regexps strings) - "Highlight a match of each of the REGEXPS in each of the STRINGS. -Warning: only use this if you know all REGEXPs match all STRINGS! -For the user's convenience, if REGEXPS is a string, it is -converted to a list of regexps according to the value of -`orderless-matching-styles'." - (when (stringp regexps) - (setq regexps (cdr (orderless-compile regexps)))) - (cl-loop with ignore-case = (orderless--ignore-case-p regexps) - for str in strings - collect (orderless--highlight regexps ignore-case (substring str)))) - -;;; Compiling patterns to lists of regexps - -(defun orderless-escapable-split-on-space (string) - "Split STRING on spaces, which can be escaped with backslash." - (mapcar - (lambda (piece) (replace-regexp-in-string (string 0) " " piece)) - (split-string (replace-regexp-in-string - "\\\\\\\\\\|\\\\ " - (lambda (x) (if (equal x "\\ ") (string 0) x)) - string 'fixedcase 'literal) - " +"))) - -(defun orderless--dispatch (dispatchers default string index total) - "Run DISPATCHERS to compute matching styles for STRING. - -A style dispatcher is a function that takes a STRING, component -INDEX and the TOTAL number of components. It should either -return (a) nil to indicate the dispatcher will not handle the -string, (b) a new string to replace the current string and -continue dispatch, or (c) the matching styles to use and, if -needed, a new string to use in place of the current one (for -example, a dispatcher can decide which style to use based on a -suffix of the string and then it must also return the component -stripped of the suffix). - -More precisely, the return value of a style dispatcher can be of -one of the following forms: - -- nil (to continue dispatching) - -- a string (to replace the component and continue dispatching), - -- a matching style or non-empty list of matching styles to - return, - -- a `cons' whose `car' is either as in the previous case or - nil (to request returning the DEFAULT matching styles), and - whose `cdr' is a string (to replace the current one). - -This function tries all DISPATCHERS in sequence until one returns -a list of styles. When that happens it returns a `cons' of the -list of styles and the possibly updated STRING. If none of the -DISPATCHERS returns a list of styles, the return value will use -DEFAULT as the list of styles." - (cl-loop for dispatcher in dispatchers - for result = (funcall dispatcher string index total) - if (stringp result) - do (setq string result result nil) - else if (and (consp result) (null (car result))) - do (setf (car result) default) - else if (and (consp result) (stringp (cdr result))) - do (setq string (cdr result) result (car result)) - when result return (cons result string) - finally (return (cons default string)))) - -(defun orderless--compile-component (component index total styles dispatchers) - "Compile COMPONENT at INDEX of TOTAL components with STYLES and DISPATCHERS." - (cl-loop - with pred = nil - with (newsty . newcomp) = (orderless--dispatch dispatchers styles - component index total) - for style in (if (functionp newsty) (list newsty) newsty) - for res = (condition-case nil - (funcall style newcomp) - (wrong-number-of-arguments - (when-let* ((res (orderless--compile-component - newcomp index total styles dispatchers))) - (funcall style (car res) (cdr res))))) - if (functionp res) do (cl-callf orderless--predicate-and pred res) - else if res collect (if (stringp res) `(regexp ,res) res) into regexps - finally return - (when (or pred regexps) - (cons pred (and regexps (rx-to-string `(or ,@(delete-dups regexps)) t)))))) - -(defun orderless-compile (pattern &optional styles dispatchers) - "Build regexps to match the components of PATTERN. -Split PATTERN on `orderless-component-separator' and compute -matching styles for each component. For each component the style -DISPATCHERS are run to determine the matching styles to be used; -they are called with arguments the component, the 0-based index -of the component and the total number of components. If the -DISPATCHERS decline to handle the component, then the list of -matching STYLES is used. See `orderless--dispatch' for details -on dispatchers. - -The STYLES default to `orderless-matching-styles', and the -DISPATCHERS default to `orderless-dipatchers'. Since nil gets -you the default, if you want no dispatchers to be run, use -\\='(ignore) as the value of DISPATCHERS. - -The return value is a pair of a predicate function and a list of -regexps. The predicate function can also be nil. It takes a -string as argument." - (unless styles (setq styles orderless-matching-styles)) - (unless dispatchers (setq dispatchers orderless-style-dispatchers)) - (cl-loop - with predicate = nil - with temp = (if (functionp orderless-component-separator) - (funcall orderless-component-separator pattern) - (split-string pattern orderless-component-separator)) - with components = (if (equal (car (last temp)) "") (nbutlast temp) temp) - with total = (length components) - for comp in components and index from 0 - for (pred . regexp) = (orderless--compile-component - comp index total styles dispatchers) - when regexp collect regexp into regexps - when pred do (cl-callf orderless--predicate-and predicate pred) - finally return (cons predicate regexps))) - -;;; Completion style implementation - -(defun orderless--predicate-normalized-and (p q) - "Combine two predicate functions P and Q with `and'. -The first function P is a completion predicate which can receive -up to two arguments. The second function Q always receives a -normalized string as argument." - (cond - ((and p q) - (lambda (k &rest v) ;; v for hash table - (when (if v (funcall p k (car v)) (funcall p k)) - (setq k (if (consp k) (car k) k)) ;; alist - (funcall q (if (symbolp k) (symbol-name k) k))))) - (q - (lambda (k &optional _) ;; _ for hash table - (setq k (if (consp k) (car k) k)) ;; alist - (funcall q (if (symbolp k) (symbol-name k) k)))) - (p))) - -(defun orderless--predicate-and (p q) - "Combine two predicate functions P and Q with `and'." - (or (and p q (lambda (x) (and (funcall p x) (funcall q x)))) p q)) - -(defun orderless--compile (string table pred) - "Compile STRING to a prefix and a list of regular expressions. -The predicate PRED is used to constrain the entries in TABLE." - (pcase-let* ((limit (car (completion-boundaries string table pred ""))) - (prefix (substring string 0 limit)) - (pattern (substring string limit)) - (`(,fun . ,regexps) (orderless-compile pattern))) - (list prefix regexps (orderless--ignore-case-p pattern) - (orderless--predicate-normalized-and pred fun)))) - -;; Thanks to @jakanakaevangeli for writing a version of this function: -;; https://github.com/oantolin/orderless/issues/79#issuecomment-916073526 -(defun orderless--literal-prefix-p (regexp) - "Determine if REGEXP is a quoted regexp anchored at the beginning. -If REGEXP is of the form \"\\`q\" for q = (regexp-quote u), -then return (cons REGEXP u); else return nil." - (when (and (string-prefix-p "\\`" regexp) - (not (string-match-p "[$*+.?[\\^]" - (replace-regexp-in-string - "\\\\[$*+.?[\\^]" "" regexp - 'fixedcase 'literal nil 2)))) - (cons regexp - (replace-regexp-in-string "\\\\\\([$*+.?[\\^]\\)" "\\1" - regexp 'fixedcase nil nil 2)))) - -(defun orderless--ignore-case-p (regexps) - "Return non-nil if case should be ignored for REGEXPS." - (if orderless-smart-case - (cl-loop for regexp in (ensure-list regexps) - always (isearch-no-upper-case-p regexp t)) - completion-ignore-case)) - -(defun orderless--filter (prefix regexps ignore-case table pred) - "Filter TABLE by PREFIX, REGEXPS and PRED. -The matching should be case-insensitive if IGNORE-CASE is non-nil." - ;; If there is a regexp of the form \`quoted-regexp then - ;; remove the first such and add the unquoted form to the prefix. - (pcase (cl-loop for r in regexps - thereis (orderless--literal-prefix-p r)) - (`(,regexp . ,literal) - (setq prefix (concat prefix literal) - regexps (remove regexp regexps)))) - (let ((completion-regexp-list regexps) - (completion-ignore-case ignore-case)) - (all-completions prefix table pred))) - -(defun orderless-filter (string table &optional pred) - "Split STRING into components and find entries TABLE matching all. -The predicate PRED is used to constrain the entries in TABLE." - (pcase-let ((`(,prefix ,regexps ,ignore-case ,pred) - (orderless--compile string table pred))) - (orderless--filter prefix regexps ignore-case table pred))) - -;;;###autoload -(defun orderless-all-completions (string table pred _point) - "Split STRING into components and find entries TABLE matching all. -The predicate PRED is used to constrain the entries in TABLE. The -matching portions of each candidate are highlighted. -This function is part of the `orderless' completion style." - (pcase-let ((`(,prefix ,regexps ,ignore-case ,pred) - (orderless--compile string table pred))) - (when-let* ((completions (orderless--filter prefix regexps ignore-case table pred))) - (if completion-lazy-hilit - (setq completion-lazy-hilit-fn - (apply-partially #'orderless--highlight regexps ignore-case)) - (cl-loop for str in-ref completions do - (setf str (orderless--highlight regexps ignore-case (substring str))))) - (nconc completions (length prefix))))) - -;;;###autoload -(defun orderless-try-completion (string table pred point) - "Complete STRING to unique matching entry in TABLE. -This uses `orderless-all-completions' to find matches for STRING -in TABLE among entries satisfying PRED. If there is only one -match, it completes to that match. If there are no matches, it -returns nil. In any other case it \"completes\" STRING to -itself, without moving POINT. -This function is part of the `orderless' completion style." - (or - (pcase orderless-expand-substring - ('nil nil) - ('prefix (completion-emacs21-try-completion string table pred point)) - (_ (completion-substring-try-completion string table pred point))) - (catch 'orderless--many - (pcase-let ((`(,prefix ,regexps ,ignore-case ,pred) - (orderless--compile string table pred)) - (one nil)) - ;; Abuse all-completions/orderless--filter as a fast search loop. - ;; Should be almost allocation-free since our "predicate" is not - ;; called more than two times. - (orderless--filter - prefix regexps ignore-case table - (orderless--predicate-normalized-and - pred - (lambda (arg) - ;; Check if there is more than a single match (= many). - (when (and one (not (equal one arg))) - (throw 'orderless--many (cons string point))) - (setq one arg) - t))) - (when one - ;; Prepend prefix if the candidate does not already have the same - ;; prefix. This workaround is needed since the predicate may either - ;; receive an unprefixed or a prefixed candidate as argument. Most - ;; completion tables consistently call the predicate with unprefixed - ;; candidates, for example `completion-file-name-table'. In contrast, - ;; `completion-table-with-context' calls the predicate with prefixed - ;; candidates. This could be an unintended bug or oversight in - ;; `completion-table-with-context'. - (unless (or (equal prefix "") - (and (string-prefix-p prefix one) - (test-completion one table pred))) - (setq one (concat prefix one))) - (or (equal string one) ;; Return t for unique exact match - (cons one (length one)))))))) - -;;;###autoload -(add-to-list 'completion-styles-alist - '(orderless - orderless-try-completion orderless-all-completions - "Completion of multiple components, in any order.")) - -(defmacro orderless-define-completion-style - (name &optional docstring &rest configuration) - "Define an orderless completion style with given CONFIGURATION. -The CONFIGURATION should be a list of bindings that you could use -with `let' to configure orderless. You can include bindings for -`orderless-matching-styles' and `orderless-style-dispatchers', -for example. - -The completion style consists of two functions that this macro -defines for you, NAME-try-completion and NAME-all-completions. -This macro registers those in `completion-styles-alist' as -forming the completion style NAME. - -The optional DOCSTRING argument is used as the documentation -string for the completion style." - (declare (doc-string 2) (indent 1)) - (unless (stringp docstring) - (push docstring configuration) - (setq docstring nil)) - (let* ((fn-name (lambda (string) (intern (concat (symbol-name name) string)))) - (try-completion (funcall fn-name "-try-completion")) - (all-completions (funcall fn-name "-all-completions")) - (doc-fmt "`%s' function for the %s style. -This function delegates to `orderless-%s'. -The orderless configuration is locally modified -specifically for the %s style.") - (fn-doc (lambda (fn) (format doc-fmt fn name fn name name)))) - `(progn - (defun ,try-completion (string table pred point) - ,(funcall fn-doc "try-completion") - (let ,configuration - (orderless-try-completion string table pred point))) - (defun ,all-completions (string table pred point) - ,(funcall fn-doc "all-completions") - (let ,configuration - (orderless-all-completions string table pred point))) - (add-to-list 'completion-styles-alist - '(,name ,try-completion ,all-completions ,docstring))))) - -;;; Ivy integration - -;;;###autoload -(defun orderless-ivy-re-builder (str) - "Convert STR into regexps for use with ivy. -This function is for integration of orderless with ivy, use it as -a value in `ivy-re-builders-alist'." - (or (mapcar (lambda (x) (cons x t)) (cdr (orderless-compile str))) "")) - -(defvar ivy-regex) -(defun orderless-ivy-highlight (str) - "Highlight a match in STR of each regexp in `ivy-regex'. -This function is for integration of orderless with ivy." - (orderless--highlight (mapcar #'car ivy-regex) t str) str) - -(provide 'orderless) -;;; orderless.el ends here diff --git a/.config/emacs/lisp/minadstack/vertico-directory.el b/.config/emacs/lisp/minadstack/vertico-directory.el deleted file mode 100644 index 3328dd1..0000000 --- a/.config/emacs/lisp/minadstack/vertico-directory.el +++ /dev/null @@ -1,136 +0,0 @@ -;;; vertico-directory.el --- Ido-like directory navigation for Vertico -*- lexical-binding: t -*- - -;; Copyright (C) 2021-2026 Free Software Foundation, Inc. - -;; Author: Daniel Mendler <mail@daniel-mendler.de> -;; Maintainer: Daniel Mendler <mail@daniel-mendler.de> -;; Created: 2021 -;; Version: 2.8 -;; Package-Requires: ((emacs "29.1") (compat "30") (vertico "2.8")) -;; URL: https://github.com/minad/vertico - -;; This file is part of GNU Emacs. - -;; This program is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This package is a Vertico extension, which provides Ido-like -;; directory navigation commands. The commands can be bound in the -;; `vertico-map'. -;; -;; (keymap-set vertico-map "RET" #'vertico-directory-enter) -;; (keymap-set vertico-map "DEL" #'vertico-directory-delete-char) -;; (keymap-set vertico-map "M-DEL" #'vertico-directory-delete-word) -;; -;; Alternatively use `vertico-directory-map' together with -;; `vertico-multiform-mode'. -;; -;; (setq vertico-multiform-categories -;; '((file (:keymap . vertico-directory-map)))) -;; (vertico-multiform-mode) -;; -;; Furthermore a cleanup function for shadowed file paths is provided. -;; -;; (add-hook 'rfn-eshadow-update-overlay-hook #'vertico-directory-tidy) - -;;; Code: - -(require 'vertico) -(eval-when-compile (require 'subr-x)) - -;;;###autoload -(defun vertico-directory-enter (&optional arg) - "Enter directory or exit completion with current candidate. -Exit with current input if prefix ARG is given." - (interactive "P") - (if-let* (((not arg)) - ((>= vertico--index 0)) - ((eq 'file (vertico--metadata-get 'category))) - ;; Check vertico--base for stepwise file path completion - ((not (equal vertico--base ""))) - (cand (vertico--candidate)) - ((or (string-suffix-p "/" cand) - (and (vertico--remote-p cand) - (string-suffix-p ":" cand)))) - ;; Handle /./ and /../ manually instead of via `expand-file-name' - ;; and `abbreviate-file-name', such that we don't accidentally - ;; perform unwanted substitutions in the existing completion. - ((progn - (setq cand (string-replace "/./" "/" cand)) - (unless (string-suffix-p "/../../" cand) - (setq cand (replace-regexp-in-string "/[^/|:]+/\\.\\./\\'" "/" cand))) - (not (equal (minibuffer-contents-no-properties) cand))))) - (progn - (delete-minibuffer-contents) - (insert cand)) - (vertico-exit arg))) - -;;;###autoload -(defun vertico-directory-up (&optional n) - "Delete N names before point." - (interactive "p") - (when (and (> (point) (minibuffer-prompt-end)) - (eq 'file (vertico--metadata-get 'category))) - (let ((path (buffer-substring-no-properties (minibuffer-prompt-end) (point))) - found) - (when (string-match-p "\\`~[^/]*/\\'" path) - (delete-minibuffer-contents) - (insert (expand-file-name path))) - (dotimes (_ (or n 1) found) - (save-excursion - (let ((end (point))) - (goto-char (1- end)) - (when (search-backward "/" (minibuffer-prompt-end) t) - (delete-region (1+ (point)) end) - (setq found t)))))))) - -;;;###autoload -(defun vertico-directory-delete-char (n) - "Delete N directories or chars before point." - (interactive "p") - (unless (and (not (and (use-region-p) delete-active-region (= n 1))) - (eq (char-before) ?/) (vertico-directory-up n)) - (with-no-warnings (delete-backward-char n)))) - -;;;###autoload -(defun vertico-directory-delete-word (n) - "Delete N directories or words before point." - (interactive "p") - (unless (and (eq (char-before) ?/) (vertico-directory-up n)) - (delete-region (prog1 (point) (backward-word n)) (point)))) - -;;;###autoload -(defun vertico-directory-tidy () - "Tidy shadowed file name, see `rfn-eshadow-overlay'." - (when (eq this-command #'self-insert-command) - (dolist (ov '(tramp-rfn-eshadow-overlay rfn-eshadow-overlay)) - (when (and (boundp ov) - (setq ov (symbol-value ov)) - (overlay-buffer ov) - (= (point) (point-max)) - (> (point) (overlay-end ov))) - (delete-region (overlay-start ov) (overlay-end ov)))))) - -(defvar-keymap vertico-directory-map - :doc "File name editing map." - "RET" #'vertico-directory-enter - "DEL" #'vertico-directory-delete-char - "M-DEL" #'vertico-directory-delete-word) - -;;;###autoload (autoload 'vertico-directory-map "vertico-directory" nil t 'keymap) -(defalias 'vertico-directory-map vertico-directory-map) - -(provide 'vertico-directory) -;;; vertico-directory.el ends here diff --git a/.config/emacs/lisp/minadstack/vertico.el b/.config/emacs/lisp/minadstack/vertico.el deleted file mode 100644 index c646f0b..0000000 --- a/.config/emacs/lisp/minadstack/vertico.el +++ /dev/null @@ -1,736 +0,0 @@ -;;; vertico.el --- VERTical Interactive COmpletion -*- lexical-binding: t -*- - -;; Copyright (C) 2021-2026 Free Software Foundation, Inc. - -;; Author: Daniel Mendler <mail@daniel-mendler.de> -;; Maintainer: Daniel Mendler <mail@daniel-mendler.de> -;; Created: 2021 -;; Version: 2.8 -;; Package-Requires: ((emacs "29.1") (compat "30")) -;; URL: https://github.com/minad/vertico -;; Keywords: convenience, files, matching, completion - -;; This file is part of GNU Emacs. - -;; This program is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Vertico provides a performant and minimalistic vertical completion UI -;; based on the default completion system. By reusing the built-in -;; facilities, Vertico achieves full compatibility with built-in Emacs -;; completion commands and completion tables. - -;;; Code: - -(require 'compat) -(eval-when-compile - (require 'cl-lib) - (require 'subr-x)) - -(defgroup vertico nil - "VERTical Interactive COmpletion." - :link '(info-link :tag "Info Manual" "(vertico)") - :link '(url-link :tag "Website" "https://github.com/minad/vertico") - :link '(url-link :tag "Wiki" "https://github.com/minad/vertico/wiki") - :link '(emacs-library-link :tag "Library Source" "vertico.el") - :group 'convenience - :group 'minibuffer - :prefix "vertico-") - -(defcustom vertico-count-format (cons "%-6s " "%s/%s") - "Format string used for the candidate count." - :type '(choice (const :tag "No candidate count" nil) (cons string string))) - -(defcustom vertico-group-format - (concat #(" " 0 4 (face vertico-group-separator)) - #(" %s " 0 4 (face vertico-group-title)) - #(" " 0 1 (face vertico-group-separator display (space :align-to (- right 1))))) - "Format string used for the group title." - :type '(choice (const :tag "No group titles" nil) string)) - -(defcustom vertico-count 10 - "Maximal number of candidates to show." - :type 'natnum) - -(defcustom vertico-preselect 'directory - "Configure if the prompt or first candidate is preselected. -- prompt: Always select the prompt. -- first: Select the first candidate, allow prompt selection. -- no-prompt: Like first, but forbid selection of the prompt entirely. -- directory: Like first, but select the prompt if it is a directory." - :type '(choice (const prompt) (const first) (const no-prompt) (const directory))) - -(defcustom vertico-scroll-margin 2 - "Number of lines at the top and bottom when scrolling. -The value should lie between 0 and vertico-count/2." - :type 'natnum) - -(defcustom vertico-resize resize-mini-windows - "How to resize the Vertico minibuffer window, see `resize-mini-windows'." - :type '(choice (const :tag "Fixed" nil) - (const :tag "Shrink and grow" t) - (const :tag "Grow-only" grow-only))) - -(defcustom vertico-cycle nil - "Enable cycling for `vertico-next' and `vertico-previous'." - :type 'boolean) - -(defcustom vertico-multiline - (cons #("↲" 0 1 (face vertico-multiline)) #("…" 0 1 (face vertico-multiline))) - "Replacements for multiline strings." - :type '(cons (string :tag "Newline") (string :tag "Truncation"))) - -(defcustom vertico-sort-function - (and (fboundp 'vertico-sort-history-length-alpha) 'vertico-sort-history-length-alpha) - "Default sorting function, used if no `display-sort-function' is specified." - :type '(choice - (const :tag "No sorting" nil) - (const :tag "By history, length and alpha" vertico-sort-history-length-alpha) - (const :tag "By history and alpha" vertico-sort-history-alpha) - (const :tag "By length and alpha" vertico-sort-length-alpha) - (const :tag "Alphabetically" vertico-sort-alpha) - (function :tag "Custom function"))) - -(defcustom vertico-sort-override-function nil - "Override sort function which overrides the `display-sort-function'." - :type '(choice (const nil) function)) - -(defgroup vertico-faces nil - "Faces used by Vertico." - :group 'vertico - :group 'faces) - -(defface vertico-multiline '((t :inherit shadow)) - "Face used to highlight multiline replacement characters.") - -(defface vertico-group-title '((t :inherit shadow :slant italic)) - "Face used for the title text of the candidate group headlines.") - -(defface vertico-group-separator '((t :inherit vertico-group-title :strike-through t)) - "Face used for the separator lines of the candidate groups.") - -(defface vertico-current '((t :inherit highlight :extend t)) - "Face used to highlight the currently selected candidate.") - -(defvar-keymap vertico-map - :doc "Vertico minibuffer keymap derived from `minibuffer-local-map'." - :parent minibuffer-local-map - "<remap> <beginning-of-buffer>" #'vertico-first - "<remap> <minibuffer-beginning-of-buffer>" #'vertico-first - "<remap> <end-of-buffer>" #'vertico-last - "<remap> <scroll-down-command>" #'vertico-scroll-down - "<remap> <scroll-up-command>" #'vertico-scroll-up - "<remap> <next-line>" #'vertico-next - "<remap> <previous-line>" #'vertico-previous - "<remap> <next-line-or-history-element>" #'vertico-next - "<remap> <previous-line-or-history-element>" #'vertico-previous - "<remap> <backward-paragraph>" #'vertico-previous-group - "<remap> <forward-paragraph>" #'vertico-next-group - "<remap> <exit-minibuffer>" #'vertico-exit - "<remap> <kill-ring-save>" #'vertico-save - "M-RET" #'vertico-exit-input - "TAB" #'vertico-insert - "<touchscreen-begin>" #'ignore) - -(defvar vertico--locals - '((scroll-margin . 0) - (completion-auto-help . nil) - (pixel-scroll-precision-mode . nil)) - "Vertico minibuffer local variables.") - -(defvar-local vertico--hilit #'identity - "Lazy candidate highlighting function.") - -(defvar-local vertico--candidates-ov nil - "Overlay showing the candidates.") - -(defvar-local vertico--count-ov nil - "Overlay showing the number of candidates.") - -(defvar-local vertico--index -1 - "Index of current candidate or negative for prompt selection.") - -(defvar-local vertico--scroll 0 - "Scroll position.") - -(defvar-local vertico--input nil - "Cons of last minibuffer contents and point or t.") - -(defvar-local vertico--candidates nil - "List of candidates.") - -(defvar-local vertico--metadata nil - "Completion metadata.") - -(defvar-local vertico--base "" - "Base string, which is concatenated with the candidate.") - -(defvar-local vertico--total 0 - "Length of the candidate list `vertico--candidates'.") - -(defvar-local vertico--lock-candidate nil - "Lock-in current candidate.") - -(defvar-local vertico--lock-groups nil - "Lock-in current group order.") - -(defvar-local vertico--groups nil - "List of current group titles.") - -(defvar-local vertico--allow-prompt nil - "Prompt selection is allowed.") - -(defun vertico--affixate (cands) - "Annotate CANDS with annotation function." - (if-let* ((aff (vertico--metadata-get 'affixation-function))) - (funcall aff cands) - (if-let* ((ann (vertico--metadata-get 'annotation-function))) - (cl-loop for cand in cands collect - (let ((suff (or (funcall ann cand) ""))) - ;; The default completion UI adds the `completions-annotations' - ;; face if no other faces are present. - (unless (text-property-not-all 0 (length suff) 'face nil suff) - (setq suff (propertize suff 'face 'completions-annotations))) - (list cand "" suff))) - (cl-loop for cand in cands collect (list cand "" ""))))) - -(defun vertico--move-to-front (elem list) - "Move ELEM to front of LIST." - (if-let* ((found (member elem list))) ;; No duplicates, compare with Corfu. - (nconc (list (car found)) (delq (setcar found nil) list)) - list)) - -(defun vertico--filter-completions (&rest args) - "Compute all completions for ARGS with lazy highlighting." - (dlet ((completion-lazy-hilit t) (completion-lazy-hilit-fn nil)) - (static-if (>= emacs-major-version 30) - (cons (apply #'completion-all-completions args) completion-lazy-hilit-fn) - (cl-letf* ((orig-pcm (symbol-function #'completion-pcm--hilit-commonality)) - (orig-flex (symbol-function #'completion-flex-all-completions)) - ((symbol-function #'completion-flex-all-completions) - (lambda (&rest args) - ;; Unfortunately for flex we have to undo the lazy highlighting, since flex uses - ;; the completion-score for sorting, which is applied during highlighting. - (cl-letf (((symbol-function #'completion-pcm--hilit-commonality) orig-pcm)) - (apply orig-flex args)))) - ((symbol-function #'completion-pcm--hilit-commonality) - (lambda (pattern cands) - (setq completion-lazy-hilit-fn - (lambda (x) - ;; `completion-pcm--hilit-commonality' sometimes throws an internal error - ;; for example when entering "/sudo:://u". - (condition-case nil - (car (completion-pcm--hilit-commonality pattern (list x))) - (t x)))) - cands)) - ((symbol-function #'completion-hilit-commonality) - (lambda (cands prefix &optional base) - (setq completion-lazy-hilit-fn - (lambda (x) (car (completion-hilit-commonality (list x) prefix base)))) - (and cands (nconc cands base))))) - (cons (apply #'completion-all-completions args) completion-lazy-hilit-fn))))) - -(defun vertico--metadata-get (prop) - "Return PROP from completion metadata." - (compat-call completion-metadata-get vertico--metadata prop)) - -(defun vertico--sort-function () - "Return the sorting function." - (or vertico-sort-override-function - (vertico--metadata-get 'display-sort-function) - vertico-sort-function)) - -(defun vertico--compute (input) - "Compute state given INPUT." - (pcase-let* ((`(,str . ,pt) input) - (table minibuffer-completion-table) - (pred minibuffer-completion-predicate) - (before (substring str 0 pt)) - (after (substring str pt)) - ;; bug#47678: `completion-boundaries' fails for `partial-completion' - ;; if the cursor is moved before the slashes of "~//". - ;; See also corfu.el which has the same issue. - (bounds (condition-case nil - (completion-boundaries before table pred after) - (t (cons 0 (length after))))) - (field (substring str (car bounds) (+ pt (cdr bounds)))) - ;; bug#75910: category instead of `minibuffer-completing-file-name' - (completing-file (eq 'file (vertico--metadata-get 'category))) - (`(,all . ,hl) (vertico--filter-completions str table pred pt vertico--metadata)) - (base (or (when-let* ((z (last all))) (prog1 (cdr z) (setcdr z nil))) 0)) - (vertico--base (substring str 0 base)) - (def (or (car-safe minibuffer-default) minibuffer-default)) - (groups) (def-missing) (lock)) - ;; Filter the ignored file extensions. We cannot use modified predicate for this filtering, - ;; since this breaks the special casing in the `completion-file-name-table' for `file-exists-p' - ;; and `file-directory-p'. - (when completing-file (setq all (completion-pcm--filename-try-filter all))) - ;; Sort using the `display-sort-function' or the Vertico sort functions - (setq all (delete-consecutive-dups (funcall (or (vertico--sort-function) #'identity) all))) - ;; Move special candidates: "field" appears at the top, before "field/", before default value - (when (stringp def) - (setq all (vertico--move-to-front def all))) - (when (and completing-file (not (string-suffix-p "/" field))) - (setq all (vertico--move-to-front (concat field "/") all))) - (setq all (vertico--move-to-front field all)) - (when-let* ((fun (and all (vertico--metadata-get 'group-function)))) - (setq groups (vertico--group-by fun all) all (car groups))) - (setq def-missing (and def (equal str "") (not (member def all))) - lock (and vertico--lock-candidate ;; Locked position of old candidate. - (if (< vertico--index 0) -1 - (seq-position all (nth vertico--index vertico--candidates))))) - `((vertico--input . ,input) - (vertico--base . ,vertico--base) - (vertico--metadata . ,vertico--metadata) - (vertico--candidates . ,all) - (vertico--total . ,(length all)) - (vertico--hilit . ,(or hl #'identity)) - (vertico--allow-prompt . ,(and (not (eq vertico-preselect 'no-prompt)) - (or def-missing (eq vertico-preselect 'prompt) - (memq minibuffer--require-match - '(nil confirm confirm-after-completion))))) - (vertico--lock-candidate . ,lock) - (vertico--groups . ,(cdr groups)) - (vertico--index . ,(or lock - (if (or def-missing (eq vertico-preselect 'prompt) (not all) - (and completing-file (eq vertico-preselect 'directory) - (= (length vertico--base) (length str)) - (test-completion str table pred))) - -1 0)))))) - -(defun vertico--hilit (cand) - "Highlight CAND string with lazy highlighting." - ;; bug#77754: Highlight unquoted string. - (funcall vertico--hilit (substring (or (get-text-property - 0 'completion--unquoted cand) cand)))) - -(defun vertico--cycle (list n) - "Rotate LIST to position N." - (nconc (copy-sequence (nthcdr n list)) (seq-take list n))) - -(defun vertico--group-by (fun elems) - "Group ELEMS by FUN." - (let ((ht (make-hash-table :test #'equal)) titles groups) - ;; Build hash table of groups - (cl-loop for elem on elems - for title = (funcall fun (car elem) nil) do - (if-let* ((group (gethash title ht))) - (setcdr group (setcdr (cdr group) elem)) ;; Append to tail of group - (puthash title (cons elem elem) ht) ;; New group element (head . tail) - (push title titles))) - (setq titles (nreverse titles)) - ;; Cycle groups if `vertico--lock-groups' is set - (when-let* ((group (seq-find (lambda (group) (gethash group ht)) - vertico--lock-groups))) - (setq titles (vertico--cycle titles (seq-position titles group)))) - ;; Build group list - (dolist (title titles) - (push (gethash title ht) groups)) - ;; Unlink last tail - (setcdr (cdar groups) nil) - (setq groups (nreverse groups)) - ;; Link groups - (let ((link groups)) - (while (cdr link) - (setcdr (cdar link) (caadr link)) - (pop link))) - (cons (caar groups) titles))) - -(defun vertico--remote-p (path) - "Return t if PATH is a remote path." - (string-match-p "\\`/[^/|:]+:" (substitute-in-file-name path))) - -(defun vertico--update (&optional interruptible) - "Update state, optionally INTERRUPTIBLE." - (let* ((pt (max 0 (- (point) (minibuffer-prompt-end)))) - (str (minibuffer-contents-no-properties)) - (input (cons str pt))) - (unless (or (and interruptible (input-pending-p)) (equal vertico--input input)) - ;; Redisplay to make input immediately visible before expensive candidate - ;; recomputation (gh:minad/vertico#89). No redisplay during init because - ;; of flicker. - (when (and interruptible (consp vertico--input)) - ;; Prevent recursive exhibit from timer (`consult-vertico--refresh'). - (cl-letf (((symbol-function #'vertico--exhibit) #'ignore)) (redisplay))) - (pcase (let ((vertico--metadata (completion-metadata (substring str 0 pt) - minibuffer-completion-table - minibuffer-completion-predicate))) - ;; If Tramp is used, do not compute the candidates in an - ;; interruptible fashion, since this will break the Tramp - ;; password and user name prompts (See gh:minad/vertico#23). - (if (or (not interruptible) - (and (eq 'file (vertico--metadata-get 'category)) - (or (vertico--remote-p str) (vertico--remote-p default-directory)))) - (vertico--compute input) - (let ((non-essential t)) - (while-no-input (vertico--compute input))))) - ('nil (abort-recursive-edit)) - ((and state (pred consp)) - (dolist (s state) (set (car s) (cdr s)))))))) - -(defun vertico--display-string (str) - "Return display STR without display and invisible properties." - (let ((end (length str)) (pos 0) chunks) - (while (< pos end) - (let ((nextd (next-single-property-change pos 'display str end)) - (disp (get-text-property pos 'display str))) - (if (stringp disp) - (let ((face (get-text-property pos 'face str))) - (when face - (add-face-text-property 0 (length disp) face t (setq disp (concat disp)))) - (setq pos nextd chunks (cons disp chunks))) - (while (< pos nextd) - (let ((nexti (next-single-property-change pos 'invisible str nextd))) - (unless (or (get-text-property pos 'invisible str) - (and (= pos 0) (= nexti end))) ;; full string -> no allocation - (push (substring str pos nexti) chunks)) - (setq pos nexti)))))) - (if chunks (apply #'concat (nreverse chunks)) str))) - -(defun vertico--window-width () - "Return minimum width of windows, which display the minibuffer." - (cl-loop for win in (get-buffer-window-list) minimize (window-width win))) - -(defun vertico--truncate-multiline (str max) - "Truncate multiline STR to MAX." - (let ((pos 0) (res "")) - (while (and (< (length res) (* 2 max)) (string-match "\\(\\S-+\\)\\|\\s-+" str pos)) - (setq res (concat res (if (match-end 1) (match-string 0 str) - (if (string-search "\n" (match-string 0 str)) - (car vertico-multiline) " "))) - pos (match-end 0))) - (truncate-string-to-width (string-trim res) max 0 nil (cdr vertico-multiline)))) - -(defun vertico--compute-scroll () - "Compute new scroll position." - (let ((off (max (min vertico-scroll-margin (/ vertico-count 2)) 0)) - (corr (if (= vertico-scroll-margin (/ vertico-count 2)) (1- (mod vertico-count 2)) 0))) - (setq vertico--scroll (min (max 0 (- vertico--total vertico-count)) - (max 0 (+ vertico--index off 1 (- vertico-count)) - (min (- vertico--index off corr) vertico--scroll)))))) - -(defun vertico--format-group-title (title cand) - "Format group TITLE given the current CAND." - ;; Copy candidate highlighting if title is a prefix of the candidate. - (when (string-prefix-p title cand) - (setq title (substring cand 0 (length title))) - (vertico--remove-face 0 (length title) 'completions-first-difference title)) - (setq title (substring title)) - (add-face-text-property 0 (length title) 'vertico-group-title t title) - (format (concat vertico-group-format "\n") title)) - -(defun vertico--format-count () - "Format the count string." - (format (car vertico-count-format) - (format (cdr vertico-count-format) - (cond ((>= vertico--index 0) (1+ vertico--index)) - (vertico--allow-prompt "*") - (t "!")) - vertico--total))) - -(defun vertico--display-count () - "Update count overlay `vertico--count-ov'." - (move-overlay vertico--count-ov (point-min) (point-min)) - (overlay-put vertico--count-ov 'before-string - (if vertico-count-format (vertico--format-count) ""))) - -(defun vertico--prompt-selection () - "Highlight the prompt if selected." - (let ((inhibit-modification-hooks t)) - (if (and (< vertico--index 0) vertico--allow-prompt) - (add-face-text-property (minibuffer-prompt-end) (point-max) 'vertico-current 'append) - (vertico--remove-face (minibuffer-prompt-end) (point-max) 'vertico-current)))) - -(defun vertico--remove-face (beg end face &optional obj) - "Remove FACE between BEG and END from OBJ." - (while (< beg end) - (let ((next (next-single-property-change beg 'face obj end))) - (when-let* ((val (get-text-property beg 'face obj))) - (put-text-property beg next 'face (remq face (ensure-list val)) obj)) - (setq beg next)))) - -(defun vertico--debug (&rest _) - "Debugger used by `vertico--protect'." - (let ((inhibit-message t)) - (require 'backtrace) - (declare-function backtrace-to-string "backtrace") - (message "Vertico detected an error:\n%s" (backtrace-to-string))) - (let (message-log-max) - (message "%s %s" - (propertize "Vertico detected an error:" 'face 'error) - (substitute-command-keys "Press \\[view-echo-area-messages] to see the stack trace"))) - nil) - -(defun vertico--protect (fun) - "Protect FUN such that errors are caught. -If an error occurs, the FUN is retried with `debug-on-error' enabled and -the stack trace is shown in the *Messages* buffer." - (static-if (fboundp 'handler-bind) ;; Available on Emacs 30 - (ignore-errors - (handler-bind ((error #'vertico--debug)) - (funcall fun))) - (when (or debug-on-error (condition-case nil - (progn (funcall fun) nil) - (error t))) - (let ((debug-on-error t) - (debugger #'vertico--debug)) - (condition-case nil - (funcall fun) - ((debug error) nil)))))) - -(defun vertico--exhibit () - "Exhibit completion UI." - (vertico--protect - (lambda () - (let ((buffer-undo-list t)) ;; Overlays affect point position and undo list! - (vertico--update 'interruptible) - (vertico--prompt-selection) - (vertico--display-count) - (vertico--display-candidates (vertico--arrange-candidates)))))) - -(defun vertico--goto (index) - "Go to candidate with INDEX." - (setq vertico--index - (max (if (or vertico--allow-prompt (= 0 vertico--total)) -1 0) - (min index (1- vertico--total))) - vertico--lock-candidate (or (>= vertico--index 0) vertico--allow-prompt))) - -(defun vertico--candidate (&optional hl) - "Return current candidate string with optional highlighting if HL is non-nil." - (let ((content (or (car-safe vertico--input) (minibuffer-contents-no-properties)))) - (cond - ((>= vertico--index 0) - (let ((cand (substring (nth vertico--index vertico--candidates)))) - ;; XXX Drop the completions-common-part face which is added by the - ;; `completion--twq-all' hack. This should better be fixed in Emacs - ;; itself, the corresponding code is already marked as fixme. - (vertico--remove-face 0 (length cand) 'completions-common-part cand) - (concat vertico--base (if hl (vertico--hilit cand) cand)))) - ((and (equal content "") (or (car-safe minibuffer-default) minibuffer-default))) - (t content)))) - -(defun vertico--match-p (input) - "Return t if INPUT is a valid match." - (let ((rm minibuffer--require-match)) - (or (memq rm '(nil confirm-after-completion)) - (equal "" input) ;; Null completion, returns default value - (if (functionp rm) (funcall rm input) ;; require-match can be a function - (test-completion input minibuffer-completion-table minibuffer-completion-predicate)) - (if (eq rm 'confirm) (eq (ignore-errors (read-char "Confirm")) 13) - (minibuffer-message "Match required") nil)))) - -(cl-defgeneric vertico--format-candidate (cand prefix suffix index _start) - "Format CAND given PREFIX, SUFFIX and INDEX." - (setq cand (vertico--display-string (concat prefix cand suffix "\n"))) - (when (= index vertico--index) - (add-face-text-property 0 (length cand) 'vertico-current 'append cand)) - cand) - -(cl-defgeneric vertico--arrange-candidates () - "Arrange candidates." - (vertico--compute-scroll) - (let ((curr-line 0) lines) - ;; Compute group titles - (let* (title (index vertico--scroll) - (group-fun (and vertico-group-format (vertico--metadata-get 'group-function))) - (candidates - (vertico--affixate - (cl-loop repeat vertico-count for c in (nthcdr index vertico--candidates) - collect (vertico--hilit c))))) - (pcase-dolist ((and cand `(,str . ,_)) candidates) - (when-let* ((new-title (and group-fun (funcall group-fun str nil)))) - (unless (equal title new-title) - (setq title new-title) - (push (vertico--format-group-title title str) lines)) - (setcar cand (funcall group-fun str 'transform))) - (when (= index vertico--index) - (setq curr-line (length lines))) - (push (cons index cand) lines) - (cl-incf index))) - ;; Drop excess lines - (setq lines (nreverse lines)) - (cl-loop for count from (length lines) above vertico-count do - (if (< curr-line (/ count 2)) - (nbutlast lines) - (setq curr-line (1- curr-line) lines (cdr lines)))) - ;; Format candidates - (let ((max-width (- (vertico--window-width) 4)) start) - (cl-loop for line on lines do - (pcase (car line) - (`(,index ,cand ,prefix ,suffix) - (setq start (or start index)) - (when (string-search "\n" cand) - (setq cand (vertico--truncate-multiline cand max-width))) - (setcar line (vertico--format-candidate cand prefix suffix index start)))))) - lines)) - -(cl-defgeneric vertico--display-candidates (lines) - "Update candidates overlay `vertico--candidates-ov' with LINES." - (move-overlay vertico--candidates-ov (point-max) (point-max)) - (overlay-put vertico--candidates-ov 'before-string - (apply #'concat #(" " 0 1 (cursor t)) (and lines "\n") lines)) - (vertico--resize-window (length lines))) - -(cl-defgeneric vertico--resize-window (height) - "Resize active minibuffer window to HEIGHT." - (setq-local truncate-lines (< (point) (* 0.8 (vertico--window-width))) - resize-mini-windows 'grow-only - max-mini-window-height 1.0) - (unless truncate-lines (set-window-hscroll nil 0)) - (unless (frame-root-window-p (active-minibuffer-window)) - (unless vertico-resize (setq height (max height vertico-count))) - (let ((dp (- (max (cdr (window-text-pixel-size)) - (* (default-line-height) (1+ height))) - (window-pixel-height)))) - (when (or (and (> dp 0) (/= height 0)) - (and (< dp 0) (eq vertico-resize t))) - (window-resize nil dp nil nil 'pixelwise))))) - -(cl-defgeneric vertico--prepare () - "Ensure that the state is prepared before running the next command." - (when-let* ((cmd (and (symbolp this-command) (symbol-name this-command))) - ((string-prefix-p "vertico-" cmd)) - ((not (and vertico--metadata (string-prefix-p "vertico-directory-" cmd))))) - (vertico--update))) - -(cl-defgeneric vertico--setup () - "Setup completion UI." - (dolist (var vertico--locals) - (set (make-local-variable (car var)) (cdr var))) - (setq-local vertico--input t - vertico--candidates-ov (make-overlay (point-max) (point-max) nil t t) - vertico--count-ov (make-overlay (point-min) (point-min) nil t t)) - (overlay-put vertico--count-ov 'priority 1) ;; For `minibuffer-depth-indicate-mode' - (use-local-map vertico-map) - (add-hook 'pre-command-hook #'vertico--prepare nil 'local) - (add-hook 'post-command-hook #'vertico--exhibit nil 'local)) - -(cl-defgeneric vertico--advice (&rest app) - "Advice for completion function, apply APP." - (dlet ((completion-eager-display nil)) ;; Available on Emacs 31 - (minibuffer-with-setup-hook #'vertico--setup (apply app)))) - -(defun vertico-first () - "Go to first candidate, or to the prompt when the first candidate is selected." - (interactive) - (vertico--goto (if (> vertico--index 0) 0 -1))) - -(defun vertico-last () - "Go to last candidate." - (interactive) - (vertico--goto (1- vertico--total))) - -(defun vertico-scroll-down (&optional n) - "Go back by N pages." - (interactive "p") - (vertico--goto (max 0 (- vertico--index (* (or n 1) vertico-count))))) - -(defun vertico-scroll-up (&optional n) - "Go forward by N pages." - (interactive "p") - (vertico-scroll-down (- (or n 1)))) - -(defun vertico-next (&optional n) - "Go forward N candidates." - (interactive "p") - (let ((index (+ vertico--index (or n 1)))) - (vertico--goto - (cond - ((not vertico-cycle) index) - ((= vertico--total 0) -1) - (vertico--allow-prompt (1- (mod (1+ index) (1+ vertico--total)))) - (t (mod index vertico--total)))))) - -(defun vertico-previous (&optional n) - "Go backward N candidates." - (interactive "p") - (vertico-next (- (or n 1)))) - -(defun vertico-exit (&optional arg) - "Exit minibuffer with current candidate or input if prefix ARG is given." - (interactive "P") - (when (and (not arg) (>= vertico--index 0)) - (vertico-insert)) - (when (vertico--match-p (minibuffer-contents-no-properties)) - (exit-minibuffer))) - -(defun vertico-next-group (&optional n) - "Cycle N groups forward. -When the prefix argument is 0, the group order is reset." - (interactive "p") - (when (cdr vertico--groups) - (setq vertico--groups (and (not (eq n 0)) - (vertico--cycle vertico--groups - (let ((len (length vertico--groups))) - (- len (mod (- (or n 1)) len))))) - vertico--lock-groups vertico--groups - vertico--lock-candidate nil - vertico--input nil))) - -(defun vertico-previous-group (&optional n) - "Cycle N groups backward. -When the prefix argument is 0, the group order is reset." - (interactive "p") - (vertico-next-group (- (or n 1)))) - -(defun vertico-exit-input () - "Exit minibuffer with input." - (interactive) - (vertico-exit t)) - -(defun vertico-save () - "Save current candidate to kill ring." - (interactive) - (if (or (use-region-p) (not transient-mark-mode)) - (call-interactively #'kill-ring-save) - (kill-new (substring-no-properties (vertico--candidate))))) - -(defun vertico-insert () - "Insert current candidate in minibuffer." - (interactive) - ;; XXX There is a small bug here, depending on interpretation. When completing - ;; "~/emacs/master/li|/calc" where "|" is the cursor, then the returned - ;; candidate only includes the prefix "~/emacs/master/lisp/", but not the - ;; suffix "/calc". Default completion has the same problem when selecting in - ;; the *Completions* buffer. See bug#48356. - (when (> vertico--total 0) - (let ((vertico--index (max 0 vertico--index))) - (insert (prog1 (vertico--candidate) (delete-minibuffer-contents)))))) - -;;;###autoload -(define-minor-mode vertico-mode - "VERTical Interactive COmpletion." - :global t :group 'vertico - (dolist (fun '(completing-read-default completing-read-multiple)) - (if vertico-mode - (advice-add fun :around #'vertico--advice) - (advice-remove fun #'vertico--advice)))) - -(defun vertico--command-p (_sym buffer) - "Return non-nil if Vertico is active in BUFFER." - (buffer-local-value 'vertico--input buffer)) - -;; Do not show Vertico commands in M-X -(dolist (sym '( vertico-next vertico-next-group vertico-previous vertico-previous-group - vertico-scroll-down vertico-scroll-up vertico-exit vertico-insert - vertico-exit-input vertico-save vertico-first vertico-last - vertico-repeat-next ;; autoloads in vertico-repeat.el - vertico-quick-jump vertico-quick-exit vertico-quick-insert ;; autoloads in vertico-quick.el - vertico-directory-up vertico-directory-enter ;; autoloads in vertico-directory.el - vertico-directory-delete-char vertico-directory-delete-word)) - (put sym 'completion-predicate #'vertico--command-p)) - -(provide 'vertico) -;;; vertico.el ends here |