commit 7914e559781ac60fc55238ec0cbd8f849266a99c parent afcb9be9fd07d206b2f5774bb6afab64466e01a8 Author: Lukas Henkel <lh@entf.net> Date: Tue, 1 Feb 2022 20:43:20 +0100 Delete older packages Diffstat:
| D | elpa/consult-0.13/consult-autoloads.el | | | 489 | ------------------------------------------------------------------------------- |
| D | elpa/consult-0.13/consult-compile.el | | | 122 | ------------------------------------------------------------------------------- |
| D | elpa/consult-0.13/consult-compile.elc | | | 0 | |
| D | elpa/consult-0.13/consult-flymake.el | | | 100 | ------------------------------------------------------------------------------- |
| D | elpa/consult-0.13/consult-flymake.elc | | | 0 | |
| D | elpa/consult-0.13/consult-icomplete.el | | | 55 | ------------------------------------------------------- |
| D | elpa/consult-0.13/consult-icomplete.elc | | | 0 | |
| D | elpa/consult-0.13/consult-imenu.el | | | 232 | ------------------------------------------------------------------------------- |
| D | elpa/consult-0.13/consult-imenu.elc | | | 0 | |
| D | elpa/consult-0.13/consult-org.el | | | 124 | ------------------------------------------------------------------------------- |
| D | elpa/consult-0.13/consult-org.elc | | | 0 | |
| D | elpa/consult-0.13/consult-pkg.el | | | 10 | ---------- |
| D | elpa/consult-0.13/consult-register.el | | | 266 | ------------------------------------------------------------------------------- |
| D | elpa/consult-0.13/consult-register.elc | | | 0 | |
| D | elpa/consult-0.13/consult-selectrum.el | | | 104 | ------------------------------------------------------------------------------- |
| D | elpa/consult-0.13/consult-selectrum.elc | | | 0 | |
| D | elpa/consult-0.13/consult-vertico.el | | | 54 | ------------------------------------------------------ |
| D | elpa/consult-0.13/consult-vertico.elc | | | 0 | |
| D | elpa/consult-0.13/consult-xref.el | | | 116 | ------------------------------------------------------------------------------- |
| D | elpa/consult-0.13/consult-xref.elc | | | 0 | |
| D | elpa/consult-0.13/consult.el | | | 4472 | ------------------------------------------------------------------------------- |
| D | elpa/consult-0.13/consult.elc | | | 0 | |
| D | elpa/corfu-0.16.signed | | | 2 | -- |
| D | elpa/corfu-0.16/LICENSE | | | 674 | ------------------------------------------------------------------------------- |
| D | elpa/corfu-0.16/README.org | | | 211 | ------------------------------------------------------------------------------- |
| D | elpa/corfu-0.16/corfu-autoloads.el | | | 60 | ------------------------------------------------------------ |
| D | elpa/corfu-0.16/corfu-pkg.el | | | 2 | -- |
| D | elpa/corfu-0.16/corfu.el | | | 1193 | ------------------------------------------------------------------------------- |
| D | elpa/corfu-0.16/corfu.elc | | | 0 | |
| D | elpa/corfu-0.16/corfu.info | | | 305 | ------------------------------------------------------------------------------ |
| D | elpa/corfu-0.16/dir | | | 18 | ------------------ |
| D | elpa/eglot-1.7/eglot-autoloads.el | | | 56 | -------------------------------------------------------- |
| D | elpa/eglot-1.7/eglot-pkg.el | | | 2 | -- |
| D | elpa/eglot-1.7/eglot.el | | | 2753 | ------------------------------------------------------------------------------- |
| D | elpa/eglot-1.7/eglot.elc | | | 0 | |
| A | elpa/eglot-1.8.signed | | | 2 | ++ |
| A | elpa/eglot-1.8/.dir-locals.el | | | 13 | +++++++++++++ |
| A | elpa/eglot-1.8/Makefile | | | 73 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | elpa/eglot-1.8/NEWS.md | | | 315 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | elpa/eglot-1.8/README.md | | | 604 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | elpa/eglot-1.8/eglot-autoloads.el | | | 75 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | elpa/eglot-1.8/eglot-pkg.el | | | 2 | ++ |
| A | elpa/eglot-1.8/eglot-tests.el | | | 1173 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | elpa/eglot-1.8/eglot-tests.elc | | | 0 | |
| A | elpa/eglot-1.8/eglot.el | | | 3082 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | elpa/eglot-1.8/eglot.elc | | | 0 | |
| D | elpa/eglot-20211116.823/eglot-autoloads.el | | | 64 | ---------------------------------------------------------------- |
| D | elpa/eglot-20211116.823/eglot-pkg.el | | | 2 | -- |
| D | elpa/eglot-20211116.823/eglot.el | | | 3050 | ------------------------------------------------------------------------------- |
| D | elpa/eglot-20211116.823/eglot.elc | | | 0 | |
| D | elpa/marginalia-0.10.signed | | | 2 | -- |
| D | elpa/marginalia-0.10/LICENSE | | | 674 | ------------------------------------------------------------------------------- |
| D | elpa/marginalia-0.10/README.org | | | 193 | ------------------------------------------------------------------------------- |
| D | elpa/marginalia-0.10/dir | | | 18 | ------------------ |
| D | elpa/marginalia-0.10/marginalia-autoloads.el | | | 49 | ------------------------------------------------- |
| D | elpa/marginalia-0.10/marginalia-mode.png | | | 0 | |
| D | elpa/marginalia-0.10/marginalia-pkg.el | | | 2 | -- |
| D | elpa/marginalia-0.10/marginalia.el | | | 1112 | ------------------------------------------------------------------------------- |
| D | elpa/marginalia-0.10/marginalia.elc | | | 0 | |
| D | elpa/marginalia-0.10/marginalia.info | | | 238 | ------------------------------------------------------------------------------- |
| D | elpa/paredit-24/paredit-autoloads.el | | | 41 | ----------------------------------------- |
| D | elpa/paredit-24/paredit-pkg.el | | | 2 | -- |
| D | elpa/paredit-24/paredit.el | | | 2916 | ------------------------------------------------------------------------------- |
| D | elpa/paredit-24/paredit.elc | | | 0 | |
| D | elpa/vertico-0.17.signed | | | 2 | -- |
| D | elpa/vertico-0.17/LICENSE | | | 674 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-0.17/README.org | | | 445 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-0.17/dir | | | 18 | ------------------ |
| D | elpa/vertico-0.17/vertico-autoloads.el | | | 265 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-0.17/vertico-buffer.el | | | 141 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-0.17/vertico-buffer.elc | | | 0 | |
| D | elpa/vertico-0.17/vertico-directory.el | | | 113 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-0.17/vertico-directory.elc | | | 0 | |
| D | elpa/vertico-0.17/vertico-flat.el | | | 122 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-0.17/vertico-flat.elc | | | 0 | |
| D | elpa/vertico-0.17/vertico-grid.el | | | 158 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-0.17/vertico-grid.elc | | | 0 | |
| D | elpa/vertico-0.17/vertico-indexed.el | | | 83 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-0.17/vertico-indexed.elc | | | 0 | |
| D | elpa/vertico-0.17/vertico-mouse.el | | | 95 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-0.17/vertico-mouse.elc | | | 0 | |
| D | elpa/vertico-0.17/vertico-pkg.el | | | 2 | -- |
| D | elpa/vertico-0.17/vertico-quick.el | | | 140 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-0.17/vertico-quick.elc | | | 0 | |
| D | elpa/vertico-0.17/vertico-repeat.el | | | 96 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-0.17/vertico-repeat.elc | | | 0 | |
| D | elpa/vertico-0.17/vertico-reverse.el | | | 79 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-0.17/vertico-reverse.elc | | | 0 | |
| D | elpa/vertico-0.17/vertico.el | | | 790 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-0.17/vertico.elc | | | 0 | |
| D | elpa/vertico-0.17/vertico.info | | | 612 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-posframe-0.4.2.signed | | | 2 | -- |
| D | elpa/vertico-posframe-0.4.2/LICENSE | | | 674 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-posframe-0.4.2/README.org | | | 26 | -------------------------- |
| D | elpa/vertico-posframe-0.4.2/vertico-posframe-autoloads.el | | | 47 | ----------------------------------------------- |
| D | elpa/vertico-posframe-0.4.2/vertico-posframe-pkg.el | | | 2 | -- |
| D | elpa/vertico-posframe-0.4.2/vertico-posframe.el | | | 328 | ------------------------------------------------------------------------------- |
| D | elpa/vertico-posframe-0.4.2/vertico-posframe.elc | | | 0 |
98 files changed, 5339 insertions(+), 24697 deletions(-)
diff --git a/elpa/consult-0.13/consult-autoloads.el b/elpa/consult-0.13/consult-autoloads.el @@ -1,489 +0,0 @@ -;;; consult-autoloads.el --- automatically extracted autoloads -;; -;;; Code: - -(add-to-list 'load-path (directory-file-name - (or (file-name-directory #$) (car load-path)))) - - -;;;### (autoloads nil "consult" "consult.el" (0 0 0 0)) -;;; Generated autoloads from consult.el - -(autoload 'consult-completion-in-region "consult" "\ -Use minibuffer completion as the UI for `completion-at-point'. - -The function is called with 4 arguments: START END COLLECTION PREDICATE. -The arguments and expected return value are as specified for -`completion-in-region'. Use as a value for `completion-in-region-function'. - -The function can be configured via `consult-customize'. - - (consult-customize consult-completion-in-region - :completion-styles (basic) - :cycle-threshold 3) - -These configuration options are supported: - - * :cycle-threshold - Cycling threshold (def: `completion-cycle-threshold') - * :completion-styles - Use completion styles (def: `completion-styles') - * :require-match - Require matches when completing (def: nil) - * :prompt - The prompt string shown in the minibuffer - -\(fn START END COLLECTION &optional PREDICATE)" nil nil) - -(autoload 'consult-completing-read-multiple "consult" "\ -Enhanced replacement for `completing-read-multiple'. -See `completing-read-multiple' for the documentation of the arguments. - -\(fn PROMPT TABLE &optional PRED REQUIRE-MATCH INITIAL-INPUT HIST DEF INHERIT-INPUT-METHOD)" nil nil) - -(autoload 'consult-multi-occur "consult" "\ -Improved version of `multi-occur' based on `completing-read-multiple'. - -See `multi-occur' for the meaning of the arguments BUFS, REGEXP and NLINES. - -\(fn BUFS REGEXP &optional NLINES)" t nil) - -(autoload 'consult-outline "consult" "\ -Jump to an outline heading, obtained by matching against `outline-regexp'. - -This command supports narrowing to a heading level and candidate preview. -The symbol at point is added to the future history." t nil) - -(autoload 'consult-mark "consult" "\ -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. - -\(fn &optional MARKERS)" t nil) - -(autoload 'consult-global-mark "consult" "\ -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. - -\(fn &optional MARKERS)" t nil) - -(autoload 'consult-line "consult" "\ -Search for a matching line. - -Depending on the setting `consult-line-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. - -\(fn &optional INITIAL START)" t nil) - -(autoload 'consult-line-multi "consult" "\ -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. See -`consult-line' for more information. In order to search a subset of buffers, -QUERY can be set to a plist according to `consult--buffer-query'. - -\(fn QUERY &optional INITIAL)" t nil) - -(autoload 'consult-keep-lines "consult" "\ -Select a subset of the lines in the current buffer with live preview. - -The selected lines are kept and the other lines are deleted. When called -interactively, the lines selected are those that match the minibuffer input. In -order to match the inverse of the input, prefix the input with `! '. When -called from elisp, the filtering is performed by a FILTER function. This -command obeys narrowing. - -FILTER is the filter function. -INITIAL is the initial input. - -\(fn &optional FILTER INITIAL)" t nil) - -(autoload 'consult-focus-lines "consult" "\ -Hide or show lines using overlays. - -The selected lines are shown and the other lines hidden. When called -interactively, the lines selected are those that match the minibuffer input. In -order to match the inverse of the input, prefix the input with `! '. With -optional prefix argument SHOW reveal the hidden lines. Alternatively the -command can be restarted to reveal the lines. When called from elisp, the -filtering is performed by a FILTER function. This command obeys narrowing. - -FILTER is the filter function. -INITIAL is the initial input. - -\(fn &optional SHOW FILTER INITIAL)" t nil) - -(autoload 'consult-goto-line "consult" "\ -Read line number and jump to the line with preview. - -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'. - -\(fn &optional ARG)" t nil) - -(autoload 'consult-recent-file "consult" "\ -Find recent file using `completing-read'." t nil) - -(autoload 'consult-file-externally "consult" "\ -Open FILE externally using the default application of the system. - -\(fn FILE)" t nil) - -(autoload 'consult-mode-command "consult" "\ -Run a command from any of the given MODES. - -If no MODES are specified, use currently active major and minor modes. - -\(fn &rest MODES)" t nil) - -(autoload 'consult-yank-from-kill-ring "consult" "\ -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' in Emacs 28, which also offers -a `completing-read' interface to the `kill-ring'. Additionally the Consult -version supports preview of the selected string. - -\(fn STRING &optional ARG)" t nil) - -(autoload 'consult-yank-pop "consult" "\ -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' in Emacs 28, which also offers a -`completing-read' interface to the `kill-ring'. Additionally the Consult -version supports preview of the selected string. - -\(fn &optional ARG)" t nil) - -(autoload 'consult-yank-replace "consult" "\ -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. - -There exists no equivalent of this command in Emacs 28. - -\(fn STRING)" t nil) - -(autoload 'consult-bookmark "consult" "\ -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. - -\(fn NAME)" t nil) - -(autoload 'consult-apropos "consult" "\ -Select pattern and call `apropos'. - -The default value of the completion is the symbol at point. As a better -alternative, you can run `embark-export' from commands like `M-x' and -`describe-symbol'." t nil) - -(autoload 'consult-complex-command "consult" "\ -Select and evaluate command from the command history. - -This command can act as a drop-in replacement for `repeat-complex-command'." t nil) - -(autoload 'consult-history "consult" "\ -Insert string from HISTORY of current buffer. - -In order to select from a specific HISTORY, pass the history variable -as argument. - -\(fn &optional HISTORY)" t nil) - -(autoload 'consult-isearch-history "consult" "\ -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." t nil) - -(autoload 'consult-minor-mode-menu "consult" "\ -Enable or disable minor mode. - -This is an alternative to `minor-mode-menu-from-indicator'." t nil) - -(autoload 'consult-theme "consult" "\ -Disable current themes and enable THEME from `consult-themes'. - -The command supports previewing the currently selected theme. - -\(fn THEME)" t nil) - -(autoload 'consult-buffer "consult" "\ -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. Furthermore 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-root-function' is used. See `consult-buffer-sources' and -`consult--multi' for the configuration of the virtual buffer sources." t nil) - -(autoload 'consult-buffer-other-window "consult" "\ -Variant of `consult-buffer' which opens in other window." t nil) - -(autoload 'consult-buffer-other-frame "consult" "\ -Variant of `consult-buffer' which opens in other frame." t nil) - -(autoload 'consult-kmacro "consult" "\ -Run a chosen keyboard macro. - -With prefix ARG, run the macro that many times. -Macros containing mouse clicks are omitted. - -\(fn ARG)" t nil) - -(autoload 'consult-grep "consult" "\ -Search for regexp with grep in DIR with INITIAL input. - -The input string is split, the first part of the string 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 --. - -Example: #async-regexp -- grep-opts#filter-string - -The symbol at point is added to the future history. If `consult-grep' -is called interactively with a prefix argument, the user can specify -the directory to search in. By default the project directory is used -if `consult-project-root-function' is defined and returns non-nil. -Otherwise the `default-directory' is searched. - -\(fn &optional DIR INITIAL)" t nil) - -(autoload 'consult-git-grep "consult" "\ -Search for regexp with grep in DIR with INITIAL input. - -See `consult-grep' for more details. - -\(fn &optional DIR INITIAL)" t nil) - -(autoload 'consult-ripgrep "consult" "\ -Search for regexp with rg in DIR with INITIAL input. - -See `consult-grep' for more details. - -\(fn &optional DIR INITIAL)" t nil) - -(autoload 'consult-find "consult" "\ -Search for regexp with find in DIR with INITIAL input. - -The find process is started asynchronously, similar to `consult-grep'. -See `consult-grep' for more details regarding the asynchronous search. - -\(fn &optional DIR INITIAL)" t nil) - -(autoload 'consult-locate "consult" "\ -Search for regexp with locate with INITIAL input. - -The locate process is started asynchronously, similar to `consult-grep'. -See `consult-grep' for more details regarding the asynchronous search. - -\(fn &optional INITIAL)" t nil) - -(autoload 'consult-man "consult" "\ -Search for regexp with man with INITIAL input. - -The man process is started asynchronously, similar to `consult-grep'. -See `consult-grep' for more details regarding the asynchronous search. - -\(fn &optional INITIAL)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "consult" '("consult-"))) - -;;;*** - -;;;### (autoloads nil "consult-compile" "consult-compile.el" (0 0 -;;;;;; 0 0)) -;;; Generated autoloads from consult-compile.el - -(autoload 'consult-compile-error "consult-compile" "\ -Jump to a compilation error in the current buffer. - -This command collects entries from compilation buffers and grep -buffers related to the current buffer. The command supports -preview of the currently selected error." t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "consult-compile" '("consult-compile--"))) - -;;;*** - -;;;### (autoloads nil "consult-flymake" "consult-flymake.el" (0 0 -;;;;;; 0 0)) -;;; Generated autoloads from consult-flymake.el - -(autoload 'consult-flymake "consult-flymake" "\ -Jump to Flymake diagnostic." t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "consult-flymake" '("consult-flymake--"))) - -;;;*** - -;;;### (autoloads nil "consult-icomplete" "consult-icomplete.el" -;;;;;; (0 0 0 0)) -;;; Generated autoloads from consult-icomplete.el - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "consult-icomplete" '("consult-icomplete--refresh"))) - -;;;*** - -;;;### (autoloads nil "consult-imenu" "consult-imenu.el" (0 0 0 0)) -;;; Generated autoloads from consult-imenu.el - -(autoload 'consult-imenu "consult-imenu" "\ -Select item from flattened `imenu' using `completing-read' with preview. - -The command supports preview and narrowing. See the variable -`consult-imenu-config', which configures the narrowing. -The symbol at point is added to the future history. - -See also `consult-imenu-multi'." t nil) - -(autoload 'consult-imenu-multi "consult-imenu" "\ -Select item from the imenus of all buffers from the same project. - -In order to determine the buffers belonging to the same project, the -`consult-project-root-function' is used. Only the buffers with the -same major mode as the current buffer are used. See also -`consult-imenu' for more details. In order to search a subset of buffers, -QUERY can be set to a plist according to `consult--buffer-query'. - -\(fn &optional QUERY)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "consult-imenu" '("consult-imenu-"))) - -;;;*** - -;;;### (autoloads nil "consult-org" "consult-org.el" (0 0 0 0)) -;;; Generated autoloads from consult-org.el - -(autoload 'consult-org-heading "consult-org" "\ -Jump to an Org heading. - -MATCH and SCOPE are as in `org-map-entries' and determine which -entries are offered. By default, all entries of the current -buffer are offered. - -\(fn &optional MATCH SCOPE)" t nil) - -(autoload 'consult-org-agenda "consult-org" "\ -Jump to an Org agenda heading. - -By default, all agenda entries are offered. MATCH is as in -`org-map-entries' and can used to refine this. - -\(fn &optional MATCH)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "consult-org" '("consult-org--"))) - -;;;*** - -;;;### (autoloads nil "consult-register" "consult-register.el" (0 -;;;;;; 0 0 0)) -;;; Generated autoloads from consult-register.el - -(autoload 'consult-register-window "consult-register" "\ -Enhanced drop-in replacement for `register-preview'. - -BUFFER is the window buffer. -SHOW-EMPTY must be t if the window should be shown for an empty register list. - -\(fn BUFFER &optional SHOW-EMPTY)" nil nil) - -(autoload 'consult-register-format "consult-register" "\ -Enhanced preview of register REG. - -This function can be used as `register-preview-function'. - -\(fn REG)" nil nil) - -(autoload 'consult-register "consult-register" "\ -Load register and either jump to location or insert the stored text. - -This command is useful to search the register contents. For quick access to -registers it is still recommended to use the register functions -`consult-register-load' and `consult-register-store' or the built-in built-in -register access functions. The command supports narrowing, see -`consult-register-narrow'. Marker positions are previewed. See -`jump-to-register' and `insert-register' for the meaning of prefix ARG. - -\(fn &optional ARG)" t nil) - -(autoload 'consult-register-load "consult-register" "\ -Do what I mean with a REG. - -For a window configuration, restore it. For a number or text, insert it. For a -location, jump to it. See `jump-to-register' and `insert-register' for the -meaning of prefix ARG. - -\(fn REG &optional ARG)" t nil) - -(autoload 'consult-register-store "consult-register" "\ -Store register dependent on current context, showing an action menu. - -With an active region, store/append/prepend the contents, optionally deleting -the region when a prefix ARG is given. With a numeric prefix ARG, store/add the -number. Otherwise store point, frameset, window or kmacro. - -\(fn ARG)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "consult-register" '("consult-register-"))) - -;;;*** - -;;;### (autoloads nil "consult-selectrum" "consult-selectrum.el" -;;;;;; (0 0 0 0)) -;;; Generated autoloads from consult-selectrum.el - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "consult-selectrum" '("consult-selectrum--"))) - -;;;*** - -;;;### (autoloads nil "consult-vertico" "consult-vertico.el" (0 0 -;;;;;; 0 0)) -;;; Generated autoloads from consult-vertico.el - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "consult-vertico" '("consult-vertico--"))) - -;;;*** - -;;;### (autoloads nil "consult-xref" "consult-xref.el" (0 0 0 0)) -;;; Generated autoloads from consult-xref.el - -(autoload 'consult-xref "consult-xref" "\ -Show xrefs with preview in the minibuffer. - -This function can be used for `xref-show-xrefs-function'. -See `xref-show-xrefs-function' for the description of the -FETCHER and ALIST arguments. - -\(fn FETCHER &optional ALIST)" nil nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "consult-xref" '("consult-xref--"))) - -;;;*** - -;;;### (autoloads nil nil ("consult-pkg.el") (0 0 0 0)) - -;;;*** - -;; Local Variables: -;; version-control: never -;; no-byte-compile: t -;; no-update-autoloads: t -;; coding: utf-8 -;; End: -;;; consult-autoloads.el ends here diff --git a/elpa/consult-0.13/consult-compile.el b/elpa/consult-0.13/consult-compile.el @@ -1,122 +0,0 @@ -;;; consult-compile.el --- Provides the command `consult-compile-error' -*- lexical-binding: t -*- - -;; Copyright (C) 2021 Free Software Foundation, Inc. - -;; 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 <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Provides the command `consult-compile-error'. This is an extra -;; package, to allow lazy loading of compile.el. The -;; `consult-compile-error' command is autoloaded. - -;;; Code: - -(require 'consult) -(require 'compile) - -(defvar consult-compile--history nil) - -(defconst consult-compile--narrow - '((?e . "Error") - (?w . "Warning") - (?i . "Info"))) - -(defun consult-compile--font-lock (str) - "Apply `font-lock' faces in STR, copy them to `face'." - (let ((pos 0) (len (length str))) - (while (< pos len) - (let* ((face (get-text-property pos 'font-lock-face str)) - (end (or (text-property-not-all pos len 'font-lock-face face str) len))) - (put-text-property pos end 'face face str) - (setq pos end))) - str)) - -(defun consult-compile--error-candidates (buffer) - "Return alist of errors and positions in BUFFER, a compilation buffer." - (with-current-buffer buffer - (let ((candidates) - (pos (point-min))) - (save-excursion - (while (setq pos (compilation-next-single-property-change pos 'compilation-message)) - (when-let (msg (get-text-property pos 'compilation-message)) - (goto-char pos) - (push (propertize - (consult-compile--font-lock (consult--buffer-substring pos (line-end-position))) - 'consult--type (pcase (compilation--message->type msg) - (0 ?i) - (1 ?w) - (_ ?e)) - 'consult-compile--marker (point-marker) - 'consult-compile--loc (compilation--message->loc msg)) - candidates)))) - (nreverse candidates)))) - -(defun consult-compile--error-lookup (_ candidates cand) - "Lookup marker of CAND by accessing CANDIDATES list." - (when-let ((cand (car (member cand candidates))) - (marker (get-text-property 0 'consult-compile--marker cand)) - (loc (get-text-property 0 'consult-compile--loc cand)) - (buffer (marker-buffer marker)) - (default-directory (buffer-local-value 'default-directory buffer))) - (consult--position-marker - ;; taken from compile.el - (apply #'compilation-find-file - marker - (caar (compilation--loc->file-struct loc)) - (cadar (compilation--loc->file-struct loc)) - (compilation--file-struct->formats - (compilation--loc->file-struct loc))) - (compilation--loc->line loc) - (compilation--loc->col loc)))) - -(defun consult-compile--compilation-buffers (file) - "Return a list of compilation buffers relevant to FILE." - (consult--buffer-query - :sort 'alpha :predicate - (lambda (buffer) - (with-current-buffer buffer - (and (compilation-buffer-internal-p) - (file-in-directory-p file default-directory)))))) - -;;;###autoload -(defun consult-compile-error () - "Jump to a compilation error in the current buffer. - -This command collects entries from compilation buffers and grep -buffers related to the current buffer. The command supports -preview of the currently selected error." - (interactive) - (consult--read - (consult--with-increased-gc - (or (mapcan #'consult-compile--error-candidates - (or (consult-compile--compilation-buffers - default-directory) - (user-error "No compilation buffers found for the current buffer"))) - (user-error "No compilation errors found"))) - :prompt "Go to error: " - :category 'consult-compile-error - :sort nil - :require-match t - :history t ;; disable history - :lookup #'consult-compile--error-lookup - :group (consult--type-group consult-compile--narrow) - :narrow (consult--type-narrow consult-compile--narrow) - :history '(:input consult-compile--history) - :state (consult--jump-state 'consult-preview-error))) - -(provide 'consult-compile) -;;; consult-compile.el ends here diff --git a/elpa/consult-0.13/consult-compile.elc b/elpa/consult-0.13/consult-compile.elc Binary files differ. diff --git a/elpa/consult-0.13/consult-flymake.el b/elpa/consult-0.13/consult-flymake.el @@ -1,100 +0,0 @@ -;;; consult-flymake.el --- Provides the command `consult-flymake' -*- lexical-binding: t -*- - -;; Copyright (C) 2021 Free Software Foundation, Inc. - -;; 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 <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Provides the command `consult-flymake'. This is an extra package, -;; to allow lazy loading of flymake.el. The `consult-flymake' command -;; is autoloaded. - -;;; Code: - -(require 'consult) -(require 'flymake) - -(defconst consult-flymake--narrow - '((?e . "Error") - (?w . "Warning") - (?n . "Note"))) - -(defun consult-flymake--candidates () - "Return Flymake errors as alist." - (consult--forbid-minibuffer) - (let* ((raw-diags (or (flymake-diagnostics) - (user-error "No flymake errors (Status: %s)" - (if (seq-difference (flymake-running-backends) - (flymake-reporting-backends)) - 'running 'finished)))) - (diags - (mapcar - (lambda (diag) - (let ((buffer (flymake-diagnostic-buffer diag)) - (type (flymake-diagnostic-type diag))) - (with-current-buffer buffer - (save-excursion - (save-restriction - (widen) - (goto-char (flymake-diagnostic-beg diag)) - (list (buffer-name buffer) - (line-number-at-pos) - type - (flymake-diagnostic-text diag) - (point-marker) - (pcase (flymake--lookup-type-property type 'flymake-category) - ('flymake-error ?e) - ('flymake-warning ?w) - (_ ?n)))))))) - raw-diags)) - (buffer-width (apply #'max (mapcar (lambda (x) (length (nth 0 x))) diags))) - (line-width (apply #'max (mapcar (lambda (x) (length (number-to-string (nth 1 x)))) diags))) - (fmt (format "%%-%ds %%-%dd %%-7s %%s" buffer-width line-width))) - (mapcar - (pcase-lambda (`(,buffer ,line ,type ,text ,marker ,narrow)) - (propertize (format fmt buffer line - (propertize (format "%s" (flymake--lookup-type-property - type 'flymake-type-name type)) - 'face (flymake--lookup-type-property - type 'mode-line-face 'flymake-error)) - text) - 'consult--candidate marker - 'consult--type narrow)) - (sort diags - (pcase-lambda (`(_ _ ,t1 _ ,m1 _) `(_ _ ,t2 _ ,m2 _)) - (let ((s1 (flymake--severity t1)) - (s2 (flymake--severity t2))) - (or (> s1 s2) (and (= s1 s2) (< m1 m2))))))))) - -;;;###autoload -(defun consult-flymake () - "Jump to Flymake diagnostic." - (interactive) - (consult--read - (consult--with-increased-gc (consult-flymake--candidates)) - :prompt "Flymake diagnostic: " - :category 'consult-flymake-error - :history t ;; disable history - :require-match t - :sort nil - :group (consult--type-group consult-flymake--narrow) - :narrow (consult--type-narrow consult-flymake--narrow) - :lookup #'consult--lookup-candidate - :state (consult--jump-state 'consult-preview-error))) - -(provide 'consult-flymake) -;;; consult-flymake.el ends here diff --git a/elpa/consult-0.13/consult-flymake.elc b/elpa/consult-0.13/consult-flymake.elc Binary files differ. diff --git a/elpa/consult-0.13/consult-icomplete.el b/elpa/consult-0.13/consult-icomplete.el @@ -1,55 +0,0 @@ -;;; consult-icomplete.el --- Icomplete integration for Consult -*- lexical-binding: t -*- - -;; Copyright (C) 2021 Free Software Foundation, Inc. - -;; 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 <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Integration code for the Icomplete completion system. This package -;; is automatically loaded by Consult. - -;;; Code: - -(require 'consult) -(require 'icomplete) - -(defun consult-icomplete--refresh (&optional reset) - "Refresh icomplete view, keep current candidate unless RESET is non-nil." - (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 (and top (not reset)) - (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))) - -(add-hook 'consult--completion-refresh-hook #'consult-icomplete--refresh) - -(provide 'consult-icomplete) -;;; consult-icomplete.el ends here diff --git a/elpa/consult-0.13/consult-icomplete.elc b/elpa/consult-0.13/consult-icomplete.elc Binary files differ. diff --git a/elpa/consult-0.13/consult-imenu.el b/elpa/consult-0.13/consult-imenu.el @@ -1,232 +0,0 @@ -;;; consult-imenu.el --- Consult commands for imenu -*- lexical-binding: t -*- - -;; Copyright (C) 2021 Free Software Foundation, Inc. - -;; 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 <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Provides imenu-related Consult commands. - -;;; Code: - -(require 'consult) -(require 'imenu) - -(defcustom consult-imenu-config - '((emacs-lisp-mode :toplevel "Functions" - :types ((?f "Functions" font-lock-function-name-face) - (?m "Macros" font-lock-function-name-face) - (?p "Packages" font-lock-constant-face) - (?t "Types" font-lock-type-face) - (?v "Variables" font-lock-variable-name-face)))) - "Imenu configuration, faces and narrowing keys used by `consult-imenu'. - -For each type a narrowing key and a name must be specified. The face is -optional. The imenu representation provided by the backend usually puts -functions directly at the toplevel. `consult-imenu' moves them instead under the -type specified by :toplevel." - :type '(repeat (cons symbol plist)) - :group 'consult) - -(defface consult-imenu-prefix - '((t :inherit consult-key)) - "Face used to highlight imenu prefix in `consult-imenu'." - :group 'consult-faces) - -(defvar consult-imenu--history nil) -(defvar-local consult-imenu--cache nil) - -(defun consult-imenu--special (_name pos buf name fn &rest args) - "Wrapper function for special imenu items. - -POS is the position. -BUF is the buffer. -NAME is the item name. -FN is the original special item function. -ARGS are the arguments to the special item function." - (funcall consult--buffer-display buf) - (apply fn name pos args)) - -(defun consult-imenu--flatten (prefix face list types) - "Flatten imenu LIST. - -PREFIX is prepended in front of all items. -FACE is the item face. -TYPES is the mode-specific types configuration." - (mapcan - (lambda (item) - (if (imenu--subalist-p item) - (let ((name (car item)) - (next-prefix prefix) - (next-face face)) - (if prefix - (setq next-prefix (concat prefix "/" (propertize name 'face 'consult-imenu-prefix))) - (if-let (type (cdr (assoc name types))) - (setq next-prefix (propertize name - 'face 'consult-imenu-prefix - 'consult--type (car type)) - next-face (cadr type)) - (setq next-prefix (propertize name 'face 'consult-imenu-prefix)))) - (consult-imenu--flatten next-prefix next-face (cdr item) types)) - (let* ((name (car item)) - (key (if prefix (concat prefix " " (propertize name 'face face)) name)) - (payload (cdr item))) - (list (cons key - (pcase payload - ;; Simple marker item - ((pred markerp) payload) - ;; Simple integer item - ((pred integerp) (copy-marker payload)) - ;; Semantic uses overlay for positions - ((pred overlayp) (copy-marker (overlay-start payload))) - ;; Wrap special item - (`(,pos ,fn . ,args) - (nconc - (list pos #'consult-imenu--special (current-buffer) name fn) - args)) - (_ (error "Unknown imenu item: %S" item)))))))) - list)) - -(defun consult-imenu--compute () - "Compute imenu candidates." - (consult--forbid-minibuffer) - (let* ((imenu-use-markers t) - ;; Generate imenu, see `imenu--make-index-alist'. - (items (imenu--truncate-items - (save-excursion - (save-restriction - (widen) - (funcall imenu-create-index-function))))) - (config (cdr (seq-find (lambda (x) (derived-mode-p (car x))) consult-imenu-config)))) - ;; Fix toplevel items, e.g., emacs-lisp-mode toplevel items are functions - (when-let (toplevel (plist-get config :toplevel)) - (let ((tops (seq-remove (lambda (x) (listp (cdr x))) items)) - (rest (seq-filter (lambda (x) (listp (cdr x))) items))) - (setq items (nconc rest (and tops (list (cons toplevel tops))))))) - ;; Apply our flattening in order to ease searching the imenu. - (consult-imenu--flatten - nil nil items - (mapcar (pcase-lambda (`(,x ,y ,z)) (list y x z)) - (plist-get config :types))))) - -(defun consult-imenu--deduplicate (items) - "Deduplicate imenu ITEMS by appending a counter." - ;; Some imenu backends generate duplicate items (e.g. for overloaded methods in java) - (let ((ht (make-hash-table :test #'equal :size (length items)))) - (dolist (item items) - (if-let (count (gethash (car item) ht)) - (setcar item (format "%s (%s)" (car item) - (puthash (car item) (1+ count) ht))) - (puthash (car item) 0 ht))))) - -(defun consult-imenu--items () - "Return cached imenu candidates, may error." - (unless (equal (car consult-imenu--cache) (buffer-modified-tick)) - (setq consult-imenu--cache (cons (buffer-modified-tick) (consult-imenu--compute)))) - (cdr consult-imenu--cache)) - -(defun consult-imenu--items-safe () - "Return cached imenu candidates, will not error." - (condition-case err - (consult-imenu--items) - (t (message "Cannot create Imenu for buffer %s (%s)" - (buffer-name) (error-message-string err)) - nil))) - -(defun consult-imenu--multi-items (buffers) - "Return all imenu items from BUFFERS." - (apply #'append (consult--buffer-map buffers #'consult-imenu--items-safe))) - -(defun consult-imenu--jump (item) - "Jump to imenu ITEM via `consult--jump'. - -In contrast to the builtin `imenu' jump function, -this function can jump across buffers." - (pcase item - (`(,name ,pos ,fn . ,args) (apply fn name pos args)) - (`(,_ . ,pos) (consult--jump pos)) - (_ (error "Unknown imenu item: %S" item)))) - -(defun consult-imenu--select (prompt items) - "Select from imenu ITEMS given PROMPT string." - (let ((narrow - (mapcar (lambda (x) (cons (car x) (cadr x))) - (plist-get (cdr (seq-find (lambda (x) (derived-mode-p (car x))) - consult-imenu-config)) - :types)))) - (consult-imenu--deduplicate items) - (consult-imenu--jump - (consult--read - (or items (user-error "Imenu is empty")) - :prompt prompt - :state - (let ((preview (consult--jump-preview))) - (lambda (cand restore) - ;; Only preview simple menu items which are markers, - ;; in order to avoid any bad side effects. - (funcall preview (and (markerp (cdr cand)) (cdr cand)) restore))) - :require-match t - :group - (when narrow - (lambda (cand transform) - (when-let (type (get-text-property 0 'consult--type cand)) - (if transform - (substring cand (1+ (next-single-property-change 0 'consult--type cand))) - (alist-get type narrow))))) - :narrow - (when narrow - (list :predicate - (lambda (cand) - (eq (get-text-property 0 'consult--type (car cand)) consult--narrow)) - :keys narrow)) - :category 'imenu - :lookup #'consult--lookup-cons - :history 'consult-imenu--history - :add-history (thing-at-point 'symbol) - :sort nil)))) - -;;;###autoload -(defun consult-imenu () - "Select item from flattened `imenu' using `completing-read' with preview. - -The command supports preview and narrowing. See the variable -`consult-imenu-config', which configures the narrowing. -The symbol at point is added to the future history. - -See also `consult-imenu-multi'." - (interactive) - (consult-imenu--select "Go to item: " (consult-imenu--items))) - -;;;###autoload -(defun consult-imenu-multi (&optional query) - "Select item from the imenus of all buffers from the same project. - -In order to determine the buffers belonging to the same project, the -`consult-project-root-function' is used. Only the buffers with the -same major mode as the current buffer are used. See also -`consult-imenu' for more details. 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 :mode major-mode - :directory (and (not query) 'project)))) - (let ((buffers (consult--buffer-query-prompt "Go to item" query))) - (consult-imenu--select (car buffers) - (consult-imenu--multi-items (cdr buffers))))) - -(provide 'consult-imenu) -;;; consult-imenu.el ends here diff --git a/elpa/consult-0.13/consult-imenu.elc b/elpa/consult-0.13/consult-imenu.elc Binary files differ. diff --git a/elpa/consult-0.13/consult-org.el b/elpa/consult-0.13/consult-org.el @@ -1,124 +0,0 @@ -;;; consult-org.el --- Consult commands for org-mode -*- lexical-binding: t -*- - -;; Copyright (C) 2021 Free Software Foundation, Inc. - -;; 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 <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Provides a `completing-read' interface for Org mode navigation. -;; This is an extra package, to allow lazy loading of Org. - -;;; Code: - -(require 'consult) -(require 'org) - -(defvar consult-org--history nil) - -(defun consult-org--narrow () - "Narrowing configuration for `consult-org' commands." - (let ((todo-kws - (seq-filter - (lambda (x) (<= ?a (car x) ?z)) - (mapcar (lambda (s) - (pcase-let ((`(,a ,b) (split-string s "("))) - (cons (downcase (string-to-char (or b a))) a))) - (apply #'append (mapcar #'cdr org-todo-keywords)))))) - (list :predicate - (lambda (cand) - (pcase-let ((`(_ ,level ,todo ,prio) - (get-text-property 0 'consult-org--heading cand))) - (cond - ((<= ?1 consult--narrow ?9) (<= level (- consult--narrow ?0))) - ((<= ?A consult--narrow ?Z) (eq prio consult--narrow)) - (t (equal todo (alist-get consult--narrow todo-kws)))))) - :keys - (nconc (mapcar (lambda (c) (cons c (format "Level %c" c))) - (number-sequence ?1 ?9)) - (mapcar (lambda (c) (cons c (format "Priority %c" c))) - (number-sequence (max ?A org-highest-priority) - (min ?Z org-lowest-priority))) - todo-kws)))) - -(defun consult-org--headings (prefix match scope &rest skip) - "Return a list of Org heading candidates. - -If PREFIX is non-nil, prefix the candidates with the buffer name. -MATCH, SCOPE and SKIP are as in `org-map-entries'." - (let (buffer) - (apply - #'org-map-entries - (lambda () - ;; Reset the cache when the buffer changes, since `org-get-outline-path' uses the cache - (unless (eq buffer (buffer-name)) - (setq buffer (buffer-name) - org-outline-path-cache nil)) - (pcase-let ((`(_ ,level ,todo ,prio . _) (org-heading-components)) - (cand (org-format-outline-path - (org-get-outline-path 'with-self 'use-cache) - most-positive-fixnum))) - (setq cand (if prefix - (concat buffer " " cand (consult--tofu-encode (point))) - (concat cand (consult--tofu-encode (point))))) - (put-text-property 0 1 'consult-org--heading (list (point-marker) level todo prio) cand) - cand)) - match scope skip))) - -;;;###autoload -(defun consult-org-heading (&optional match scope) - "Jump to an Org heading. - -MATCH and SCOPE are as in `org-map-entries' and determine which -entries are offered. By default, all entries of the current -buffer are offered." - (interactive (unless (derived-mode-p 'org-mode) - (user-error "Must be called from an Org buffer"))) - (let ((prefix (not (memq scope '(nil tree region region-start-level file))))) - (consult--read - (consult--with-increased-gc (consult-org--headings prefix match scope)) - :prompt "Go to heading: " - :category 'consult-org-heading - :sort nil - :require-match t - :history '(:input consult-org--history) - :narrow (consult-org--narrow) - :state (consult--jump-state) - :group - (when prefix - (lambda (cand transform) - (let ((name (buffer-name - (marker-buffer - (car (get-text-property 0 'consult-org--heading cand)))))) - (if transform (substring cand (1+ (length name))) name)))) - :lookup - (lambda (_ candidates cand) - (when-let (found (member cand candidates)) - (car (get-text-property 0 'consult-org--heading (car found)))))))) - -;;;###autoload -(defun consult-org-agenda (&optional match) - "Jump to an Org agenda heading. - -By default, all agenda entries are offered. MATCH is as in -`org-map-entries' and can used to refine this." - (interactive) - (unless org-agenda-files - (user-error "No agenda files")) - (consult-org-heading match 'agenda)) - -(provide 'consult-org) -;;; consult-org.el ends here diff --git a/elpa/consult-0.13/consult-org.elc b/elpa/consult-0.13/consult-org.elc Binary files differ. diff --git a/elpa/consult-0.13/consult-pkg.el b/elpa/consult-0.13/consult-pkg.el @@ -1,10 +0,0 @@ -(define-package "consult" "0.13" "Consulting completing-read" - '((emacs "26.1")) - :commit "c2fed383c9c555ed017200a22efad0a9734725b0" :authors - '(("Daniel Mendler and Consult contributors")) - :maintainer - '("Daniel Mendler" . "mail@daniel-mendler.de") - :url "https://github.com/minad/consult") -;; Local Variables: -;; no-byte-compile: t -;; End: diff --git a/elpa/consult-0.13/consult-register.el b/elpa/consult-0.13/consult-register.el @@ -1,266 +0,0 @@ -;;; consult-register.el --- Consult commands for registers -*- lexical-binding: t -*- - -;; Copyright (C) 2021 Free Software Foundation, Inc. - -;; 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 <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Provides register-related Consult commands. - -;;; Code: - -(require 'consult) - -(defcustom consult-register-narrow - `((?n "Number" ,#'numberp) - (?s "String" ,#'stringp) - (?p "Point" ,#'markerp) - (?r "Rectangle" ,(lambda (x) (stringp (car-safe x)))) - ;; frameset-register-p and kmacro-register-p exists since 27.1 - (?t "Frameset" ,(lambda (x) (eq (type-of x) 'frameset-register))) - (?k "Kmacro" ,(lambda (x) (eq (type-of x) 'kmacro-register))) - (?f "File" ,(lambda (x) (memq (car-safe x) '(file file-query)))) - (?w "Window" ,(lambda (x) (window-configuration-p (car-safe x))))) - "Register narrowing configuration. - -Each element of the list must have the form '(char name predicate)." - :type '(repeat (list character string function)) - :group 'consult) - -;;;###autoload -(defun consult-register-window (buffer &optional show-empty) - "Enhanced drop-in replacement for `register-preview'. - -BUFFER is the window buffer. -SHOW-EMPTY must be t if the window should be shown for an empty register list." - (let ((regs (seq-filter #'cdr register-alist)) - (separator - (and (display-graphic-p) - (propertize (concat (propertize " " 'display '(space :align-to right)) "\n") - 'face '(:inherit consult-separator :height 1 :underline t))))) - (when (or show-empty regs) - (with-current-buffer-window buffer - (cons 'display-buffer-below-selected - '((window-height . fit-window-to-buffer) - (preserve-size . (nil . t)))) - nil - (setq-local cursor-in-non-selected-windows nil) - (setq-local mode-line-format nil) - (setq-local truncate-lines t) - (setq-local window-min-height 1) - (setq-local window-resize-pixelwise t) - (insert (mapconcat - (lambda (reg) - (concat (funcall register-preview-function reg) separator)) - (seq-sort #'car-less-than-car regs) nil)))))) - -;;;###autoload -(defun consult-register-format (reg) - "Enhanced preview of register REG. - -This function can be used as `register-preview-function'." - (concat (consult-register--format reg) "\n")) - -(defun consult-register--format (reg) - "Format register REG for preview." - (pcase-let ((`(,key . ,val) reg)) - (let* ((key-str (propertize (single-key-description key) 'face 'consult-key)) - (len (max 3 (length key-str)))) - (concat - key-str - (make-string (- len (length key-str)) ?\s) - ;; Special printing for certain register types - (cond - ;; Display full string - ((or (stringp val) (stringp (car-safe val))) - (when (consp val) - (setq val (mapconcat #'identity val "\n"))) - (mapconcat #'identity - (seq-take (split-string (string-trim val) "\n") 3) - (concat "\n" (make-string len ?\s)))) - ;; Display 'file-query - ((eq (car-safe val) 'file-query) - (format "%s at position %d" - (propertize (abbreviate-file-name (cadr val)) 'face 'consult-file) - (caddr val))) - ;; Display 'file - ((eq (car-safe val) 'file) - (propertize (abbreviate-file-name (cdr val)) 'face 'consult-file)) - ;; Display full line of buffer - ((and (markerp val) (marker-buffer val)) - (with-current-buffer (marker-buffer val) - (save-restriction - (save-excursion - (widen) - (goto-char val) - (consult--format-location (buffer-name) (line-number-at-pos) - (consult--line-with-cursor val)))))) - ;; Default printing for the other types - (t (register-describe-oneline key))))))) - -(defun consult-register--alist () - "Return register list or raise an error if the list is empty." - ;; Sometimes, registers are made without a `cdr'. - ;; Such registers don't do anything, and can be ignored. - (or (seq-filter #'cdr register-alist) (user-error "All registers are empty"))) - -(defun consult-register--candidates () - "Return list of formatted register candidates." - (mapcar (lambda (reg) - (propertize - (consult-register--format reg) - 'consult--candidate (car reg) - 'consult--type - (car (seq-find (lambda (x) (funcall (caddr x) (cdr reg))) - consult-register-narrow)))) - (sort (consult-register--alist) #'car-less-than-car))) - -;;;###autoload -(defun consult-register (&optional arg) - "Load register and either jump to location or insert the stored text. - -This command is useful to search the register contents. For quick access to -registers it is still recommended to use the register functions -`consult-register-load' and `consult-register-store' or the built-in built-in -register access functions. The command supports narrowing, see -`consult-register-narrow'. Marker positions are previewed. See -`jump-to-register' and `insert-register' for the meaning of prefix ARG." - (interactive "P") - (let ((narrow (mapcar (lambda (x) (cons (car x) (cadr x))) - consult-register-narrow))) - (consult-register-load - (consult--read - (consult-register--candidates) - :prompt "Register: " - :category 'consult-register - :state - (let ((preview (consult--jump-preview))) - (lambda (cand restore) - ;; Preview only markers - (funcall preview - (when-let (reg (get-register cand)) - (and (markerp reg) reg)) - restore))) - :group (consult--type-group narrow) - :narrow (consult--type-narrow narrow) - :sort nil - :require-match t - :history t ;; disable history - :lookup #'consult--lookup-candidate) - arg))) - -;;;###autoload -(defun consult-register-load (reg &optional arg) - "Do what I mean with a REG. - -For a window configuration, restore it. For a number or text, insert it. For a -location, jump to it. See `jump-to-register' and `insert-register' for the -meaning of prefix ARG." - (interactive - (list - (and (consult-register--alist) - (register-read-with-preview "Load register: ")) - current-prefix-arg)) - (condition-case nil - (jump-to-register reg arg) - (user-error (insert-register reg (not arg))))) - -(defun consult-register--action (action-list) - "Read register key and execute action from ACTION-LIST. - -This function is derived from `register-read-with-preview'." - (let* ((buffer "*Register Preview*") - (prefix (car action-list)) - (action-list (cdr action-list)) - (action (car (nth 0 action-list))) - (reg) - (preview - (lambda () - (unless (get-buffer-window buffer) - (register-preview buffer 'show-empty) - (when-let (win (get-buffer-window buffer)) - (with-selected-window win - (let ((inhibit-read-only t)) - (goto-char (point-max)) - (insert - (propertize (concat prefix ": ") 'face 'consult-help) - (mapconcat - (lambda (x) - (concat (propertize (format "M-%c" (car x)) 'face 'consult-key) - " " (propertize (cadr x) 'face 'consult-help))) - action-list " ")) - (fit-window-to-buffer))))))) - (timer (when (numberp register-preview-delay) - (run-at-time register-preview-delay nil preview))) - (help-chars (seq-remove #'get-register (cons help-char help-event-list)))) - (unwind-protect - (while (not reg) - (while (memq (read-key (propertize (caddr (assq action action-list)) - 'face 'minibuffer-prompt)) - help-chars) - (funcall preview)) - (cond - ((or (eq ?\C-g last-input-event) - (eq 'escape last-input-event) - (eq ?\C-\[ last-input-event)) - (keyboard-quit)) - ((and (numberp last-input-event) (assq (logxor #x8000000 last-input-event) action-list)) - (setq action (logxor #x8000000 last-input-event))) - ((characterp last-input-event) - (setq reg last-input-event)) - (t (error "Non-character input-event")))) - (when (timerp timer) - (cancel-timer timer)) - (let ((w (get-buffer-window buffer))) - (when (window-live-p w) - (delete-window w))) - (when (get-buffer buffer) - (kill-buffer buffer))) - (when reg - (funcall (cadddr (assq action action-list)) reg)))) - -;;;###autoload -(defun consult-register-store (arg) - "Store register dependent on current context, showing an action menu. - -With an active region, store/append/prepend the contents, optionally deleting -the region when a prefix ARG is given. With a numeric prefix ARG, store/add the -number. Otherwise store point, frameset, window or kmacro." - (interactive "P") - (consult-register--action - (cond - ((use-region-p) - (let ((beg (region-beginning)) - (end (region-end))) - `("Region" - (?c "copy" "Copy region to register: " ,(lambda (r) (copy-to-register r beg end arg t))) - (?a "append" "Append region to register: " ,(lambda (r) (append-to-register r beg end arg))) - (?p "prepend" "Prepend region to register: " ,(lambda (r) (prepend-to-register r beg end arg)))))) - ((numberp arg) - `(,(format "Number %s" arg) - (?s "store" ,(format "Store %s in register: " arg) ,(lambda (r) (number-to-register arg r))) - (?a "add" ,(format "Add %s to register: " arg) ,(lambda (r) (increment-register arg r))))) - (t - `("Store" - (?p "point" "Point to register: " ,#'point-to-register) - (?f "file" "File to register: " ,(lambda (r) (set-register r `(file . ,(buffer-file-name))))) - (?t "frameset" "Frameset to register: " ,#'frameset-to-register) - (?w "window" "Window to register: " ,#'window-configuration-to-register) - ,@(and last-kbd-macro `((?k "kmacro" "Kmacro to register: " ,#'kmacro-to-register)))))))) - -(provide 'consult-register) -;;; consult-register.el ends here diff --git a/elpa/consult-0.13/consult-register.elc b/elpa/consult-0.13/consult-register.elc Binary files differ. diff --git a/elpa/consult-0.13/consult-selectrum.el b/elpa/consult-0.13/consult-selectrum.el @@ -1,104 +0,0 @@ -;;; consult-selectrum.el --- Selectrum integration for Consult -*- lexical-binding: t -*- - -;; Copyright (C) 2021 Free Software Foundation, Inc. - -;; 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 <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Integration code for the Selectrum completion system. This package -;; is automatically loaded by Consult. - -;;; Code: - -(require 'consult) - -;; NOTE: It is not guaranteed that Selectrum is available during compilation! -(defvar selectrum-default-value-format) -(defvar selectrum-highlight-candidates-function) -(defvar selectrum-is-active) -(defvar selectrum-refine-candidates-function) -(defvar selectrum--history-hash) -(declare-function selectrum-exhibit "ext:selectrum") -(declare-function selectrum-get-current-candidate "ext:selectrum") - -(defun consult-selectrum--filter-adv (orig pattern cands category highlight) - "Advice for ORIG `consult--completion-filter' function. -See `consult--completion-filter' for arguments PATTERN, CANDS, CATEGORY -and HIGHLIGHT." - ;; Do not use selectrum-is-active here, since we want to always use - ;; the Selectrum filtering when Selectrum is installed, even when - ;; Selectrum is currently not active. - ;; However if `selectrum-refine-candidates-function' is the default - ;; function, which uses the completion styles, the Selectrum filtering - ;; is not used and the original function is called. - (if (and (eq completing-read-function 'selectrum-completing-read) - (not (eq selectrum-refine-candidates-function - 'selectrum-refine-candidates-using-completions-styles))) - (if highlight - (funcall selectrum-highlight-candidates-function pattern - (funcall selectrum-refine-candidates-function pattern cands)) - (funcall selectrum-refine-candidates-function pattern cands)) - (funcall orig pattern cands category highlight))) - -(defun consult-selectrum--candidate () - "Return current selectrum candidate." - (and selectrum-is-active (selectrum-get-current-candidate))) - -(defun consult-selectrum--refresh (&optional reset) - "Refresh completion UI, keep current candidate unless RESET is non-nil." - (when selectrum-is-active - (when consult--narrow - (setq-local selectrum-default-value-format nil)) - (when reset - (setq-local selectrum--history-hash nil)) - (selectrum-exhibit (not reset)))) - -(defun consult-selectrum--split-wrap (orig split) - "Wrap candidates highlight/refinement ORIG function, splitting -the input using SPLIT." - (lambda (str cands) - (funcall orig (cadr (funcall split str 0)) cands))) - -(defun consult-selectrum--split-setup-adv (orig split) - "Advice for `consult--split-setup' to be used by Selectrum. - -ORIG is the original function. -SPLIT is the splitter function." - (if (not selectrum-is-active) - (funcall orig split) - (setq-local selectrum-refine-candidates-function - (consult-selectrum--split-wrap selectrum-refine-candidates-function split)) - (setq-local selectrum-highlight-candidates-function - (consult-selectrum--split-wrap selectrum-highlight-candidates-function split)))) - -(defun consult-selectrum--crm-adv (&rest args) - "Setup crm for Selectrum given ARGS." - (consult--minibuffer-with-setup-hook - (lambda () - (when selectrum-is-active - (setq-local selectrum-default-value-format nil))) - (apply args))) - -(add-hook 'consult--completion-candidate-hook #'consult-selectrum--candidate) -(add-hook 'consult--completion-refresh-hook #'consult-selectrum--refresh) -(advice-add #'consult-completing-read-multiple :around #'consult-selectrum--crm-adv) -(advice-add #'consult--completion-filter :around #'consult-selectrum--filter-adv) -(advice-add #'consult--split-setup :around #'consult-selectrum--split-setup-adv) -(define-key consult-async-map [remap selectrum-insert-current-candidate] 'selectrum-next-page) - -(provide 'consult-selectrum) -;;; consult-selectrum.el ends here diff --git a/elpa/consult-0.13/consult-selectrum.elc b/elpa/consult-0.13/consult-selectrum.elc Binary files differ. diff --git a/elpa/consult-0.13/consult-vertico.el b/elpa/consult-0.13/consult-vertico.el @@ -1,54 +0,0 @@ -;;; consult-vertico.el --- Vertico integration for Consult -*- lexical-binding: t -*- - -;; Copyright (C) 2021 Free Software Foundation, Inc. - -;; 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 <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Integration code for the Vertico completion system. This package -;; is automatically loaded by Consult. - -;;; Code: - -(require 'consult) - -;; NOTE: It is not guaranteed that Vertico is available during compilation! -(defvar vertico--input) -(defvar vertico--history-hash) -(defvar vertico--lock-candidate) -(declare-function vertico--exhibit "ext:vertico") -(declare-function vertico--candidate "ext:vertico") - -(defun consult-vertico--candidate () - "Return current candidate for Consult preview." - (and vertico--input (vertico--candidate 'highlight))) - -(defun consult-vertico--refresh (&optional reset) - "Refresh completion UI, keep current candidate unless RESET is non-nil." - (when vertico--input - (setq vertico--input t) - (when reset - (setq vertico--history-hash nil - vertico--lock-candidate nil)) - (vertico--exhibit))) - -(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) - -(provide 'consult-vertico) -;;; consult-vertico.el ends here diff --git a/elpa/consult-0.13/consult-vertico.elc b/elpa/consult-0.13/consult-vertico.elc Binary files differ. diff --git a/elpa/consult-0.13/consult-xref.el b/elpa/consult-0.13/consult-xref.el @@ -1,116 +0,0 @@ -;;; consult-xref.el --- Xref integration for Consult -*- lexical-binding: t -*- - -;; Copyright (C) 2021 Free Software Foundation, Inc. - -;; 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 <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Provides Xref integration for Consult. This is an extra package, to -;; allow lazy loading of xref.el. The `consult-xref' function is -;; autoloaded. - -;;; Code: - -(require 'consult) -(require 'xref) - -(defvar consult-xref--history nil) - -(defun consult-xref--candidates (xrefs) - "Return candidate list from XREFS." - (mapcar (lambda (xref) - (let* ((loc (xref-item-location xref)) - (group (xref-location-group loc)) - (cand (consult--format-location group - (or (xref-location-line loc) 0) - (xref-item-summary xref)))) - (add-text-properties - 0 1 `(consult--candidate ,xref consult-xref--group ,group) cand) - cand)) - xrefs)) - -(defun consult-xref--preview (display) - "Xref preview with DISPLAY function." - (let ((open (consult--temporary-files)) - (preview (consult--jump-preview))) - (lambda (cand restore) - (cond - (restore - (funcall preview nil t) - (funcall open nil)) - (cand - (let ((loc (xref-item-location cand)) - (consult--buffer-display display)) - (funcall preview - ;; Only preview file and buffer markers - (cl-typecase loc - (xref-buffer-location - (xref-location-marker loc)) - (xref-file-location - (consult--position-marker - (funcall open - ;; xref-location-group returns the file name - (let ((xref-file-name-display 'abs)) - (xref-location-group loc))) - (xref-location-line loc) - (xref-file-location-column loc))) - (t (message "No preview for %s" (type-of loc)) nil)) - nil))))))) - -(defun consult-xref--group (cand transform) - "Return title for CAND or TRANSFORM the candidate." - (if transform - (substring cand (1+ (length (get-text-property 0 'consult-xref--group cand)))) - (get-text-property 0 'consult-xref--group cand))) - -;;;###autoload -(defun consult-xref (fetcher &optional alist) - "Show xrefs with preview in the minibuffer. - -This function can be used for `xref-show-xrefs-function'. -See `xref-show-xrefs-function' for the description of the -FETCHER and ALIST arguments." - (let ((candidates (consult--with-increased-gc - (consult-xref--candidates (funcall fetcher)))) - (display (alist-get 'display-action alist))) - (xref-pop-to-location - (if (cdr candidates) - (apply - #'consult--read - candidates - (append - (alist-get #'consult-xref consult--read-config) - (list - :prompt "Go to xref: " - :history 'consult-xref--history - :require-match t - :sort nil - :category 'xref-location - :group #'consult-xref--group - :state - ;; do not preview other frame - (when-let (fun (pcase-exhaustive display - ('frame nil) - ('window #'switch-to-buffer-other-window) - ('nil #'switch-to-buffer))) - (consult-xref--preview fun)) - :lookup #'consult--lookup-candidate))) - (get-text-property 0 'consult--candidate (car candidates))) - display))) - -(provide 'consult-xref) -;;; consult-xref.el ends here diff --git a/elpa/consult-0.13/consult-xref.elc b/elpa/consult-0.13/consult-xref.elc Binary files differ. diff --git a/elpa/consult-0.13/consult.el b/elpa/consult-0.13/consult.el @@ -1,4472 +0,0 @@ -;;; consult.el --- Consulting completing-read -*- lexical-binding: t -*- - -;; Copyright (C) 2021 Free Software Foundation, Inc. - -;; Author: Daniel Mendler and Consult contributors -;; Maintainer: Daniel Mendler <mail@daniel-mendler.de> -;; Created: 2020 -;; Version: 0.13 -;; Package-Requires: ((emacs "26.1")) -;; Homepage: https://github.com/minad/consult - -;; 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 <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Consult implements a set of `consult-<thing>' commands which use -;; `completing-read' to select from a list of candidates. 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 -;; allow previewing candidates - if a candidate is selected in the completion -;; view, the buffer shows the candidate immediately. - -;; The Consult commands are compatible with completion systems based -;; on the Emacs `completing-read' API, including the default completion -;; system, Icomplete, Selectrum, Vertico and Embark. - -;; Consult has been inspired by Counsel. Some of the Consult commands -;; originated in the Counsel package or the Selectrum wiki. See the -;; README for a full list of contributors. - -;;; Code: - -(eval-when-compile - (require 'cl-lib) - (require 'subr-x)) -(require 'bookmark) -(require 'kmacro) -(require 'recentf) -(require 'seq) - -(defgroup consult nil - "Consulting `completing-read'." - :group 'convenience - :group 'minibuffer - :prefix "consult-") - -;;;; Customization - -(defcustom consult-narrow-key nil - "Prefix key for narrowing during completion. - -Good choices for this key are (kbd \"<\") or (kbd \"C-+\") for example. - -The key must be either a string or a vector. -This is the key representation accepted by `define-key'." - :type '(choice key-sequence (const 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 either a string or a vector. -This is the key representation accepted by `define-key'." - :type '(choice key-sequence (const nil))) - -(defcustom consult-project-root-function nil - "Function which returns project root directory. - -The root directory is used by `consult-buffer' and `consult-grep'." - :type '(choice function (const 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) - -(defcustom consult-async-input-throttle 0.4 - "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) - -(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) - -(defcustom consult-async-min-input 3 - "Minimum number of letters needed, before asynchronous process is called. - -This applies to asynchronous commands, e.g., `consult-grep'." - :type 'integer) - -(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 - '((nil :type nil) - (comma :separator ?, :type separator) - (semicolon :separator ?\; :type separator) - (perl :initial "#" :type perl)) - "Async splitting styles." - :type '(alist :key-type symbol :value-type plist)) - -(defcustom consult-mode-histories - '((eshell-mode . eshell-history-ring) - (comint-mode . comint-input-ring) - (term-mode . term-input-ring)) - "Alist of (mode . history) pairs of mode histories. -The histories can be rings or lists." - :type '(alist :key-type symbol :value-type symbol)) - -(defcustom consult-themes nil - "List of themes to be presented for selection. -nil shows all `custom-available-themes'." - :type '(repeat symbol)) - -(defcustom consult-after-jump-hook '(recenter) - "Function called after jumping to a location. - -Commonly used functions for this hook are `recenter' and `reposition-window'. -This is 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-line-point-placement 'match-beginning - "Where to leave point after `consult-line' jumps to a match." - :type '(choice (const :tag "Beginning of the line" line-beginning) - (const :tag "Beginning of the match" match-beginning) - (const :tag "End of the match" match-end))) - -(defcustom consult-line-numbers-widen t - "Show absolute line numbers when narrowing is active. - -See also `display-line-numbers-widen'." - :type 'boolean) - -(defcustom consult-goto-line-numbers t - "Show line numbers for `consult-goto-line'." - :type 'boolean) - -(defcustom consult-fontify-preserve t - "Preserve fontification for line-based commands." - :type 'boolean) - -(defcustom consult-fontify-max-size 1048576 - "Buffers larger than this byte limit are not fontified. - -This is necessary in order to prevent a large startup time -for navigation commands like `consult-line'." - :type 'integer) - -(defcustom consult-buffer-filter - '("\\` " - "\\`\\*Completions\\*\\'" - "\\`\\*Flymake log\\*\\'" - "\\`\\*Semantic SymRef\\*\\'" - "\\`\\*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." - :type '(repeat regexp)) - -(defcustom consult-buffer-sources - '(consult--source-hidden-buffer - consult--source-buffer - consult--source-file - consult--source-bookmark - consult--source-project-buffer - consult--source-project-file) - "Sources used by `consult-buffer'. - -See `consult--multi' for a description of the source values." - :type '(repeat symbol)) - -(defcustom consult-mode-command-filter - '(;; Filter commands - "-mode\\'" "--" - ;; Filter whole features - simple mwheel time so-long recentf) - "Filter commands for `consult-mode-command'." - :type '(repeat (choice symbol regexp))) - -(defcustom consult-grep-max-columns 300 - "Maximal number of columns of grep output." - :type 'integer) - -(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 --null --line-buffered --color=never --ignore-case\ - --exclude-dir=.git --line-number -I -r ." - "Command line arguments for grep, see `consult-grep'. -The dynamically computed arguments are appended." - :type 'string) - -(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." - :type 'string) - -(defcustom consult-ripgrep-args - "rg --null --line-buffered --color=never --max-columns=1000 --path-separator /\ - --smart-case --no-heading --line-number ." - "Command line arguments for ripgrep, see `consult-ripgrep'. -The dynamically computed arguments are appended." - :type 'string) - -(defcustom consult-find-args - "find . -not ( -wholename */.* -prune )" - "Command line arguments for find, see `consult-find'. -The dynamically computed arguments are appended." - :type 'string) - -(defcustom consult-locate-args - "locate --ignore-case --existing --regexp" - "Command line arguments for locate, see `consult-locate'. -The dynamically computed arguments are appended." - :type 'string) - -(defcustom consult-man-args - "man -k" - "Command line arguments for man, see `consult-man'. -The dynamically computed arguments are appended." - :type 'string) - -(defcustom consult-preview-key 'any - "Preview trigger keys, can be nil, 'any, a single key or a list of keys." - :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-sequence :tag "Key") - (repeat :tag "List of keys" key-sequence))) - -(defcustom consult-preview-max-size 10485760 - "Files larger than this byte limit are not previewed." - :type 'integer) - -(defcustom consult-preview-raw-size 102400 - "Files larger than this byte limit are previewed in raw form." - :type 'integer) - -(defcustom consult-preview-max-count 10 - "Number of files to keep open at once during preview." - :type 'integer) - -(defcustom consult-preview-excluded-hooks - '(epa-file-find-file-hook - recentf-track-opened-file - vc-refresh-state) - "List of `find-file' hooks, which should not be executed during file preview. -In particular we don't want to modify the list of recent files and we -don't want to see epa password prompts." - :type '(repeat symbol)) - -(defcustom consult-bookmark-narrow - `((?f "File" ,#'bookmark-default-handler) - (?h "Help" ,#'help-bookmark-jump) - (?i "Info" ,#'Info-bookmark-jump) - (?p "Picture" ,#'image-bookmark-jump) - (?d "Docview" ,#'doc-view-bookmark-jump) - (?m "Man" ,#'Man-bookmark-jump) - (?w "Woman" ,#'woman-bookmark-jump) - (?g "Gnus" ,#'gnus-summary-bookmark-jump)) - "Bookmark narrowing configuration. - -Each element of the list must have the form '(char name handler)." - :type '(repeat (list character string function))) - -(defcustom consult-crm-prefix - (cons " " (propertize "✓ " 'face 'success)) - "Prefix for `consult-completing-read-multiple' candidates." - :type '(cons (string :tag "Not selected") (string :tag "Selected"))) - -;;;; 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 to for line previews.") - -(defface consult-preview-match - '((t :inherit match)) - "Face used to for match previews in `consult-grep'.") - -(defface consult-preview-cursor - '((t :inherit consult-preview-match)) - "Face used to for cursor previews and marks in `consult-mark'.") - -(defface consult-preview-error - '((t :inherit isearch-fail)) - "Face used to for cursor previews and marks in `consult-compile-error'.") - -(defface consult-preview-insertion - '((t :inherit region)) - "Face used to for previews of text to be inserted. -Used by `consult-completion-in-region', `consult-yank' and `consult-history'.") - -(defface consult-narrow-indicator - '((t :inherit warning)) - "Face used for the narrowing indicator.") - -(defface consult-async-running - '((t :inherit consult-narrow-indicator)) - "Face used if asynchronous process is running.") - -(defface consult-async-finished - '((t :inherit success)) - "Face used if asynchronous process has finished.") - -(defface consult-async-failed - '((t :inherit error)) - "Face used if asynchronous process has failed.") - -(defface consult-async-split - '((t :inherit font-lock-negation-char-face)) - "Face used to highlight punctuation character.") - -(defface consult-help - '((t :inherit shadow)) - "Face used to highlight help, e.g., in `consult-register-store'.") - -(defface consult-key - '((t :inherit font-lock-keyword-face)) - "Face used to highlight keys, e.g., in `consult-register'.") - -(defface consult-line-number - '((t :inherit consult-key)) - "Face used to highlight location line in `consult-global-mark'.") - -(defface consult-file - '((t :inherit font-lock-function-name-face)) - "Face used to highlight files in `consult-buffer'.") - -(defface consult-grep-context - '((t :inherit shadow)) - "Face used to highlight grep context in `consult-grep'.") - -(defface consult-bookmark - '((t :inherit font-lock-constant-face)) - "Face used to highlight bookmarks in `consult-buffer'.") - -(defface consult-buffer - '((t)) - "Face used to highlight buffers in `consult-buffer'.") - -(defface consult-crm-selected - '((t :inherit secondary-selection)) - "Face used to highlight selected items in `consult-completing-read-multiple'.") - -(defface consult-line-number-prefix - '((t :inherit line-number)) - "Face used to highlight line number prefixes.") - -(defface consult-line-number-wrapped - '((t :inherit consult-line-number-prefix :inherit font-lock-warning-face)) - "Face used to highlight line number prefixes, if the line number wrapped around.") - -(defface consult-separator - '((((class color) (min-colors 88) (background light)) - :foreground "#ccc") - (((class color) (min-colors 88) (background dark)) - :foreground "#333")) - "Face used for thin line separators in `consult-register-window'.") - -;;;; History variables - -(defvar consult--keep-lines-history nil) -(defvar consult--grep-history nil) -(defvar consult--find-history nil) -(defvar consult--man-history nil) -(defvar consult--line-history nil) -(defvar consult--apropos-history nil) -(defvar consult--theme-history nil) -(defvar consult--minor-mode-menu-history nil) -(defvar consult--mode-command-history nil) -(defvar consult--kmacro-history nil) -(defvar consult--buffer-history nil) -(defvar consult--crm-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--read-config 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 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-mb-candidate - #'consult--default-completion-list-candidate) - "Get candidate from completion system.") - -(defvar consult--completion-refresh-hook nil - "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.") - -(defconst consult--tofu-char #x100000 - "Special character used to encode line prefixes for disambiguation. -We use the first character of the private unicode plane b.") - -(defconst consult--tofu-range #xFFFE - "Special character range. -Size of private unicode plane b.") - -(defvar-local consult--narrow nil - "Current narrowing key.") - -(defvar-local consult--narrow-keys nil - "Narrowing prefixes of the current completion.") - -(defvar-local consult--narrow-predicate nil - "Narrowing predicate of the current completion.") - -(defvar-local consult--narrow-overlay nil - "Narrowing indicator overlay.") - -(defvar consult--gc-threshold (* 64 1024 1024) - "Large gc threshold for temporary increase.") - -(defvar consult--gc-percentage 0.5 - "Large gc percentage for temporary increase.") - -(defvar consult--process-chunk (* 1024 1024) - "Increase process output chunk size.") - -(defvar consult--async-log - " *consult-async*" - "Buffer for async logging output used by `consult--async-process'.") - -(defvar-local consult--focus-lines-overlays nil - "Overlays used by `consult-focus-lines'.") - -;;;; Customization helper - -(defun consult--customize-set (cmds prop val) - "Set property PROP to VAL of commands CMDS." - (dolist (cmd cmds) - (cond - ((and (boundp cmd) (consp (symbol-value cmd))) - (set cmd (plist-put (symbol-value cmd) prop val))) - ((functionp cmd) - (setf (alist-get cmd consult--read-config) - (plist-put (alist-get cmd consult--read-config) prop val))) - (t (user-error "%s is neither a Consult command nor a Consult 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." - (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-set ',cmds ,(car args) ,(cadr args)) setter) - (setq args (cddr args))))) - (macroexp-progn setter))) - -;;;; Helper functions and macros - -(defun consult--command-split (str) - "Return command argument and options list given input STR." - (save-match-data - (let ((opts (when (string-match " +--\\( +\\|\\'\\)" str) - (prog1 (substring str (match-end 0)) - (setq str (substring str 0 (match-beginning 0))))))) - ;; split-string-and-unquote fails if the quotes are invalid. Ignore it. - (cons str (and opts (ignore-errors (split-string-and-unquote opts))))))) - -(defun consult--highlight-regexps (regexps str) - "Highlight REGEXPS in STR. -If a regular expression contains capturing groups, only these are highlighted. -If no capturing groups are used highlight the whole match." - (dolist (re regexps) - (when (string-match re str) - ;; 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 m (or (cddr m) m)) - (while m - (when (car m) - (add-face-text-property (car m) (cadr m) - 'consult-preview-match nil str)) - (setq m (cddr m))))))) - -(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")) - ;; 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 - ;; - 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 "<>")))) ;; 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) - "Compile the INPUT string to a list of regular expressions. -The function should return a pair, the list of regular expressions and a -highlight function. The highlight function should take 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'." - (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)) - (lambda (str) - (consult--highlight-regexps regexps str))))) - -(defun consult--split-escaped (str) - "Split STR at spaces, which can be escaped with backslash." - (mapcar - (lambda (x) (replace-regexp-in-string (string 0) " " x)) - (split-string (replace-regexp-in-string - "\\\\\\\\\\|\\\\ " - (lambda (x) (if (equal x "\\ ") (string 0) x)) - str 'fixedcase 'literal) - " +" t))) - -(defun consult--join-regexps (regexps type) - "Join REGEXPS of TYPE." - ;; Add lookahead 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) - (message "Too many regexps, %S ignored. Use post-filtering!" - (string-join (seq-drop regexps 3) " ")) - (setq regexps (seq-take regexps 3))) - (consult--regexp-join-permutations regexps - (and (memq type '(basic emacs)) "\\"))))) - -(defun consult--regexp-join-permutations (regexps esc) - "Join all permutations of REGEXPS. -ESC is the escaping string for choice and groups." - (pcase regexps - ('nil "") - (`(,r) r) - (`(,r1 ,r2) (concat r1 ".*" r2 esc "|" r2 ".*" r1)) - (_ (mapconcat - (lambda (r) - (concat r ".*" esc "(" - (consult--regexp-join-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 "\\|"))) - -(defmacro consult--keep! (list form) - "Evaluate FORM for every element of LIST and keep the non-nil results." - (declare (indent 1)) - (let ((head (make-symbol "head")) - (prev (make-symbol "prev")) - (result (make-symbol "result"))) - `(let* ((,head (cons nil ,list)) - (,prev ,head)) - (while (cdr ,prev) - (if-let (,result (let ((it (cadr ,prev))) ,form)) - (progn - (pop ,prev) - (setcar ,prev ,result)) - (setcdr ,prev (cddr ,prev)))) - (setq ,list (cdr ,head)) - nil))) - -;; Upstream bug#46326, Consult issue https://github.com/minad/consult/issues/193 -(defmacro consult--minibuffer-with-setup-hook (fun &rest body) - "Variant of `minibuffer-with-setup-hook' using a symbol and `fset'. - -This macro is only needed to prevent memory leaking issues with -the upstream `minibuffer-with-setup-hook' macro. -FUN is the hook function and BODY opens the minibuffer." - (declare (indent 1) (debug t)) - (let ((hook (make-symbol "hook")) - (append)) - (when (eq (car-safe fun) :append) - (setq append '(t) fun (cadr fun))) - `(let ((,hook (make-symbol "consult--minibuffer-setup"))) - (fset ,hook (lambda () - (remove-hook 'minibuffer-setup-hook ,hook) - (funcall ,fun))) - (unwind-protect - (progn - (add-hook 'minibuffer-setup-hook ,hook ,@append) - ,@body) - (remove-hook 'minibuffer-setup-hook ,hook))))) - -(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." - ;; completion-all-completions returns an improper list - ;; where the last link is not necessarily nil. - ;; TODO Implement support to disable highlighting as in Vertico deferred highlighting. - (nconc (completion-all-completions - pattern cands nil (length pattern) - `(metadata (category . ,category))) - nil)) - -(defun consult--completion-filter-complement (pattern cands category _highlight) - "Filter CANDS with complement of PATTERN. -See `consult--completion-filter' for the arguments CATEGORY and HIGHLIGHT." - (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 nil)) - (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)) - (let ((max (make-symbol "max"))) - `(save-excursion - (let ((,beg (point-min)) (,max (point-max)) end) - (while (< ,beg ,max) - (goto-char ,beg) - (setq ,end (line-end-position)) - ,@body - (setq ,beg (1+ ,end))))))) - -(defmacro consult--static-if (cond then &rest else) - "If COND yields non-nil at compile time, do THEN, else do ELSE." - (declare (indent 2)) - (if (eval cond 'lexical) then (macroexp-progn else))) - -(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 - ;; bug#47712: Emacs 28 can compute `string-width' of substrings - (consult--static-if (eq 3 (cdr (func-arity #'string-width))) - (string-width string pos nexti) - (string-width - ;; Avoid allocation for the full string. - (if (and (= pos 0) (= nexti end)) - string - (substring-no-properties string pos nexti))))))) - (setq pos nexti)))))) - width)) - -(defun consult--string-hash (strings) - "Create hashtable from STRINGS." - (let ((ht (make-hash-table :test #'equal :size (length strings)))) - (dolist (str strings) - (puthash str t ht)) - ht)) - -(defmacro consult--local-let (binds &rest body) - "Buffer local let BINDS of dynamic variables in BODY." - (declare (indent 1)) - (let ((buffer (make-symbol "buffer")) - (local (mapcar (lambda (x) (cons (make-symbol "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))))))) - -(defun consult--abbreviate-directory (dir) - "Return abbreviated directory DIR for use in prompts." - (save-match-data - (let ((adir (abbreviate-file-name dir))) - (if (string-match "/\\([^/]+\\)/\\([^/]+\\)/\\'" adir) - (format "…/%s/%s/" (match-string 1 adir) (match-string 2 adir)) - adir)))) - -(defun consult--directory-prompt-1 (prompt dir) - "Format PROMPT, expand directory DIR and return them as a pair." - (let ((edir (file-name-as-directory (expand-file-name dir))) - (ddir (file-name-as-directory (expand-file-name default-directory)))) - (cons - (if (string= ddir edir) - (concat prompt ": ") - (format "%s (%s): " prompt (consult--abbreviate-directory dir))) - edir))) - -(defun consult--directory-prompt (prompt dir) - "Return prompt and 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. -If DIR is a true value, the user is asked. -Then the `consult-project-root-function' is tried. -Otherwise the `default-directory' is returned." - (cond - ((stringp dir) (consult--directory-prompt-1 prompt dir)) - (dir (consult--directory-prompt-1 - prompt - ;; HACK Preserve this-command across `read-directory-name' call, - ;; such that `consult-customize' continues to work. - ;; TODO Find a better and more general solution which preserves `this-command'. - (let ((this-command this-command)) - (read-directory-name "Directory: " nil nil t)))) - ((when-let (root (consult--project-root)) - (cons (format "%s (Project %s): " prompt (consult--project-name root)) - root))) - (t (consult--directory-prompt-1 prompt default-directory)))) - -(defun consult--project-root () - "Return project root as absolute path." - (when-let (root (and consult-project-root-function (funcall consult-project-root-function))) - (expand-file-name root))) - -(defun consult--project-name (dir) - "Return the project name for DIR." - (if (string-match "/\\([^/]+\\)/\\'" dir) - (match-string 1 dir) - dir)) - -(defun consult--format-location (file line &optional str) - "Format location string 'FILE:LINE:STR'." - (setq line (number-to-string line) - str (concat file ":" line (and str ":") str) - file (length file)) - (put-text-property 0 file 'face 'consult-file str) - (put-text-property (1+ file) (+ 1 file (length line)) 'face 'consult-line-number str) - str) - -(defmacro consult--overlay (beg end &rest props) - "Make consult overlay between BEG and END with PROPS." - (let ((ov (make-symbol "ov")) - (puts)) - (while props - (push `(overlay-put ,ov ,(car props) ,(cadr props)) puts) - (setq props (cddr props))) - `(let ((,ov (make-overlay ,beg ,end))) - ,@puts - ,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--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--lookup-member (_ candidates cand) - "Lookup CAND in CANDIDATES list, return original element." - (car (member cand candidates))) - -(defun consult--lookup-cons (_ candidates cand) - "Lookup CAND in CANDIDATES alist, return cons." - (assoc cand candidates)) - -(defun consult--lookup-cdr (_ candidates cand) - "Lookup CAND in CANDIDATES alist, return cdr of element." - (cdr (assoc cand candidates))) - -(defun consult--lookup-location (_ candidates cand) - "Lookup CAND in CANDIDATES list of 'consult-location category, return the marker." - (when-let (found (member cand candidates)) - (car (get-text-property 0 'consult-location (car found))))) - -(defun consult--lookup-candidate (_ candidates cand) - "Lookup CAND in CANDIDATES list and return property 'consult--candidate." - (when-let (found (member cand candidates)) - (get-text-property 0 'consult--candidate (car found)))) - -(defun consult--forbid-minibuffer () - "Raise an error if executed from the minibuffer." - (when (minibufferp) - (user-error "`%s' called inside the minibuffer" this-command))) - -(defun consult--require-minibuffer () - "Raise an error if executed outside the minibuffer." - (unless (minibufferp) - (user-error "`%s' must be called inside the minibuffer" this-command))) - -(defun consult--fontify-all () - "Ensure that the whole buffer is fontified." - ;; Font-locking is lazy, i.e., if a line has not been looked at yet, the line - ;; is not font-locked. We would observe this if consulting an unfontified - ;; line. Therefore we have to enforce font-locking now, which is slow. In - ;; order to prevent is hang-up we check the buffer size against - ;; `consult-fontify-max-size'. - (when (and consult-fontify-preserve jit-lock-mode - (< (buffer-size) consult-fontify-max-size)) - (jit-lock-fontify-now))) - -(defun consult--fontify-region (start end) - "Ensure that region between START and END is fontified." - (when (and consult-fontify-preserve jit-lock-mode) - (jit-lock-fontify-now start end))) - -(defmacro consult--with-increased-gc (&rest body) - "Temporarily increase the gc limit in BODY to optimize for throughput." - (let ((overwrite (make-symbol "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))) - -(defun consult--count-lines (pos) - "Move to position POS and return number of lines." - (let ((line 0)) - (while (< (point) pos) - (forward-line) - (when (<= (point) pos) - (setq line (1+ line)))) - (goto-char pos) - line)) - -(defun consult--position-marker (buffer line column) - "Get marker in BUFFER from LINE and COLUMN." - (when (buffer-live-p buffer) - (with-current-buffer buffer - (save-restriction - (save-excursion - (widen) - (goto-char (point-min)) - ;; Location data might be invalid by now! - (ignore-errors - (forward-line (1- line)) - (forward-char column)) - (point-marker)))))) - -(defun consult--line-group (cand transform) - "Group function used by `consult-line-all' and `consult-line-project'. -If TRANSFORM non-nil, return transformed CAND, otherwise return title." - (if transform - cand - (buffer-name - (marker-buffer - (car (get-text-property 0 'consult-location cand)))))) - -(defun consult--line-prefix (&optional curr-line) - "Annotate `consult-location' candidates with line numbers given the current line -CURR-LINE." - (setq curr-line (or curr-line -1)) - (let* ((width (length (number-to-string (line-number-at-pos - (point-max) - consult-line-numbers-widen)))) - (fmt-before (propertize (format "%%%dd " width) 'face 'consult-line-number-wrapped)) - (fmt-after (propertize (format "%%%dd " width) 'face 'consult-line-number-prefix))) - (lambda (cand) - (let ((line (cdr (get-text-property 0 'consult-location cand)))) - (list cand (format (if (< line curr-line) fmt-before fmt-after) line) ""))))) - -(defun consult--location-candidate (cand marker line &rest props) - "Add MARKER and LINE as 'consult-location text property to CAND. -Furthermore add the additional text properties PROPS, and append -tofu-encoded MARKER suffix for disambiguation." - (setq cand (concat cand (consult--tofu-encode marker))) - (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 - (progn - (when fontify - (consult--fontify-region beg end)) - (buffer-substring beg end)) - (buffer-substring-no-properties beg end))) - -(defun consult--region-with-cursor (beg end marker) - "Return region string with a marking at the cursor position. - -BEG is the begin position. -END is the end position. -MARKER is the cursor position." - (let ((str (consult--buffer-substring beg end 'fontify))) - (if (>= marker end) - (concat str #(" " 0 1 (face consult-preview-cursor))) - (put-text-property (- marker beg) (- (1+ marker) beg) - 'face 'consult-preview-cursor str) - str))) - -(defun consult--line-with-cursor (marker) - "Return current line where the cursor MARKER is highlighted." - (consult--region-with-cursor (line-beginning-position) (line-end-position) marker)) - -;;;; Preview support - -(defun consult--kill-clean-buffer (buf) - "Kill BUF if it has not been modified." - (unless (buffer-modified-p buf) - (kill-buffer buf))) - -(defun consult--temporary-files () - "Return a function to open files temporarily." - (let* ((new-buffers) - (dir default-directory)) - (lambda (&optional name) - (if name - (let ((default-directory dir)) - (or (get-file-buffer name) - ;; file-attributes may throw permission denied error - (when-let* ((attrs (ignore-errors (file-attributes name))) - (size (file-attribute-size attrs))) - (if (> size consult-preview-max-size) - (prog1 nil - (message "File `%s' (%s) is too large for preview" - name (file-size-human-readable size))) - (cl-letf* (((default-value 'find-file-hook) - (seq-remove (lambda (x) (memq x consult-preview-excluded-hooks)) - (default-value 'find-file-hook))) - (inhibit-message t) - (non-essential t) - (enable-dir-local-variables nil) - (enable-local-variables (and enable-local-variables :safe)) - (buf (find-file-noselect - name 'nowarn - (> size consult-preview-raw-size)))) - (push buf new-buffers) - ;; Only keep a few buffers alive - (while (> (length new-buffers) consult-preview-max-count) - (consult--kill-clean-buffer (car (last new-buffers))) - (setq new-buffers (nbutlast new-buffers))) - buf))))) - (mapc #'consult--kill-clean-buffer new-buffers))))) - -(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 (line-beginning-position) (line-end-position))) - (when-let (fun (overlay-get ov 'isearch-open-invisible)) - (when (invisible-p (overlay-get ov 'invisible)) - (funcall fun ov))))) - -(defun consult--invisible-open-temporarily () - "Temporarily open overlays which hide the current line. -See `isearch-open-necessary-overlays' and `isearch-open-overlay-temporary'." - (let ((restore)) - (dolist (ov (overlays-in (line-beginning-position) (line-end-position)) restore) - (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 nil) - (lambda () (funcall fun t))) - (overlay-put ov 'invisible nil) - (lambda () (overlay-put ov 'invisible inv))) - restore)))))) - -(defun consult--jump-nomark (pos) - "Go to POS and recenter." - (cond - ((and (markerp pos) (not (marker-buffer pos))) - ;; Only print a message, no error in order to not mess - ;; with the minibuffer update hook. - (message "Buffer is dead")) - (t - ;; Switch to buffer if it is not visible - (when (and (markerp pos) (not (eq (current-buffer) (marker-buffer pos)))) - (consult--buffer-action (marker-buffer pos) 'norecord)) - ;; Widen if we cannot jump to the position (idea from flycheck-jump-to-error) - (unless (= (goto-char pos) (point)) - (widen) - (goto-char pos)) - (run-hooks 'consult-after-jump-hook)))) - -(defun consult--jump (pos) - "Push current position to mark ring, go to POS and recenter." - (when pos - ;; When the marker is in the same buffer, - ;; record previous location such that the user can jump back quickly. - (unless (and (markerp pos) (not (eq (current-buffer) (marker-buffer pos)))) - (push-mark (point) t)) - (consult--jump-nomark pos) - (consult--invisible-open-permanently)) - nil) - -;; Matched strings are not highlighted as of now. -;; see https://github.com/minad/consult/issues/7 -(defun consult--jump-preview (&optional face) - "The preview function used if selecting from a list of candidate positions. -The function can be used as the `:state' argument of `consult--read'. -FACE is the cursor face." - (let ((overlays) - (invisible) - (face (or face 'consult-preview-cursor)) - (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 - (lambda (cand restore) - (mapc #'funcall invisible) - (mapc #'delete-overlay overlays) - (setq invisible nil overlays nil) - (cond - (restore - (let ((saved-buffer (marker-buffer saved-pos))) - (if (not saved-buffer) - (message "Buffer is dead") - (set-buffer saved-buffer) - (narrow-to-region saved-min saved-max) - (goto-char saved-pos)))) - ;; Jump to position - (cand - (consult--jump-nomark cand) - (setq invisible (consult--invisible-open-temporarily) - overlays - (list (save-excursion - (let ((vbeg (progn (beginning-of-visual-line) (point))) - (vend (progn (end-of-visual-line) (point))) - (end (line-end-position))) - (consult--overlay vbeg (if (= vend end) (1+ end) vend) - 'face 'consult-preview-line - 'window (selected-window)))) - (consult--overlay (point) (1+ (point)) - 'face face - 'window (selected-window))))) - ;; If position cannot be previewed, return to saved position - (t (consult--jump-nomark saved-pos)))))) - -(defun consult--jump-state (&optional face) - "The state function used if selecting from a list of candidate positions. -The function can be used as the `:state' argument of `consult--read'. -FACE is the cursor face." - (let ((preview (consult--jump-preview face))) - (lambda (cand restore) - (funcall preview cand restore) - (when (and cand restore) - (consult--jump cand))))) - -(defmacro consult--define-state (type) - "Define state function for TYPE." - `(defun ,(intern (format "consult--%s-state" type)) () - (let ((preview (,(intern (format "consult--%s-preview" type))))) - (lambda (cand restore) - (funcall preview cand restore) - (when (and cand restore) - (,(intern (format "consult--%s-action" type)) cand)))))) - -(defun consult--preview-key-normalize (preview-key) - "Normalize PREVIEW-KEY, return alist of keys and debounce times." - (let ((keys) - (debounce 0)) - (setq preview-key (consult--to-list preview-key)) - (while preview-key - (if (eq (car preview-key) :debounce) - (setq debounce (cadr preview-key) - preview-key (cddr preview-key)) - (push (cons (car preview-key) debounce) keys) - (pop preview-key))) - keys)) - -(defun consult--preview-key-pressed-p (preview-key cand) - "Return t if PREVIEW-KEY has been pressed given the current candidate CAND." - (when (and (consp preview-key) (memq :keys preview-key)) - (setq preview-key (funcall (plist-get preview-key :predicate) cand))) - (setq preview-key (consult--preview-key-normalize preview-key)) - (let ((keys (this-single-command-keys))) - (cdr (or (seq-find (lambda (x) - (and (not (eq (car x) 'any)) - (equal (vconcat (car x)) keys))) - preview-key) - (assq 'any preview-key))))) - -(defun consult--with-preview-1 (preview-key state transform candidate fun) - "Add preview support for FUN. - -See `consult--with-preview' for the arguments PREVIEW-KEY, STATE, TRANSFORM -and CANDIDATE." - (let ((input "") (selected) (timer)) - (consult--minibuffer-with-setup-hook - (if (and state preview-key) - (lambda () - (setq consult--preview-function - (let ((last-preview)) - (lambda () - (when-let (cand (funcall candidate)) - (with-selected-window (active-minibuffer-window) - (let ((input (minibuffer-contents-no-properties))) - (with-selected-window (or (minibuffer-selected-window) (next-window)) - (let ((transformed (funcall transform input cand)) - (new-preview (cons input cand))) - (when-let (debounce (consult--preview-key-pressed-p preview-key transformed)) - (when timer - (cancel-timer timer) - (setq timer nil)) - (unless (equal last-preview new-preview) - (if (> debounce 0) - (let ((win (selected-window))) - (setq timer - (run-at-time - debounce - nil - (lambda () - (when (window-live-p win) - (with-selected-window win - (funcall state transformed nil) - (setq last-preview new-preview))))))) - (funcall state transformed nil) - (setq last-preview new-preview)))))))))))) - ;; symbol indirection because of bug#46407 - (let ((post-command-sym (make-symbol "consult--preview-post-command"))) - (fset post-command-sym (lambda () - (setq input (minibuffer-contents-no-properties)) - (funcall consult--preview-function))) - (add-hook 'post-command-hook post-command-sym nil 'local))) - (lambda () - ;; symbol indirection because of bug#46407 - (let ((post-command-sym (make-symbol "consult--preview-post-command"))) - (fset post-command-sym (lambda () (setq input (minibuffer-contents-no-properties)))) - (add-hook 'post-command-hook post-command-sym nil 'local)))) - (unwind-protect - (cons (setq selected (when-let (result (funcall fun)) - (funcall transform input result))) - input) - (when timer - (cancel-timer timer)) - ;; If there is a state function, always call restore! - ;; The preview function should be seen as a stateful object, - ;; and we call the destructor here. - (when state - (funcall state selected t)))))) - -(defmacro consult--with-preview (preview-key state transform candidate &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. - -The preview function takes two arguments, the selected candidate and a restore -flag. It is called every time with restore=nil after a preview-key keypress, as -long as a new candidate is selected. Finally the preview function is called in -any case with restore=t even if no preview has actually taken place. The -candidate argument can be nil if the selection has been aborted." - (declare (indent 4)) - `(consult--with-preview-1 ,preview-key ,state ,transform ,candidate (lambda () ,@body))) - -;;;; Narrowing support - -(defun consult--widen-key () - "Return widening key, if `consult-widen-key' is not set, defaults to twice -`consult-narrow-key'." - (or consult-widen-key (and consult-narrow-key (vconcat consult-narrow-key consult-narrow-key)))) - -(defun consult-narrow (key) - "Narrow current completion with KEY. - -This command is used internally by the narrowing system of `consult--read'." - (interactive - (list (unless (equal (this-single-command-keys) (consult--widen-key)) - last-command-event))) - (consult--require-minibuffer) - (setq consult--narrow key) - (when consult--narrow-predicate - (setq minibuffer-completion-predicate (and consult--narrow consult--narrow-predicate))) - (when consult--narrow-overlay - (delete-overlay consult--narrow-overlay)) - (when consult--narrow - (setq consult--narrow-overlay - (consult--overlay - (1- (minibuffer-prompt-end)) (minibuffer-prompt-end) - 'before-string - (propertize (format " [%s]" (alist-get consult--narrow - consult--narrow-keys)) - 'face 'consult-narrow-indicator)))) - (run-hooks 'consult--completion-refresh-hook)) - -(defconst consult--narrow-delete - `(menu-item - "" nil :filter - ,(lambda (&optional _) - (when (string= (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 (pair (or (and (= 1 (length str)) - (assoc (aref str 0) consult--narrow-keys)) - (and (string= str "") - (assoc 32 consult--narrow-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." - (interactive) - (consult--require-minibuffer) - (let ((minibuffer-message-timeout 1000000)) - (minibuffer-message - (mapconcat - (lambda (x) (concat - (propertize (char-to-string (car x)) 'face 'consult-key) " " - (propertize (cdr x) 'face 'consult-help))) - (seq-filter (lambda (x) (/= (car x) 32)) - consult--narrow-keys) - " ")))) - -(defun consult--narrow-setup (settings map) - "Setup narrowing with SETTINGS and keymap MAP." - (if (memq :keys settings) - (setq consult--narrow-predicate (plist-get settings :predicate) - consult--narrow-keys (plist-get settings :keys)) - (setq consult--narrow-predicate nil - consult--narrow-keys settings)) - (when consult-narrow-key - (dolist (pair consult--narrow-keys) - (define-key map - (vconcat consult-narrow-key (vector (car pair))) - (cons (cdr pair) #'consult-narrow)))) - (when-let (widen (consult--widen-key)) - (define-key map widen (cons "All" #'consult-narrow)))) - -;; Emacs 28: hide in M-X -(put #'consult-narrow-help 'completion-predicate #'ignore) -(put #'consult-narrow 'completion-predicate #'ignore) - -;;;; Splitting completion style - -(defun consult--split-perl (str point) - "Split input STR in async input and filtering part. - -The function returns a list with four elements: The async string, the -completion filter string, the new point position computed from POINT 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) - `(,(match-string 1 str) - ,(substring str (match-end 0)) - ,(max 0 (- point (match-end 0))) - ;; Force update it two punctuation characters are entered. - ,(match-end 2) - ;; List of highlights - (0 . ,(match-beginning 1)) - ,@(and (match-end 2) `((,(match-beginning 2) . ,(match-end 2))))))) - `(,str "" 0))) - -(defun consult--split-nil (str _point) - "Treat the complete input STR as async input." - `(,str "" 0)) - -(defun consult--split-separator (sep str point) - "Split input STR in async input and filtering part at the first separator SEP. -POINT is the point position." - (setq sep (regexp-quote (char-to-string sep))) - (save-match-data - (if (string-match (format "^\\([^%s]+\\)\\(%s\\)?" sep sep) str) - `(,(match-string 1 str) - ,(substring str (match-end 0)) - ,(max 0 (- point (match-end 0))) - ;; Force update it space is entered. - ,(match-end 2) - ;; List of highlights - (0 . ,(match-end 1))) - `(,str "" 0)))) - -(defun consult--split-setup (split) - "Setup splitting completion style with splitter function SPLIT." - (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) - (parts (funcall split str point))) - (completion-try-completion (cadr parts) table pred (caddr parts))))) - (all (lambda (str table pred point) - (let ((completion-styles styles) - (completion-category-defaults catdef) - (completion-category-overrides catovr) - (parts (funcall split str point))) - (completion-all-completions (cadr parts) table pred (caddr parts)))))) - (setq-local completion-styles-alist (cons `(consult--split ,try ,all "") - completion-styles-alist)) - (setq-local completion-styles '(consult--split)) - (setq-local completion-category-defaults nil) - (setq-local completion-category-overrides nil))) - -;;;; Async support - -(defmacro consult--with-async (bind &rest body) - "Setup asynchronous completion in BODY. - -BIND is the asynchronous function binding." - (declare (indent 1)) - (let ((async (car bind))) - `(let ((,async ,@(cdr bind)) (orig-chunk)) - (consult--minibuffer-with-setup-hook - (lambda () - (when (functionp ,async) - (setq orig-chunk read-process-output-max - read-process-output-max (max read-process-output-max consult--process-chunk)) - (funcall ,async 'setup) - ;; Push input string to request refresh. - ;; We use a symbol in order to avoid adding lambdas to the hook variable. - ;; Symbol indirection because of bug#46407. - (let ((sym (make-symbol "consult--async-after-change"))) - (fset sym (lambda (&rest _) (funcall ,async (minibuffer-contents-no-properties)))) - (run-at-time 0 nil sym) - (add-hook 'after-change-functions sym nil 'local)))) - (let ((,async (if (functionp ,async) ,async (lambda (_) ,async)))) - (unwind-protect - ,(macroexp-progn body) - (funcall ,async 'destroy) - (when orig-chunk - (setq read-process-output-max orig-chunk)))))))) - -(defun consult--async-sink () - "Create ASYNC sink function. - -An async function must accept a single action argument. 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. - -'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. -nil Return the list of candidates. -list Append the list to the already existing candidates list and return it. -string Update with the current user input string. Return nil." - (let (candidates last buffer previewed) - (lambda (action) - (pcase-exhaustive action - ('setup - (setq buffer (current-buffer)) - nil) - ((or (pred stringp) 'destroy) nil) - ('flush (setq candidates nil last nil previewed 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 tables and - ;; preview: We have to trigger preview immediately when - ;; candidates arrive (Issue #436). - (when (and consult--preview-function candidates (not previewed)) - (setq previewed t) - (funcall consult--preview-function))))) - nil) - ('nil candidates) - ((pred consp) - (setq last (last (if last (setcdr last action) (setq candidates action)))) - candidates))))) - -(defun consult--async-split-style () - "Return the async splitting style function and initial string." - (or (alist-get consult-async-split-style consult-async-split-styles-alist) - (user-error "Splitting style `%s' not found" consult-async-split-style))) - -(defun consult--async-split-initial (initial) - "Return initial string for async command. -INITIAL is the additional initial string." - (concat (plist-get (consult--async-split-style) :initial) initial)) - -(defun consult--async-split-thingatpt (thing) - "Return THING at point with async initial prefix." - (when-let (str (thing-at-point thing)) - (consult--async-split-initial str))) - -(defun consult--async-split (async &optional split) - "Create async function, which splits the input string. -ASYNC is the async sink. -SPLIT is the splitting function." - (unless split - (let ((style (consult--async-split-style))) - (setq split (pcase (plist-get style :type) - ('separator (apply-partially #'consult--split-separator - (plist-get style :separator))) - ('perl #'consult--split-perl) - ('nil #'consult--split-nil) - (type (user-error "Invalid style type `%s'" type)))))) - (lambda (action) - (pcase action - ('setup - (consult--split-setup split) - (funcall async 'setup)) - ((pred stringp) - (pcase-let* ((`(,async-str ,_ ,_ ,force . ,highlights) - (funcall split action 0)) - (async-len (length async-str)) - (input-len (length action)) - (end (minibuffer-prompt-end))) - ;; Highlight punctuation characters - (remove-list-of-text-properties end (+ end input-len) '(face)) - (dolist (hl highlights) - (put-text-property (+ end (car hl)) (+ end (cdr hl)) - 'face 'consult-async-split)) - (funcall async - ;; Pass through if the input is long enough! - (if (or force (>= async-len consult-async-min-input)) - async-str - ;; Pretend that there is no input - "")))) - (_ (funcall async 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--process-indicator (event) - "Return the process indicator character for EVENT." - (cond - ((string-prefix-p "killed" event) - #(";" 0 1 (face consult-async-failed))) - ((string-prefix-p "finished" event) - #(":" 0 1 (face consult-async-finished))) - (t - #("!" 0 1 (face consult-async-failed))))) - -(defun consult--async-process (async cmd &rest props) - "Create process source async function. - -ASYNC is the async function which receives the candidates. -CMD is the command line builder function. -PROPS are optional properties passed to `make-process'." - (let ((proc) (last-args) (indicator) (count)) - (lambda (action) - (pcase action - ("" ;; If no input is provided kill current process - (when proc - (delete-process proc) - (setq proc nil)) - (setq last-args nil)) - ((pred stringp) - (funcall async action) - (let* ((args (funcall cmd action)) - (stderr-buffer (generate-new-buffer " *consult-async-stderr*")) - (flush t) - (rest "") - (proc-filter - (lambda (_ out) - (when flush - (setq flush nil) - (funcall async '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 async lines)))))) - (proc-sentinel - (lambda (_ event) - (when flush - (setq flush nil) - (funcall async 'flush)) - (overlay-put indicator 'display (consult--process-indicator event)) - (when (and (string-prefix-p "finished" event) (not (string= rest ""))) - (setq count (+ count 1)) - (funcall async (list rest))) - (consult--async-log - "consult--async-process sentinel: event=%s lines=%d\n" - (string-trim event) count) - (with-current-buffer (get-buffer-create consult--async-log) - (goto-char (point-max)) - (insert ">>>>> stderr >>>>>\n") - (insert-buffer-substring stderr-buffer) - (insert "<<<<< stderr <<<<<\n") - (kill-buffer stderr-buffer))))) - (unless (equal args last-args) - (setq last-args args) - (when proc - (delete-process proc) - (setq proc nil)) - (when args - (overlay-put indicator 'display #("*" 0 1 (face consult-async-running))) - (consult--async-log "consult--async-process started %S\n" args) - (setq count 0 - proc (apply #'make-process - `(,@props - :connection-type pipe - :name ,(car args) - ;;; XXX tramp bug, the stderr buffer must be empty - :stderr ,stderr-buffer - :noquery t - :command ,args - :filter ,proc-filter - :sentinel ,proc-sentinel)))))) - nil) - ('destroy - (when proc - (delete-process proc) - (setq proc nil)) - (delete-overlay indicator) - (funcall async 'destroy)) - ('setup - (setq indicator (make-overlay (- (minibuffer-prompt-end) 2) - (- (minibuffer-prompt-end) 1))) - (funcall async 'setup)) - (_ (funcall async action)))))) - -(defun consult--async-highlight (async builder) - "Return ASYNC function which highlightes the candidates. -BUILDER is the command line builder." - (let ((highlight)) - (lambda (action) - (cond - ((stringp action) - (setq highlight (plist-get (funcall builder action) :highlight)) - (funcall async action)) - ((and (consp action) highlight) - (dolist (str action) - (funcall highlight str)) - (funcall async action)) - (t (funcall async action)))))) - -(defun consult--async-throttle (async &optional throttle debounce) - "Create async function from ASYNC 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)) - (let ((input "") (last) (timer)) - (lambda (action) - (pcase action - ((pred stringp) - (unless (string= action input) - (when timer - (cancel-timer timer) - (setq timer nil)) - (funcall async "") ;; cancel running process - (setq input action) - (unless (string= action "") - (setq timer - (run-at-time - (+ debounce - (if last - (min (- (float-time) last) throttle) - 0)) - nil - (lambda () - (setq last (float-time)) - (funcall async action)))))) - nil) - ('destroy - (when timer (cancel-timer timer)) - (funcall async 'destroy)) - (_ (funcall async action)))))) - -(defun consult--async-refresh-immediate (async) - "Create async function from ASYNC, which refreshes the display. - -The refresh happens immediately when candidates are pushed." - (lambda (action) - (pcase action - ((or (pred consp) 'flush) - (prog1 (funcall async action) - (funcall async 'refresh))) - (_ (funcall async action))))) - -(defun consult--async-refresh-timer (async &optional delay) - "Create async function from ASYNC, which refreshes the display. - -The refresh happens after a DELAY, defaulting to `consult-async-refresh-delay'." - (let ((timer) (refresh) (delay (or delay consult-async-refresh-delay))) - (lambda (action) - (prog1 (funcall async action) - (pcase action - ((or (pred consp) 'flush) - (setq refresh t) - (unless timer - (setq timer (run-at-time - nil delay - (lambda () - (when refresh - (setq refresh nil) - (funcall async 'refresh))))))) - ('destroy (when timer (cancel-timer timer)))))))) - -(defmacro consult--async-transform (async &rest transform) - "Use FUN to TRANSFORM candidates of ASYNC." - (let ((async-var (make-symbol "async")) - (action-var (make-symbol "action"))) - `(let ((,async-var ,async)) - (lambda (,action-var) - (funcall ,async-var (if (consp ,action-var) (,@transform ,action-var) ,action-var)))))) - -(defun consult--async-map (async fun) - "Map candidates of ASYNC by FUN." - (consult--async-transform async mapcar fun)) - -(defun consult--async-filter (async fun) - "Filter candidates of ASYNC by FUN." - (consult--async-transform async seq-filter fun)) - -(defun consult--to-list (list) - "Ensure that LIST is a list." - (if (listp list) list (list list))) - -(defun consult--command-builder (builder) - "Return command line builder given CMD. -BUILDER is the command line builder function." - (lambda (input) - (setq input (funcall builder input)) - (if (stringp (car input)) - input - (plist-get input :command)))) - -(defmacro consult--async-command (builder &rest args) - "Asynchronous command pipeline. -ARGS is a list of `make-process' properties and transforms. BUILDER is the -command line builder function, which takes the input string and must either -return a list of command line arguments or a plist with the command line -argument list :command and a highlighting function :highlight." - (declare (indent 1)) - `(thread-first (consult--async-sink) - (consult--async-refresh-timer) - ,@(seq-take-while (lambda (x) (not (keywordp x))) args) - (consult--async-process - (consult--command-builder ,builder) - ,@(seq-drop-while (lambda (x) (not (keywordp x))) args)) - (consult--async-throttle) - (consult--async-split))) - -;;;; Special keymaps - -(defvar consult-async-map - (let ((map (make-sparse-keymap))) - ;; Async keys overwriting some unusable defaults for the default completion - (define-key map [remap minibuffer-complete-word] #'self-insert-command) - (define-key map [remap minibuffer-complete] #'minibuffer-completion-help) - map) - "Keymap added for commands with asynchronous candidates.") - -(defvar consult-crm-map (make-sparse-keymap) - "Keymap added by `consult-completing-read-multiple'.") - -(defvar consult-preview-map (make-sparse-keymap) - "Keymap added for commands with preview.") - -(defvar consult-narrow-map - (let ((map (make-sparse-keymap))) - (define-key map " " consult--narrow-space) - (define-key map "\d" consult--narrow-delete) - map) - "Narrowing keymap which is added to the local minibuffer map. -Note that `consult-narrow-key' and `consult-widen-key' are bound dynamically.") - -;;;; Internal API: consult--read - -(defun consult--add-history (async items) - "Add ITEMS to the minibuffer future history. -ASYNC must be non-nil for async completion functions." - (delete-dups - (append - ;; the defaults are at the beginning of the future history - (consult--to-list minibuffer-default) - ;; then our custom items - (remove "" (remq nil (consult--to-list items))) - ;; Add all the 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))))) - -(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 are the narrow settings. -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) - (and preview-key consult-preview-map) - map)) - old-map)))) - -(defun consult--fry-the-tofus (&rest _) - "Fry the tofus in the minibuffer." - (let* ((min (minibuffer-prompt-end)) - (max (point-max)) - (pos max) - (high (+ consult--tofu-char consult--tofu-range -1))) - (while (and (> pos min) (<= consult--tofu-char (char-before pos) high)) - (setq pos (1- pos))) - (when (< pos max) - (add-text-properties pos max '(invisible t rear-nonsticky t cursor-intangible t))))) - -(defsubst consult--tofu-append (cand id) - "Append tofu-encoded ID to CAND." - (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." - (- (aref cand (1- (length cand))) consult--tofu-char)) - -;; We must disambiguate the lines by adding a prefix such that two lines with -;; the same text can be distinguished. In order to avoid matching the line -;; number, such that the user can search for numbers with `consult-line', we -;; encode the line number as unicode characters in the supplementary private use -;; plane b. By doing that, it is unlikely that accidential matching occurs. -(defun consult--tofu-encode (n) - "Return tofu-encoded number N." - (let ((str "")) - (while (progn - (setq str (concat (char-to-string (+ consult--tofu-char - (% n consult--tofu-range))) - str)) - (and (>= n consult--tofu-range) (setq n (/ n consult--tofu-range))))) - (add-text-properties 0 (length str) '(invisible t consult-strip t) str) - str)) - -(defun consult--read-annotate (fun cand) - "Annotate CAND with annotation function FUN." - (pcase (funcall fun cand) - (`(,_ ,_ ,suffix) suffix) - (ann ann))) - -(defun consult--read-affixate (fun cands) - "Affixate CANDS with annotation function FUN." - (mapcar (lambda (cand) - (let ((ann (funcall fun cand))) - (if (consp ann) - ann - (setq ann (or ann "")) - (list cand "" - ;; The default completion UI adds the `completions-annotations' face - ;; if no other faces are present. - (if (text-property-not-all 0 (length ann) 'face nil ann) - ann - (propertize ann 'face 'completions-annotations)))))) - cands)) - -(cl-defun consult--read-1 (candidates &key - prompt predicate require-match history default - keymap category initial narrow add-history annotate - state preview-key sort lookup group inherit-input-method) - "See `consult--read' for the documentation of the arguments." - (consult--minibuffer-with-setup-hook - (:append (lambda () - (add-hook 'after-change-functions #'consult--fry-the-tofus nil 'local) - (consult--setup-keymap keymap (functionp candidates) narrow preview-key) - (setq-local minibuffer-default-add-function - (apply-partially #'consult--add-history (functionp candidates) add-history)))) - (consult--with-async (async candidates) - ;; NOTE: Do not unnecessarily let-bind the lambdas to avoid - ;; overcapturing in the interpreter. This will make closures and the - ;; lambda string representation larger, which makes debugging much worse. - ;; Fortunately the overcapturing problem does not affect the bytecode - ;; interpreter which does a proper scope analyis. - (let* ((metadata `(metadata - ,@(when category `((category . ,category))) - ,@(when group `((group-function . ,group))) - ,@(when annotate - `((affixation-function - . ,(apply-partially #'consult--read-affixate annotate)) - (annotation-function - . ,(apply-partially #'consult--read-annotate annotate)))) - ,@(unless sort '((cycle-sort-function . identity) - (display-sort-function . identity))))) - (result - (consult--with-preview preview-key state - (lambda (input cand) - (funcall lookup input (funcall async nil) cand)) - (apply-partially #'run-hook-with-args-until-success - 'consult--completion-candidate-hook) - (completing-read prompt - (lambda (str pred action) - (if (eq action 'metadata) - metadata - (complete-with-action action (funcall async nil) str pred))) - predicate require-match initial - (if (symbolp history) history (cadr history)) - default - inherit-input-method)))) - (pcase-exhaustive history - (`(:input ,var) - (set var (cdr (symbol-value var))) - (add-to-history var (cdr result))) - ((pred symbolp))) - (car result))))) - -(cl-defun consult--read (candidates &rest options &key - prompt predicate require-match history default - keymap category initial narrow add-history annotate - state preview-key sort lookup group inherit-input-method) - "Enhanced completing read function selecting from CANDIDATES. - -Keyword OPTIONS: - -PROMPT is the string which is shown as prompt message in the minibuffer. -PREDICATE is a filter function called for each candidate. -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. -SORT should be set to nil if the candidates are already sorted. -LOOKUP is a lookup function passed the input, candidates and candidate string. -ANNOTATE is a function passed a candidate string to return an annotation. -INITIAL is the initial input. -STATE is the state function, see `consult--with-preview'. -GROUP is a completion metadata `group-function'. -PREVIEW-KEY are the preview keys (nil, 'any, a single key or a list of keys). -NARROW is an alist of narrowing prefix strings and description. -KEYMAP is a command-specific keymap. -INHERIT-INPUT-METHOD, if non-nil the minibuffer inherits the input method." - ;; supported types - (cl-assert (or (functionp candidates) ;; async table - (obarrayp candidates) ;; obarray - (hash-table-p candidates) ;; hash table - (not candidates) ;; empty list - (stringp (car candidates)) ;; string list - (and (consp (car candidates)) (stringp (caar candidates))) ;; string alist - (and (consp (car candidates)) (symbolp (caar candidates))))) ;; symbol alist - (ignore prompt predicate require-match history default - keymap category initial narrow add-history annotate - state preview-key sort lookup group inherit-input-method) - (apply #'consult--read-1 candidates - (append - (alist-get this-command consult--read-config) - options - (list :prompt "Select: " - :preview-key consult-preview-key - :sort t - :lookup (lambda (_input _cands x) x))))) - -;;;; Internal API: consult--multi - -(defsubst consult--multi-source (sources cand) - "Lookup source for CAND in SOURCES list." - (aref sources (consult--tofu-get cand))) - -(defun consult--multi-predicate (sources cand) - "Predicate function called for each candidate CAND given SOURCES." - (let* ((src (consult--multi-source sources cand)) - (narrow (plist-get src :narrow)) - (type (or (car-safe narrow) narrow -1))) - (or (eq consult--narrow type) - (not (or consult--narrow (plist-get src :hidden)))))) - -(defun consult--multi-narrow (sources) - "Return narrow list from SOURCES." - (thread-last sources - (mapcar (lambda (src) - (when-let (narrow (plist-get src :narrow)) - (if (consp narrow) - narrow - (when-let (name (plist-get src :name)) - (cons narrow name)))))) - (delq nil) - (delete-dups))) - -(defun consult--multi-annotate (sources align cand) - "Annotate candidate CAND with `consult--multi' type, given SOURCES and ALIGN." - (let* ((src (consult--multi-source sources cand)) - (annotate (plist-get src :annotate)) - (ann (if annotate - (funcall annotate (cdr (get-text-property 0 'consult-multi cand))) - (plist-get src :name)))) - (and ann (concat align ann)))) - -(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-mapcat (lambda (src) - (let ((key (if (plist-member src :preview-key) - (plist-get src :preview-key) - consult-preview-key))) - (consult--to-list key))) - sources)))) - -(defun consult--multi-lookup (sources _ candidates cand) - "Lookup CAND in CANDIDATES given SOURCES." - (if-let (found (member cand candidates)) - (cons (cdr (get-text-property 0 'consult-multi (car found))) - (consult--multi-source sources cand)) - (unless (string-blank-p cand) - (list cand)))) - -(defun consult--multi-candidates (sources) - "Return `consult--multi' candidates from SOURCES." - (let ((def) (idx 0) (max-width 0) (candidates)) - (seq-doseq (src sources) - (let* ((face (and (plist-member src :face) `(face ,(plist-get src :face)))) - (cat (plist-get src :category)) - (items (plist-get src :items)) - (items (if (functionp items) (funcall items) items))) - (when (and (not def) (plist-get src :default) items) - (setq def (consult--tofu-append (car items) idx))) - (dolist (item items) - (let ((cand (consult--tofu-append item idx)) - (width (consult--display-width item))) - (add-text-properties 0 (length item) `(,@face consult-multi (,cat . ,item)) cand) - (when (> width max-width) (setq max-width width)) - (push cand candidates)))) - (setq idx (1+ idx))) - (list def (+ 3 max-width) (nreverse candidates)))) - -(defun consult--multi-enabled-sources (sources) - "Return vector of enabled SOURCES." - (vconcat - (seq-filter (lambda (src) - (if-let (pred (plist-get src :enabled)) - (funcall pred) - t)) - (mapcar (lambda (src) - (if (symbolp src) (symbol-value src) src)) - sources)))) - -(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 (`(,cand . ,src) restore) - ;; Get state function - (let ((selected-fun (cdr (assq src states)))) - (if restore - (progn - ;; If the candidate source changed, destruct first the last source. - (when (and last-fun (not (eq last-fun selected-fun))) - (funcall last-fun nil t)) - ;; Destruct all the sources, except the last and selected source - (dolist (state states) - (let ((fun (cdr state))) - (unless (or (eq fun last-fun) (eq fun selected-fun)) - (funcall fun nil t)))) - ;; Finally destruct the source with the selected candidate - (when selected-fun (funcall selected-fun cand t))) - ;; 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 nil nil)) - (setq last-fun selected-fun) - ;; Call the state function. - (when selected-fun (funcall selected-fun cand nil)))))))) - -(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 function returns the selected candidate in the form (cons candidate -source-value). The sources of the source list can either be symbols of source -variables or source values. Source values must be plists with the following -fields: - -Required source fields: -* :category - Completion category. -* :items - List of strings to select from or function returning list of strings. - -Optional source fields: -* :name - Name of the source, used for narrowing, group titles and annotations. -* :narrow - Narrowing character or (character . string) pair. -* :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 - Action function called with the selected candidate. -* :state - State constructor for the source, must return the state function. -* Other source fields can be added specifically to the use case." - (let* ((sources (consult--multi-enabled-sources sources)) - (candidates (consult--with-increased-gc - (consult--multi-candidates sources))) - (align (propertize - " " 'display - `(space :align-to (+ left ,(cadr candidates))))) - (selected (apply #'consult--read - (caddr candidates) - (append - options - (list - :default (car candidates) - :category 'consult-multi - :predicate (apply-partially #'consult--multi-predicate sources) - :annotate (apply-partially #'consult--multi-annotate sources align) - :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))) - (when-let (action (plist-get (cdr selected) :action)) - (funcall action (car selected))) - 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." - (consult--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)))) - (car (consult--with-preview preview-key state - (lambda (inp _) (funcall transform inp)) (lambda () t) - (read-from-minibuffer prompt initial nil nil history default inherit-input-method))))) - -(cl-defun consult--prompt (&rest options &key prompt history add-history initial default - keymap state preview-key transform inherit-input-method) - "Read from minibuffer. - -Keyword OPTIONS: - -PROMPT is the string to prompt with. -TRANSFORM is a function which is applied to the current input string. -HISTORY is the symbol of the history variable. -INITIAL is initial input. -DEFAULT is the default selected value. -ADD-HISTORY is a list of items to add to the history. -STATE is the state function, see `consult--with-preview'. -PREVIEW-KEY are the preview keys (nil, 'any, a single key or a list of keys). -KEYMAP is a command-specific keymap." - (ignore prompt history add-history initial default - keymap state preview-key transform inherit-input-method) - (apply #'consult--prompt-1 - (append - (alist-get this-command consult--read-config) - options - (list :prompt "Input: " - :preview-key consult-preview-key - :transform #'identity)))) - -;;;; Functions - -;;;;; Function: 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) - ;; XXX Disable preview if anything odd is going on with the markers. Otherwise we get - ;; "Marker points into wrong buffer errors". See - ;; https://github.com/minad/consult/issues/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 (cand restore) - (if restore - (when ov (delete-overlay ov)) - (unless ov (setq ov (consult--overlay start end - 'invisible t - 'window (selected-window)))) - ;; Use `add-face-text-property' on a copy of "cand in order to merge face properties - (setq cand (copy-sequence cand)) - (add-face-text-property 0 (length cand) 'consult-preview-insertion t cand) - ;; Use the `before-string' property since the overlay might be empty. - (overlay-put ov 'before-string cand)))))) - -;;;###autoload -(defun consult-completion-in-region (start end collection &optional predicate) - "Use minibuffer completion as the UI for `completion-at-point'. - -The function is called with 4 arguments: START END COLLECTION PREDICATE. -The arguments and expected return value are as specified for -`completion-in-region'. Use as a value for `completion-in-region-function'. - -The function can be configured via `consult-customize'. - - (consult-customize consult-completion-in-region - :completion-styles (basic) - :cycle-threshold 3) - -These configuration options are supported: - - * :cycle-threshold - Cycling threshold (def: `completion-cycle-threshold') - * :completion-styles - Use completion styles (def: `completion-styles') - * :require-match - Require matches when completing (def: nil) - * :prompt - The prompt string shown in the minibuffer" - (cl-letf* ((config (alist-get #'consult-completion-in-region consult--read-config)) - ;; Overwrite both the local and global value of `completion-styles', such that the - ;; `completing-read' minibuffer sees the overwritten value in any case. This is - ;; necessary if `completion-styles' is buffer-local. - ;; NOTE: The completion-styles will be overwritten for recursive editing sessions! - (cs (or (plist-get config :completion-styles) completion-styles)) - (completion-styles cs) - ((default-value 'completion-styles) cs) - (prompt (or (plist-get config :prompt) "Completion: ")) - (require-match (plist-get config :require-match)) - (preview-key (if (plist-member config :preview-key) - (plist-get config :preview-key) - consult-preview-key)) - (initial (buffer-substring-no-properties start end)) - (metadata (completion-metadata initial collection predicate)) - (threshold (or (plist-get config :cycle-threshold) (completion--cycle-threshold metadata))) - (all (completion-all-completions initial collection predicate (length initial))) - ;; Provide `:annotation-function' if `:company-docsig' is specified - (completion-extra-properties - (if-let (fun (and (not (plist-get completion-extra-properties :annotation-function)) - (plist-get completion-extra-properties :company-docsig))) - `(:annotation-function - ,(lambda (cand) - (concat (propertize " " 'display '(space :align-to center)) - (funcall fun cand))) - ,@completion-extra-properties) - completion-extra-properties))) - ;; error if `threshold' is t or the improper list `all' is too short - (if (and threshold - (or (not (consp (ignore-errors (nthcdr threshold all)))) - (and completion-cycling completion-all-sorted-completions))) - (completion--in-region start end collection predicate) - (let* ((limit (car (completion-boundaries initial collection predicate ""))) - (category (completion-metadata-get metadata 'category)) - (buffer (current-buffer)) - (completion - (cond - ((atom all) nil) - ((and (consp all) (atom (cdr all))) - (concat (substring initial 0 limit) (car all))) - (t (car - (consult--with-preview - preview-key - ;; preview state - (consult--insertion-preview start end) - ;; transformation function - (if (eq category 'file) - (cond - ;; Transform absolute file names - ((file-name-absolute-p initial) - (lambda (_inp cand) - (substitute-in-file-name cand))) - ;; Ensure that ./ prefix is kept for the shell (#356) - ((string-match-p "\\`\\.\\.?/" initial) - (lambda (_inp cand) - (setq cand (file-relative-name (substitute-in-file-name cand))) - (if (string-match-p "\\`\\.\\.?/" cand) cand (concat "./" cand)))) - ;; Simplify relative file names - (t - (lambda (_inp cand) - (file-relative-name (substitute-in-file-name cand))))) - (lambda (_inp cand) cand)) - ;; candidate function - (apply-partially #'run-hook-with-args-until-success - 'consult--completion-candidate-hook) - (let ((enable-recursive-minibuffers t)) - (if (eq category 'file) - ;; We use read-file-name, since many completion UIs make it nicer to - ;; navigate the file system this way; and we insert the initial text - ;; directly into the minibuffer to allow the user's completion - ;; styles to expand it as appropriate (particularly useful for the - ;; partial-completion and initials styles, which allow for very - ;; condensed path specification). - (consult--minibuffer-with-setup-hook - (lambda () (insert initial)) - (read-file-name prompt nil initial require-match nil predicate)) - (completing-read prompt - ;; 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 https://github.com/minad/vertico/issues/61. - (if (functionp collection) - (lambda (&rest args) - (with-current-buffer buffer - (apply collection args))) - collection) - predicate require-match initial))))))))) - (if completion - (progn - (delete-region start end) - (insert (substring-no-properties completion)) - (when-let (exit (plist-get completion-extra-properties :exit-function)) - (funcall exit completion - ;; If completion is finished and cannot be further completed, - ;; return 'finished. Otherwise return 'exact. - (if (eq (try-completion completion collection predicate) t) - 'finished 'exact))) - t) - (message "No completion") - nil))))) - -;;;;; Function: consult-completing-read-multiple - -;;;###autoload -(defun consult-completing-read-multiple (prompt table &optional - pred require-match initial-input - hist def inherit-input-method) - "Enhanced replacement for `completing-read-multiple'. -See `completing-read-multiple' for the documentation of the arguments." - (let* ((orig-items - (funcall - (if-let (prefix (car consult-crm-prefix)) - (apply-partially #'mapcar (lambda (item) (propertize item 'line-prefix prefix))) - #'identity) - (all-completions "" table pred))) - (format-item - (lambda (item) - ;; Restore original candidate in order to preserve formatting - (setq item (propertize (or (car (member item orig-items)) item) - 'consult--crm-selected t - 'line-prefix (cdr consult-crm-prefix))) - (add-face-text-property 0 (length item) 'consult-crm-selected 'append item) - item)) - (separator (or (bound-and-true-p crm-separator) "[ \t]*,[ \t]*")) - (hist-sym (pcase hist - ('nil 'minibuffer-history) - ('t 'consult--crm-history) - (`(,sym . ,_) sym) ;; ignore history position - (_ hist))) - (hist-val (symbol-value hist-sym)) - (selected - (and initial-input - (or - ;; initial-input is multiple items - (string-match-p separator initial-input) - ;; initial-input is a single candidate - (member initial-input orig-items)) - (prog1 - (mapcar format-item - (split-string initial-input separator 'omit-nulls)) - (setq initial-input nil)))) - (consult--crm-history (append (mapcar #'substring-no-properties selected) hist-val)) - (items (append selected - (seq-remove (lambda (x) (member x selected)) - orig-items))) - (orig-md (and (functionp table) (cdr (funcall table "" nil 'metadata)))) - (group-fun (alist-get 'group-function orig-md)) - (sort-fun - (lambda (sort) - (pcase (alist-get sort orig-md) - ('identity `((,sort . identity))) - ((and sort (guard sort)) - `((,sort . ,(lambda (cands) - (setq cands (funcall sort cands)) - (nconc - (seq-filter (lambda (x) (member x selected)) cands) - (seq-remove (lambda (x) (member x selected)) cands))))))))) - (md - `(metadata - (group-function - . ,(lambda (cand transform) - (if (get-text-property 0 'consult--crm-selected cand) - (if transform cand "Selected") - (or (and group-fun (funcall group-fun cand transform)) - (if transform cand "Select multiple"))))) - ,@(funcall sort-fun 'cycle-sort-function) - ,@(funcall sort-fun 'display-sort-function) - ,@(seq-filter (lambda (x) (memq (car x) '(annotation-function - affixation-function - category))) - orig-md))) - (overlay) - (command) - (depth (1+ (recursion-depth))) - (hook (make-symbol "consult--crm-pre-command-hook")) - (wrapper (make-symbol "consult--crm-command-wrapper"))) - (fset wrapper - (lambda () - (interactive) - (pcase (catch 'exit - (call-interactively (setq this-command command)) - 'consult--continue) - ('nil - (with-selected-window (active-minibuffer-window) - (let ((item (minibuffer-contents-no-properties))) - (when (equal item "") - (throw 'exit nil)) - (setq selected (if (member item selected) - ;; Multi selections are not possible. - ;; This is probably no problem, since this is rarely desired. - (delete item selected) - (nconc selected (list (funcall format-item item)))) - consult--crm-history (append (mapcar #'substring-no-properties selected) hist-val) - items (append selected - (seq-remove (lambda (x) (member x selected)) - orig-items))) - (when overlay - (overlay-put overlay 'display - (when selected - (format " (%s selected): " (length selected))))) - (delete-minibuffer-contents) - (run-hook-with-args 'consult--completion-refresh-hook 'reset)))) - ('consult--continue nil) - (other (throw 'exit other))))) - (fset hook (lambda () - (when (and this-command (= depth (recursion-depth))) - (setq command this-command this-command wrapper)))) - (consult--minibuffer-with-setup-hook - (:append - (lambda () - (when-let (pos (string-match-p "\\(?: (default[^)]+)\\)?: \\'" prompt)) - (setq overlay (make-overlay (+ (point-min) pos) (+ (point-min) (length prompt)))) - (when selected - (overlay-put overlay 'display (format " (%s selected): " (length selected))))) - (use-local-map (make-composed-keymap (list consult-crm-map) (current-local-map))))) - (unwind-protect - (progn - (add-hook 'pre-command-hook hook 90) - (let ((result - (completing-read - prompt - (lambda (str pred action) - (if (eq action 'metadata) - md - (complete-with-action action items str pred))) - nil ;; predicate - require-match - initial-input - 'consult--crm-history - "" ;; default - inherit-input-method))) - (unless (or (equal result "") selected) - (setq selected (split-string (substring-no-properties result) separator 'omit-nulls) - consult--crm-history (append selected hist-val))))) - (remove-hook 'pre-command-hook hook))) - (set hist-sym consult--crm-history) - (when (consp def) - (setq def (car def))) - (if (and def (not (equal "" def)) (not selected)) - (split-string def separator 'omit-nulls) - (mapcar #'substring-no-properties selected)))) - -;;;; Commands - -;;;;; Command: consult-multi-occur - -;; see https://github.com/raxod502/selectrum/issues/226 -;;;###autoload -(defun consult-multi-occur (bufs regexp &optional nlines) - "Improved version of `multi-occur' based on `completing-read-multiple'. - -See `multi-occur' for the meaning of the arguments BUFS, REGEXP and NLINES." - (interactive (cons - (mapcar #'get-buffer - (completing-read-multiple "Buffer: " - #'internal-complete-buffer)) - (occur-read-primary-args))) - (occur-1 regexp nlines bufs)) - -;;;;; Command: consult-outline - -(defun consult--outline-candidates () - "Return alist of outline headings and positions." - (consult--forbid-minibuffer) - (let* ((line (line-number-at-pos (point-min) consult-line-numbers-widen)) - (heading-regexp (concat "^\\(?:" - ;; default definition from outline.el - (or (bound-and-true-p outline-regexp) "[*\^L]+") - "\\)")) - (heading-alist (bound-and-true-p outline-heading-alist)) - (level-fun (or (bound-and-true-p outline-level) - (lambda () ;; as in the default from outline.el - (or (cdr (assoc (match-string 0) heading-alist)) - (- (match-end 0) (match-beginning 0)))))) - (candidates)) - (save-excursion - (goto-char (point-min)) - (while (save-excursion (re-search-forward heading-regexp nil t)) - (setq line (+ line (consult--count-lines (match-beginning 0)))) - (push (consult--location-candidate - (consult--buffer-substring (line-beginning-position) - (line-end-position) - 'fontify) - (point-marker) line 'consult--outline-level (funcall level-fun)) - candidates) - (unless (eobp) (forward-char 1)))) - (unless candidates - (user-error "No headings")) - (nreverse candidates))) - -;;;###autoload -(defun consult-outline () - "Jump to an outline heading, obtained by matching against `outline-regexp'. - -This command supports narrowing to a heading level and candidate preview. -The symbol at point is added to the future history." - (interactive) - (let* ((cands (consult--with-increased-gc (consult--outline-candidates))) - (min-level (- (apply #'min (mapcar - (lambda (cand) - (get-text-property 0 'consult--outline-level cand)) - cands)) - ?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)))) - (consult--read - cands - :prompt "Go to heading: " - :annotate (consult--line-prefix) - :category 'consult-location - :sort nil - :require-match t - :lookup #'consult--line-match - :narrow `(:predicate ,narrow-pred :keys ,narrow-keys) - :history '(:input consult--line-history) - :add-history (thing-at-point 'symbol) - :state (consult--jump-state)))) - -;;;;; Command: consult-mark - -(defun consult--mark-candidates (markers) - "Return list of candidates strings for MARKERS." - (consult--forbid-minibuffer) - (let ((candidates) - (current-buf (current-buffer))) - (save-excursion - (dolist (marker markers) - (when-let ((pos (marker-position marker)) - (buf (marker-buffer marker))) - (when (and (eq buf current-buf) - (consult--in-range-p pos)) - (goto-char pos) - ;; `line-number-at-pos' is a very slow function, which should be replaced everywhere. - ;; However in this case the slow line-number-at-pos does not hurt much, since - ;; the mark ring is usually small since it is limited by `mark-ring-max'. - (push (consult--location-candidate - (consult--line-with-cursor marker) marker - (line-number-at-pos pos consult-line-numbers-widen)) - 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--with-increased-gc - (consult--mark-candidates - (or markers (cons (mark-marker) mark-ring)))) - :prompt "Go to mark: " - :annotate (consult--line-prefix) - :category 'consult-location - :sort nil - :require-match t - :lookup #'consult--lookup-location - :history '(:input consult--line-history) - :add-history (thing-at-point 'symbol) - :state (consult--jump-state))) - -;;;;; Command: consult-global-mark - -(defun consult--global-mark-candidates (markers) - "Return list of candidates strings for MARKERS." - (consult--forbid-minibuffer) - (let ((candidates)) - (save-excursion - (dolist (marker markers) - (when-let ((pos (marker-position marker)) - (buf (marker-buffer marker))) - (unless (minibufferp buf) - (with-current-buffer buf - (when (consult--in-range-p pos) - (goto-char pos) - ;; `line-number-at-pos' is slow, see comment in `consult--mark-candidates'. - (let ((line (line-number-at-pos pos consult-line-numbers-widen))) - (push (concat - (propertize (consult--format-location (buffer-name buf) line "") - 'consult-location (cons marker line) - 'consult-strip t) - (consult--line-with-cursor marker) - (consult--tofu-encode marker)) - 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--with-increased-gc - (consult--global-mark-candidates - (or markers global-mark-ring))) - :prompt "Go to global mark: " - ;; Despite `consult-global-mark' formating the candidates in grep-like - ;; style, we are not using the 'consult-grep category, since the candidates - ;; have location markers attached. - :category 'consult-location - :sort nil - :require-match t - :lookup #'consult--lookup-location - :history '(:input consult--line-history) - :add-history (thing-at-point 'symbol) - :state (consult--jump-state))) - -;;;;; Command: consult-line - -(defun consult--line-candidates (top curr-line) - "Return list of line candidates. -Start from top if TOP non-nil. -CURR-LINE is the current line number." - (consult--forbid-minibuffer) - (consult--fontify-all) - (let* ((default-cand) - (candidates) - (line (line-number-at-pos (point-min) consult-line-numbers-widen))) - (consult--each-line beg end - (let ((str (consult--buffer-substring beg end))) - (unless (string-blank-p str) - (push (consult--location-candidate str (point-marker) line) candidates) - (when (and (not default-cand) (>= line curr-line)) - (setq default-cand candidates))) - (setq line (1+ line)))) - (when candidates - (nreverse - (if (or top (not default-cand)) - candidates - (let ((before (cdr default-cand))) - (setcdr default-cand nil) - (nconc before candidates))))))) - -(defun consult--line-match (input candidates cand) - "Lookup position of match. - -INPUT is the input string entered by the user. -CANDIDATES is the line candidates alist. -CAND is the currently selected candidate." - (when-let (pos (consult--lookup-location input candidates cand)) - (if (or (string-blank-p input) - (eq consult-line-point-placement 'line-beginning)) - pos - (let ((beg 0) - (end (length cand)) - (high (+ consult--tofu-char consult--tofu-range -1))) - ;; Ignore tofu-encoded unique line number suffix - (while (and (> end 0) (<= consult--tofu-char (aref cand (1- end)) high)) - (setq end (1- end))) - ;; Find match end position, remove characters from line end until - ;; matching fails - (let ((step 16)) - (while (> step 0) - (while (and (> (- end step) 0) - ;; Use consult-location completion category when - ;; filtering lines. Highlighting is not necessary here, - ;; but it is actually cheaper to highlight a single - ;; candidate, since setting up deferred highlighting is - ;; costly. - (consult--completion-filter input - (list (substring cand 0 (- end step))) - 'consult-location 'highlight)) - (setq end (- end step))) - (setq step (/ step 2)))) - ;; Find match beginning position, remove characters from line beginning - ;; until matching fails - (when (eq consult-line-point-placement 'match-beginning) - (let ((step 16)) - (while (> step 0) - (while (and (< (+ beg step) end) - ;; See comment above, call to `consult--completion-filter'. - (consult--completion-filter input - (list (substring cand (+ beg step) end)) - 'consult-location 'highlight)) - (setq beg (+ beg step))) - (setq step (/ step 2))) - (setq end beg))) - ;; Marker can be dead, therefore ignore errors. Create a new marker instead of an integer, - ;; since the location may be in another buffer, e.g., for `consult-line-all'. - (ignore-errors - (if (or (not (markerp pos)) (eq (marker-buffer pos) (current-buffer))) - (+ pos end) - ;; Only create a new marker when jumping across buffers, to avoid - ;; creating unnecessary markers, when scrolling through candidates. - ;; Creating markers is not free. - (move-marker - (make-marker) - (+ pos end) - (marker-buffer pos)))))))) - -(cl-defun consult--line (candidates &key curr-line prompt initial group) - "Select from from line CANDIDATES and jump to the match. -CURR-LINE is the current line. See `consult--read' for the arguments PROMPT, -INITIAL and GROUP." - (consult--read - candidates - :prompt prompt - :annotate (consult--line-prefix curr-line) - :group group - :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--jump-state))) - -;;;###autoload -(defun consult-line (&optional initial start) - "Search for a matching line. - -Depending on the setting `consult-line-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)))) - (consult--line - (or (consult--with-increased-gc - (consult--line-candidates top curr-line)) - (user-error "No lines")) - :curr-line (and (not top) curr-line) - :prompt (if top "Go to line from top: " "Go to line: ") - :initial initial))) - -;;;;; Command: consult-line-multi - -(defun consult--line-multi-candidates (buffers) - "Collect the line candidates from multiple buffers. -BUFFERS is the list of buffers." - (or (apply #'nconc - (consult--buffer-map buffers - #'consult--line-candidates 'top most-positive-fixnum)) - (user-error "No lines"))) - -;;;###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. See -`consult-line' for more information. 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 :directory (and (not query) 'project)))) - (let ((buffers (consult--buffer-query-prompt "Go to line" query))) - (consult--line - (consult--line-multi-candidates (cdr buffers)) - :prompt (car buffers) - :initial initial - :group #'consult--line-group))) - -;;;;; Command: consult-keep-lines - -(defun consult--keep-lines-state (filter) - "State function for `consult-keep-lines' with FILTER function." - (let* ((lines) - (buffer-orig (current-buffer)) - (font-lock-orig font-lock-mode) - (hl-line-orig (bound-and-true-p hl-line-mode)) - (point-orig (point)) - (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 content) - (goto-char (or pos rbeg)) - (setq rend (+ rbeg (length content))) - (add-face-text-property rbeg rend 'region t))))) - (consult--fontify-all) - (setq content-orig (buffer-string) - replace (lambda (content &optional pos) - (delete-region (point-min) (point-max)) - (insert content) - (goto-char (or pos (point-min))))) - (consult--each-line beg end - (push (consult--buffer-substring beg end) lines))) - (setq lines (nreverse lines)) - (lambda (input restore) - (with-current-buffer buffer-orig - ;; Restoring content and point position - (when (and restore 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 povided - (or - ;; Committing, but not with empty input - (and restore (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 restore - (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 hl-line-mode) (hl-line-mode -1)) - (if restore - (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 restore - (when hl-line-orig (hl-line-mode 1)) - (when font-lock-orig (font-lock-mode 1))))))) - -;;;###autoload -(defun consult-keep-lines (&optional filter initial) - "Select a subset of the lines in the current buffer with live preview. - -The selected lines are kept and the other lines are deleted. When called -interactively, the lines selected are those that match the minibuffer input. In -order to match the inverse of the input, prefix the input with `! '. When -called from elisp, the filtering is performed by a FILTER function. This -command obeys narrowing. - -FILTER is the filter function. -INITIAL is the initial input." - (interactive - (list (lambda (pattern cands) - ;; Use consult-location completion category when filtering lines - (consult--completion-filter-dispatch - pattern cands 'consult-location 'highlight)))) - (consult--forbid-minibuffer) - (barf-if-buffer-read-only) - (consult--with-increased-gc - (consult--prompt - :prompt "Keep lines: " - :initial initial - :history 'consult--keep-lines-history - :state (consult--keep-lines-state filter)))) - -;;;;; Command: consult-focus-lines - -(defun consult--focus-lines-state (filter) - "State function for `consult-focus-lines' with FILTER function." - (let ((lines) (overlays) (last-input) (point-orig (point))) - (save-excursion - (save-restriction - (if (not (use-region-p)) - (consult--fontify-all) - (consult--fontify-region (region-beginning) (region-end)) - (narrow-to-region - (region-beginning) - ;; Behave the same as `keep-lines'. - ;; Move to the next line. - (save-excursion - (goto-char (region-end)) - (unless (or (bolp) (eobp)) - (forward-line 0)) - (point)))) - (consult--each-line beg end - (push (buffer-substring-no-properties beg end) lines) - (push (make-overlay beg (1+ end)) overlays)))) - (unless (use-region-p) - (goto-char (point-min))) - (lambda (input restore) - ;; New input provided -> Update - (when (and input (not (equal input last-input))) - (if (string-match-p "\\`!? ?\\'" input) - ;; Special case the empty input for performance. - (progn - (dolist (ov overlays) - (overlay-put ov 'invisible nil)) - (setq last-input input)) - (let* ((not (string-prefix-p "! " input)) - (stripped (string-remove-prefix "! " input)) - ;; Heavy computation is interruptible if *not* committing! - (ht (if restore - (consult--string-hash (funcall filter stripped lines)) - (while-no-input - (consult--string-hash (funcall filter stripped lines)))))) - (when (hash-table-p ht) - (let ((ov overlays) (li lines)) - (while ov - (overlay-put (car ov) 'invisible (eq not (gethash (car li) ht))) - (setq li (cdr li) ov (cdr ov)))) - (setq last-input input))))) - (when restore - (cond - ((not input) - (goto-char point-orig)) - ((equal input "") - (consult-focus-lines 'show)) - (t - ;; Sucessfully terminated -> Remember invisible overlays - (dolist (ov overlays) - (if (overlay-get ov 'invisible) - (push ov consult--focus-lines-overlays) - (delete-overlay ov))) - (setq overlays nil))) - ;; Destroy remaining overlays - (mapc #'delete-overlay overlays))))) - -;;;###autoload -(defun consult-focus-lines (&optional show filter initial) - "Hide or show lines using overlays. - -The selected lines are shown and the other lines hidden. When called -interactively, the lines selected are those that match the minibuffer input. In -order to match the inverse of the input, prefix the input with `! '. With -optional prefix argument SHOW reveal the hidden lines. Alternatively the -command can be restarted to reveal the lines. When called from elisp, the -filtering is performed by a FILTER function. This command obeys narrowing. - -FILTER is the filter function. -INITIAL is the initial input." - (interactive - (list current-prefix-arg - (lambda (pattern cands) - ;; Use consult-location completion category when filtering lines - (consult--completion-filter-dispatch - pattern cands 'consult-location nil)))) - (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--keep-lines-history - :state (consult--focus-lines-state filter))))) - -;;;;; Command: consult-goto-line - -(defun consult--goto-line-position (str msg) - "Transform input STR to line number. -Print an error message with MSG function." - (if-let (line (and str - (string-match-p "\\`[[:digit:]]+\\'" str) - (string-to-number str))) - (let ((pos (save-excursion - (save-restriction - (when consult-line-numbers-widen - (widen)) - (goto-char (point-min)) - (forward-line (1- line)) - (point))))) - (if (consult--in-range-p pos) - pos - (funcall msg "Line number out of range.") - nil)) - (when (and str (not (string= 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. - -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: " - :state (let ((preview (consult--jump-preview))) - (lambda (str restore) - (funcall preview - (consult--goto-line-position str #'ignore) - restore)))) - #'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 (cand restore) - (if restore - (progn - (funcall preview nil t) - (funcall open)) - (funcall preview (and cand (funcall open cand)) nil))))) - -(defun consult--file-action (file) - "Open FILE via `consult--buffer-action'." - (consult--buffer-action (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 #'abbreviate-file-name recentf-list) - (user-error "No recent files, `recentf-mode' is %s" - (if recentf-mode "on" "off"))) - :prompt "Find recent file: " - :sort nil - :require-match t - :category 'file - :state (consult--file-preview) - :history 'file-name-history))) - -;;;;; Command: consult-file-externally - -;;;###autoload -(defun consult-file-externally (file) - "Open FILE externally using the default application of the system." - (interactive "fOpen externally: ") - (if (and (eq system-type 'windows-nt) - (fboundp 'w32-shell-execute)) - (w32-shell-execute "open" file) - (call-process (pcase system-type - ('darwin "open") - ('cygwin "cygstart") - (_ "xdg-open")) - nil 0 nil - (expand-file-name file)))) - -;;;;; 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* ((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)) - ;; Emacs 28 has a `read-extended-command-predicate' - (if (bound-and-true-p read-extended-command-predicate) - (funcall read-extended-command-predicate sym buffer) - t)) - (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 'consult--mode-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 a possible interprogram-paste (#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 - nil kill-ring - (consult--read - (consult--remove-dups - (or kill-ring (user-error "Kill ring is empty"))) - :prompt "Yank from kill-ring: " - :history t ;; disable history - :sort nil - :category 'consult-yank - :require-match t - :state - (consult--insertion-preview - (point) - ;; If previous command is yank, hide previously yanked string - (or (and (eq last-command 'yank) (mark t)) (point)))))) - -;; 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' in Emacs 28, 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 (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' in Emacs 28, 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. - -There exists no equivalent of this command in Emacs 28." - (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 (cand restore) - (if restore - (progn - (funcall open) - (funcall preview nil t)) - (funcall - preview - (when-let (bm (and cand (assoc cand bookmark-alist))) - (let ((handler (or (bookmark-get-handler bm) #'bookmark-default-handler))) - ;; Only preview bookmarks with the default handler. - (if-let* ((file (and (eq handler #'bookmark-default-handler) - (bookmark-get-filename bm))) - (pos (bookmark-get-position bm)) - (buf (funcall open file))) - (set-marker (make-marker) pos buf) - (message "No preview for %s" handler) - nil))) - nil))))) - -(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 (mapcar (pcase-lambda (`(,y ,_ ,x)) (cons x y)) - consult-bookmark-narrow))) - (mapcar (lambda (cand) - (propertize (car cand) - 'consult--type - (alist-get - (or (bookmark-get-handler cand) #'bookmark-default-handler) - narrow))) - bookmark-alist))) - -;;;###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 (mapcar (pcase-lambda (`(,x ,y ,_)) (cons x y)) - consult-bookmark-narrow))) - (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-apropos - -;;;###autoload -(defun consult-apropos () - "Select pattern and call `apropos'. - -The default value of the completion is the symbol at point. As a better -alternative, you can run `embark-export' from commands like `M-x' and -`describe-symbol'." - (interactive) - (let ((pattern - (consult--read - obarray - :prompt "Apropos: " - :predicate (lambda (x) (or (fboundp x) (boundp x) (facep x) (symbol-plist x))) - :history 'consult--apropos-history - :category 'symbol - :default (thing-at-point 'symbol)))) - (when (string= pattern "") - (user-error "No pattern given")) - (apropos pattern))) - -;;;;; 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 relevant to the current buffer. - -If the minibuffer is active, returns the minibuffer history, -otherwise the history corresponding to the mode is returned. -There is a special case for `repeat-complex-command', -for which the command history is used." - (cond - ;; 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-:"! - ((eq last-command 'repeat-complex-command) - (mapcar #'prin1-to-string command-history)) - ;; In the minibuffer we use the current minibuffer history, - ;; which can be configured by setting `minibuffer-history-variable'. - ((minibufferp) - (if (eq minibuffer-history-variable t) - (user-error "Minibuffer history is disabled for `%s'" this-command) - (symbol-value minibuffer-history-variable))) ;; (minibuffer-history-value) is Emacs 27 only - ;; Otherwise we use a mode-specific history, see `consult-mode-histories'. - (t (when-let (history - (or (seq-find (lambda (ring) - (and (derived-mode-p (car ring)) - (boundp (cdr ring)))) - consult-mode-histories) - (user-error - "No history configured for `%s', see `consult-mode-histories'" - major-mode))) - (symbol-value (cdr history)))))) - -(declare-function ring-elements "ring") -;; This command has been adopted from https://github.com/oantolin/completing-history/. -;;;###autoload -(defun consult-history (&optional history) - "Insert string from HISTORY of current buffer. - -In order to select from a specific HISTORY, pass the history variable -as argument." - (interactive) - (let ((str (consult--local-let ((enable-recursive-minibuffers t)) - (consult--read - (let ((history (or history (consult--current-history)))) - (or (consult--remove-dups (if (ring-p history) - (ring-elements history) - history)) - (user-error "History is empty"))) - :prompt "History: " - :history t ;; disable history - :category ;; Report command category for M-x history - (and (minibufferp) - (eq minibuffer-history-variable 'extended-command-history) - 'command) - :state - (consult--insertion-preview (point) (point)) - :sort nil)))) - (when (minibufferp) - (delete-minibuffer-contents)) - (insert (substring-no-properties str)))) - -;;;;; Command: consult-isearch-history - -(defun consult-isearch-forward (&optional reverse) - "Continue isearch forward optionally in REVERSE." - (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." - (interactive) - (consult-isearch-forward (not reverse))) - -;; Emacs 28: hide in M-X -(put #'consult-isearch-backward 'completion-predicate #'ignore) -(put #'consult-isearch-forward 'completion-predicate #'ignore) - -(defvar consult-isearch-history-map - (let ((map (make-sparse-keymap))) - (define-key map [remap isearch-forward] #'consult-isearch-forward) - (define-key map [remap isearch-backward] #'consult-isearch-backward) - map) - "Additional keymap used by `consult-isearch-history'.") - -(defun consult--isearch-history-candidates () - "Return isearch history candidates." - ;; NOTE: 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)))) - (cons - (delete-dups - (mapcar - (lambda (cand) - ;; Emacs 27.1 uses settings on the search string, we can use that for narrowing. - (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)) - (if history - (+ 4 (apply #'max (mapcar #'length history))) - 0)))) - -(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) ;; Avoid flicker in echo area - (inhibit-redisplay t) ;; Avoid flicker in mode line - (candidates (consult--isearch-history-candidates)) - (align (propertize " " 'display `(space :align-to (+ left ,(cdr candidates)))))) - (unless isearch-mode (isearch-mode t)) - (with-isearch-suspended - (setq isearch-new-string - (consult--read - (car candidates) - :prompt "I-search: " - :category 'consult-isearch - :history t ;; disable history - :sort nil - :initial isearch-string - :keymap consult-isearch-history-map - :annotate - (lambda (cand) - (concat align (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 (_ candidates str) - (if-let (found (member str candidates)) (substring (car found) 0 -1) str)) - :state - (lambda (cand restore) - (unless restore - (setq isearch-string cand) - ;; Emacs 27.1 uses properties on the search string to store settings - (when (fboundp 'isearch-update-from-string-properties) - (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)))) - -(define-obsolete-function-alias - 'consult-isearch - 'consult-isearch-history - "0.12") - -;;;;; 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 - (lsh (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))) - (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) - (= (lsh 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 ((avail-themes (seq-filter (lambda (x) (or (not consult-themes) - (memq x consult-themes))) - (cons nil (custom-available-themes)))) - (saved-theme (car custom-enabled-themes))) - (consult--read - (mapcar (lambda (x) (if x (symbol-name x) "default")) avail-themes) - :prompt "Theme: " - :require-match t - :category 'theme - :history 'consult--theme-history - :lookup (lambda (_input _cands x) - (unless (equal x "default") - (or (when-let (cand (and x (intern-soft x))) - (car (memq cand avail-themes))) - saved-theme))) - :state (lambda (cand restore) - (consult-theme (if (and restore (not cand)) - saved-theme - cand))) - :default (symbol-name (or saved-theme 'default)))))) - (unless (eq theme (car custom-enabled-themes)) - (mapc #'disable-theme custom-enabled-themes) - (when theme - (if (custom-theme-p theme) - (enable-theme theme) - (load-theme theme :no-confirm))))) - -;;;;; Command: consult-buffer - -(defun consult--buffer-sort-alpha (buffers) - "Sort BUFFERS alphabetically, but push down starred buffers." - (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-visibility (buffers) - "Sort BUFFERS by visibility." - (let ((hidden) - (current (current-buffer))) - (consult--keep! buffers - (unless (eq it current) - (if (get-buffer-window it 'visible) - it - (push it hidden) - nil))) - (nconc (nreverse hidden) buffers (list (current-buffer))))) - -(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) - "Buffer query function returning a scope description. -PROMPT is the prompt format string. -QUERY 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--abbreviate-directory ndir))) - (t ""))) - buffers))) - -(cl-defun consult--buffer-query (&key sort directory mode as predicate (filter t) - include (exclude consult-buffer-filter)) - "Buffer query function. -DIRECTORY can either be project or a path. -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. -AS is a conversion function." - ;; This function is the backbone of most `consult-buffer' source. The - ;; function supports filtering by various criteria which are used throughout - ;; Consult. - (when-let (root (or (consult--normalize-directory directory) t)) - (let ((buffers (buffer-list))) - (when sort - (setq buffers (funcall (intern (format "consult--buffer-sort-%s" sort)) buffers))) - (when (or filter mode as (stringp root)) - (let ((mode (consult--to-list mode)) - (exclude-re (consult--regexp-filter exclude)) - (include-re (consult--regexp-filter include))) - (consult--keep! buffers - (and - (or (not mode) - (apply #'provided-mode-derived-p - (buffer-local-value 'major-mode it) 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 (stringp root)) - (when-let (dir (buffer-local-value 'default-directory it)) - (string-prefix-p root - (if (and (/= 0 (length dir)) (eq (aref dir 0) ?/)) - dir - (expand-file-name dir))))) - (or (not predicate) (funcall predicate it)) - (if as (funcall as it) it))))) - buffers))) - -(defun consult--buffer-map (buffer &rest app) - "Run function application APP for each BUFFER. -Report progress and return a list of the results" - (consult--with-increased-gc - (let* ((count (length buffer)) - (reporter (make-progress-reporter "Collecting" 0 count))) - (prog1 - (seq-map-indexed (lambda (buf idx) - (with-current-buffer buf - (prog1 (apply app) - (progress-reporter-update - reporter (1+ idx) (buffer-name))))) - buffer) - (progress-reporter-done reporter))))) - -(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-preview () - "Buffer preview function." - (let ((orig-buf (current-buffer))) - (lambda (cand restore) - (when (and (not restore) - ;; Only preview in current window and other window. - ;; Preview in frames and tabs is not possible since these don't get cleaned up. - (or (eq consult--buffer-display #'switch-to-buffer) - (eq consult--buffer-display #'switch-to-buffer-other-window))) - (cond - ((and cand (get-buffer cand)) (consult--buffer-action cand 'norecord)) - ((buffer-live-p orig-buf) (consult--buffer-action orig-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 candidate source for `consult-buffer'.") - -(defvar consult--source-project-buffer - `(:name "Project Buffer" - :narrow (?p . "Project") - :hidden t - :category buffer - :face consult-buffer - :history buffer-name-history - :state ,#'consult--buffer-state - :enabled ,(lambda () consult-project-root-function) - :items - ,(lambda () - (consult--buffer-query :sort 'visibility - :directory 'project - :as #'buffer-name))) - "Project buffer candidate source for `consult-buffer'.") - -(defvar consult--source-project-file - `(:name "Project File" - :narrow (?p . "Project") - :hidden t - :category file - :face consult-file - :history file-name-history - :state ,#'consult--file-state - :enabled ,(lambda () (and consult-project-root-function - recentf-mode)) - :items - ,(lambda () - (when-let (root (consult--project-root)) - (let ((len (length root)) - (inv-root (propertize root 'invisible t)) - (ht (consult--buffer-file-hash))) - (mapcar (lambda (x) - (concat inv-root (substring x len))) - (seq-filter (lambda (x) - (and (not (gethash x ht)) - (string-prefix-p root x))) - recentf-list)))))) - "Project file candidate source for `consult-buffer'.") - -(defvar consult--source-hidden-buffer - `(:name "Hidden Buffer" - :narrow 32 - :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 #'buffer-name))) - "Hidden buffer candidate source for `consult-buffer'.") - -(defvar consult--source-buffer - `(:name "Buffer" - :narrow ?b - :category buffer - :face consult-buffer - :history buffer-name-history - :state ,#'consult--buffer-state - :default t - :items - ,(lambda () (consult--buffer-query :sort 'visibility - :as #'buffer-name))) - "Buffer candidate source for `consult-buffer'.") - -(defvar consult--source-file - `(:name "File" - :narrow ?f - :category file - :face consult-file - :history file-name-history - :state ,#'consult--file-state - :enabled ,(lambda () recentf-mode) - :items - ,(lambda () - (let ((ht (consult--buffer-file-hash))) - (mapcar #'abbreviate-file-name - (seq-remove (lambda (x) (gethash x ht)) recentf-list))))) - "Recent file candidate source for `consult-buffer'.") - -;;;###autoload -(defun consult-buffer () - "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. Furthermore 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-root-function' is used. See `consult-buffer-sources' and -`consult--multi' for the configuration of the virtual buffer sources." - (interactive) - (when-let (buffer (consult--multi consult-buffer-sources - :require-match - (confirm-nonexistent-file-or-buffer) - :prompt "Switch to: " - :history 'consult--buffer-history - :sort nil)) - ;; When the buffer does not belong to a source, - ;; create a new buffer with the name. - (unless (cdr buffer) - (consult--buffer-action (car buffer))))) - -;;;###autoload -(defun consult-buffer-other-window () - "Variant of `consult-buffer' which opens in other window." - (interactive) - (let ((consult--buffer-display #'switch-to-buffer-other-window)) - (consult-buffer))) - -;;;###autoload -(defun consult-buffer-other-frame () - "Variant of `consult-buffer' which opens in other frame." - (interactive) - (let ((consult--buffer-display #'switch-to-buffer-other-frame)) - (consult-buffer))) - -;;;;; Command: consult-kmacro - -(defun consult--kmacro-candidates () - "Return alist of kmacros and indices." - (thread-last - ;; List of macros - (append (when last-kbd-macro - `((,last-kbd-macro ,kmacro-counter ,kmacro-counter-format))) - kmacro-ring) - ;; Add indices - (seq-map-indexed #'cons) - ;; Filter mouse clicks - (seq-remove (lambda (x) (seq-some #'mouse-event-p (caar x)))) - ;; Format macros - (mapcar (pcase-lambda (`((,keys ,counter ,format) . ,index)) - (propertize - (format-kbd-macro keys 1) - 'consult--candidate index - 'consult--kmacro-annotation - ;; If the counter is 0 and the counter format is its default, - ;; then there is a good chance that the counter isn't actually - ;; being used. This can only be wrong when a user - ;; intentionally starts the counter with a negative value and - ;; then increments it to 0. - (cond - ((not (string= format "%d")) ;; show counter for non-default format - (format " (counter=%d, format=%s) " counter format)) - ((/= counter 0) ;; show counter if non-zero - (format " (counter=%d)" counter)))))) - (delete-dups))) - -;;;###autoload -(defun consult-kmacro (arg) - "Run a chosen keyboard macro. - -With prefix ARG, run the macro that many times. -Macros containing mouse clicks are omitted." - (interactive "p") - (let ((selected (consult--read - (or (consult--kmacro-candidates) - (user-error "No keyboard macros defined")) - :prompt "Keyboard macro: " - :category 'consult-kmacro - :require-match t - :sort nil - :history 'consult--kmacro-history - :annotate - (lambda (cand) - (get-text-property 0 'consult--kmacro-annotation cand)) - :lookup #'consult--lookup-candidate))) - (if (= 0 selected) - ;; If the first element has been selected, just run the last macro. - (kmacro-call-macro (or arg 1) t nil) - ;; Otherwise, run a kmacro from the ring. - (let* ((selected (1- selected)) - (kmacro (nth selected kmacro-ring)) - ;; Temporarily change the variables to retrieve the correct - ;; settings. Mainly, we want the macro counter to persist, which - ;; automatically happens when cycling the ring. - (last-kbd-macro (car kmacro)) - (kmacro-counter (cadr kmacro)) - (kmacro-counter-format (caddr kmacro))) - (kmacro-call-macro (or arg 1) t) - ;; Once done, put updated variables back into the ring. - (setf (nth selected kmacro-ring) - (list last-kbd-macro - kmacro-counter - kmacro-counter-format)))))) - -;;;;; Command: consult-grep - -(defun consult--grep-format (async builder) - "Return ASYNC function highlighting grep match results. -BUILDER is the command argument builder." - (let ((highlight)) - (lambda (action) - (cond - ((stringp action) - (setq highlight (plist-get (funcall builder action) :highlight)) - (funcall async action)) - ((consp action) - (let (result) - (save-match-data - (dolist (str action) - (when (and (string-match consult--grep-match-regexp str) - ;; Filter out empty context lines - (or (/= (aref str (match-beginning 3)) ?-) - (/= (match-end 0) (length str)))) - (let* ((file (match-string 1 str)) - (line (match-string 2 str)) - (ctx (= (aref str (match-beginning 3)) ?-)) - (sep (if ctx "-" ":")) - (content (substring str (match-end 0))) - (file-len (length file)) - (line-len (length line))) - (when (> (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--grep-group' - (add-text-properties 0 file-len `(face consult-file consult--grep-file ,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))))) - (funcall async (nreverse result)))) - (t (funcall async action)))))) - -(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'." - (when cand - (let* ((file-end (next-single-property-change 0 'face cand)) - (line-end (next-single-property-change (+ 1 file-end) 'face cand)) - (col (next-single-property-change (+ 1 line-end) 'face cand)) - (file (substring-no-properties cand 0 file-end)) - (line (string-to-number (substring-no-properties cand (+ 1 file-end) line-end)))) - (setq col (if col (- col line-end 1) 0)) - (consult--position-marker - (funcall (or find-file #'find-file) file) - line col)))) - -(defun consult--grep-state () - "Grep preview state function." - (let ((open (consult--temporary-files)) - (jump (consult--jump-state))) - (lambda (cand restore) - (when restore - (funcall open)) - (funcall jump - (consult--grep-position cand (and (not restore) open)) - restore)))) - -(defun consult--grep-group (cand transform) - "Return title for CAND or TRANSFORM the candidate." - (if transform - (substring cand (1+ (length (get-text-property 0 'consult--grep-file cand)))) - (get-text-property 0 'consult--grep-file cand))) - -(defun consult--grep (prompt builder dir initial) - "Run grep in DIR. - -BUILDER is the command builder. -PROMPT is the prompt string. -INITIAL is inital input." - (let* ((prompt-dir (consult--directory-prompt prompt dir)) - (default-directory (cdr prompt-dir)) - (read-process-output-max (max read-process-output-max (* 1024 1024)))) - (consult--read - (consult--async-command builder - (consult--grep-format builder) - :file-handler t) ;; allow tramp - :prompt (car prompt-dir) - :lookup #'consult--lookup-member - :state (consult--grep-state) - :initial (consult--async-split-initial initial) - :add-history (consult--async-split-thingatpt 'symbol) - :require-match t - :category 'consult-grep - :group #'consult--grep-group - :history '(:input consult--grep-history) - :sort nil))) - -(defun consult--grep-lookahead-p (&rest cmd) - "Return t if grep CMD supports lookahead." - (with-temp-buffer - (insert "xaxbx") - (eq 0 (apply #'call-process-region (point-min) (point-max) - (car cmd) nil nil nil `(,@(cdr cmd) "^(?=.*b)(?=.*a)"))))) - -(defvar consult--grep-regexp-type nil) -(defun consult--grep-regexp-type (cmd) - "Return regexp type supported by grep CMD." - (or consult--grep-regexp-type - (setq consult--grep-regexp-type - (if (consult--grep-lookahead-p cmd "-P") 'pcre 'extended)))) - -(defun consult--grep-builder (input) - "Build command line given INPUT." - (pcase-let* ((cmd (split-string-and-unquote consult-grep-args)) - (type (consult--grep-regexp-type (car cmd))) - (`(,arg . ,opts) (consult--command-split input)) - (`(,re . ,hl) (funcall consult--regexp-compiler arg type))) - (when re - (list :command - (append cmd - (list (if (eq type 'pcre) "--perl-regexp" "--extended-regexp") - "-e" (consult--join-regexps re type)) - opts) - :highlight hl)))) - -;;;###autoload -(defun consult-grep (&optional dir initial) - "Search for regexp with grep in DIR with INITIAL input. - -The input string is split, the first part of the string 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 --. - -Example: #async-regexp -- grep-opts#filter-string - -The symbol at point is added to the future history. If `consult-grep' -is called interactively with a prefix argument, the user can specify -the directory to search in. By default the project directory is used -if `consult-project-root-function' is defined and returns non-nil. -Otherwise the `default-directory' is searched." - (interactive "P") - (consult--grep "Grep" #'consult--grep-builder dir initial)) - -;;;;; Command: consult-git-grep - -(defun consult--git-grep-builder (input) - "Build command line given CONFIG and INPUT." - (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) - (`(,re . ,hl) (funcall consult--regexp-compiler arg 'extended))) - (when re - (list :command - (append (split-string-and-unquote consult-git-grep-args) - (cdr (mapcan (lambda (x) (list "--and" "-e" x)) re)) - opts) - :highlight hl)))) - -;;;###autoload -(defun consult-git-grep (&optional dir initial) - "Search for regexp with grep in DIR with INITIAL input. - -See `consult-grep' for more details." - (interactive "P") - (consult--grep "Git-grep" #'consult--git-grep-builder dir initial)) - -;;;;; Command: consult-ripgrep - -(defvar consult--ripgrep-regexp-type nil) -(defun consult--ripgrep-regexp-type (cmd) - "Return regexp type supported by ripgrep CMD." - (or consult--ripgrep-regexp-type - (setq consult--ripgrep-regexp-type - (if (consult--grep-lookahead-p cmd "-P") 'pcre 'extended)))) - -(defun consult--ripgrep-builder (input) - "Build command line given INPUT." - (pcase-let* ((cmd (split-string-and-unquote consult-ripgrep-args)) - (type (consult--ripgrep-regexp-type (car cmd))) - (`(,arg . ,opts) (consult--command-split input)) - (`(,re . ,hl) (funcall consult--regexp-compiler arg type))) - (when re - (list :command - (append cmd - (and (eq type 'pcre) '("-P")) - (list "-e" (consult--join-regexps re type)) - opts) - :highlight hl)))) - -;;;###autoload -(defun consult-ripgrep (&optional dir initial) - "Search for regexp with rg in DIR with INITIAL input. - -See `consult-grep' for more details." - (interactive "P") - (consult--grep "Ripgrep" #'consult--ripgrep-builder dir initial)) - -;;;;; Command: consult-find - -(defun consult--find (prompt builder initial) - "Run find in current directory. - -The function returns the selected file. -The filename at point is added to the future history. - -BUILDER is the command builder. -PROMPT is the prompt. -INITIAL is inital input." - (consult--read - (consult--async-command builder - (consult--async-map (lambda (x) (string-remove-prefix "./" x))) - (consult--async-highlight builder) - :file-handler t) ;; allow tramp - :prompt prompt - :sort nil - :require-match t - :initial (consult--async-split-initial initial) - :add-history (consult--async-split-thingatpt 'filename) - :category 'file - :history '(:input consult--find-history))) - -(defvar consult--find-regexp-type nil) -(defun consult--find-regexp-type (cmd) - "Return regexp type supported by find CMD." - (or consult--find-regexp-type - (setq consult--find-regexp-type - (if (eq 0 (call-process-shell-command - (concat cmd " -regextype emacs -version"))) - 'emacs 'basic)))) - -(defun consult--find-builder (input) - "Build command line given INPUT." - (pcase-let* ((cmd (split-string-and-unquote consult-find-args)) - (type (consult--find-regexp-type (car cmd))) - (`(,arg . ,opts) (consult--command-split input)) - (`(,re . ,hl) (funcall consult--regexp-compiler arg type))) - (when re - (list :command - (append cmd - (cdr (mapcan - (lambda (x) - `("-and" "-iregex" - ,(format ".*%s.*" - ;; HACK Replace non-capturing groups with capturing groups. - ;; GNU find does not support non-capturing groups. - (replace-regexp-in-string - "\\\\(\\?:" "\\(" x 'fixedcase 'literal)))) - re)) - opts) - :highlight hl)))) - -;;;###autoload -(defun consult-find (&optional dir initial) - "Search for regexp with find in DIR with INITIAL input. - -The find process is started asynchronously, similar to `consult-grep'. -See `consult-grep' for more details regarding the asynchronous search." - (interactive "P") - (let* ((prompt-dir (consult--directory-prompt "Find" dir)) - (default-directory (cdr prompt-dir))) - (find-file (consult--find (car prompt-dir) #'consult--find-builder initial)))) - -;;;;; Command: consult-locate - -(defun consult--locate-builder (input) - "Build command line given INPUT." - (pcase-let* ((`(,arg . ,opts) (consult--command-split input)) - (`(,re . ,hl) (funcall consult--regexp-compiler arg 'basic))) - (when re - (list :command - (append (split-string-and-unquote consult-locate-args) - (list (consult--join-regexps re 'basic)) - opts) - :highlight hl)))) - -;;;###autoload -(defun consult-locate (&optional initial) - "Search for regexp with locate with INITIAL input. - -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 given CONFIG and INPUT." - (pcase-let ((`(,arg . ,opts) (consult--command-split input))) - (unless (string-blank-p arg) - (list :command (append (split-string-and-unquote consult-man-args) - (list arg) opts) - :highlight (cdr (consult--default-regexp-compiler input 'basic)))))) - -(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))) - (add-face-text-property 0 (length names) 'consult-file nil names) - (push (cons - (format "%s - %s" names desc) - (concat section " " name)) - candidates))))) - (nreverse candidates))) - -;;;###autoload -(defun consult-man (&optional initial) - "Search for regexp with man with INITIAL input. - -The man process is started asynchronously, similar to `consult-grep'. -See `consult-grep' for more details regarding the asynchronous search." - (interactive) - (man (consult--read - (consult--async-command #'consult--man-builder - (consult--async-transform consult--man-format) - (consult--async-highlight #'consult--man-builder)) - :prompt "Manual entry: " - :require-match t - :lookup #'consult--lookup-cdr - :initial (consult--async-split-initial initial) - :add-history (consult--async-split-thingatpt 'symbol) - :history '(:input consult--man-history)))) - -;;;; Preview at point in completions buffers - -(define-minor-mode consult-preview-at-point-mode - "Preview minor mode for *Completions* buffers. -When moving around in the *Completions* buffer, the candidate at point is -automatically previewed." - :init-value nil :group 'consult - (if consult-preview-at-point-mode - (add-hook 'post-command-hook #'consult-preview-at-point nil 'local) - (remove-hook 'post-command-hook #'consult-preview-at-point 'local))) - -(defun consult-preview-at-point () - "Preview candidate at point in *Completions* buffer." - (interactive) - (when-let* ((win (active-minibuffer-window)) - (buf (window-buffer win)) - (fun (buffer-local-value 'consult--preview-function buf))) - (funcall fun))) - -;;;; Integration with the default completion system - -(defun consult--default-completion-mb-candidate () - "Return current minibuffer candidate from default completion system or Icomplete." - (when (and (minibufferp) - (eq completing-read-function #'completing-read-default)) - (let ((content (minibuffer-contents-no-properties))) - ;; When the current minibuffer content matches a candidate, return it! - (if (test-completion content - minibuffer-completion-table - minibuffer-completion-predicate) - content - ;; Return the full first candidate of the sorted completion list. - (when-let ((completions (completion-all-sorted-completions))) - (concat - (substring content 0 (or (cdr (last completions)) 0)) - (car completions))))))) - -(defun consult--default-completion-list-candidate () - "Return current candidate at point from completions buffer." - (let (beg end) - (when (and - (derived-mode-p 'completion-list-mode) - ;; Logic taken from `choose-completion'. - ;; TODO Upstream a `completion-list-get-candidate' function. - (cond - ((and (not (eobp)) (get-text-property (point) 'mouse-face)) - (setq end (point) beg (1+ (point)))) - ((and (not (bobp)) (get-text-property (1- (point)) 'mouse-face)) - (setq end (1- (point)) beg (point))))) - (setq beg (previous-single-property-change beg 'mouse-face) - end (or (next-single-property-change end 'mouse-face) (point-max))) - (buffer-substring-no-properties beg end)))) - -;; Announce now that consult has been loaded -(provide 'consult) - -;;;; Integration with other completion systems - -(with-eval-after-load 'icomplete (require 'consult-icomplete)) -(with-eval-after-load 'selectrum (require 'consult-selectrum)) -(with-eval-after-load 'vertico (require 'consult-vertico)) - -;;; consult.el ends here diff --git a/elpa/consult-0.13/consult.elc b/elpa/consult-0.13/consult.elc Binary files differ. diff --git a/elpa/corfu-0.16.signed b/elpa/corfu-0.16.signed @@ -1 +0,0 @@ -Good signature from 066DAFCB81E42C40 GNU ELPA Signing Agent (2019) <elpasign@elpa.gnu.org> (trust undefined) created at 2021-11-27T11:05:02+0100 using RSA -\ No newline at end of file diff --git a/elpa/corfu-0.16/LICENSE b/elpa/corfu-0.16/LICENSE @@ -1,674 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The GNU General Public License is a free, copyleft license for -software and other kinds of works. - - The licenses for most software and other practical works are designed -to take away your freedom to share and change the works. By contrast, -the GNU General Public License is intended to guarantee your freedom to -share and change all versions of a program--to make sure it remains free -software for all its users. We, the Free Software Foundation, use the -GNU General Public License for most of our software; it applies also to -any other work released this way by its authors. You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -them if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs, and that you know you can do these things. - - To protect your rights, we need to prevent others from denying you -these rights or asking you to surrender the rights. Therefore, you have -certain responsibilities if you distribute copies of the software, or if -you modify it: responsibilities to respect the freedom of others. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must pass on to the recipients the same -freedoms that you received. You must make sure that they, too, receive -or can get the source code. And you must show them these terms so they -know their rights. - - Developers that use the GNU GPL protect your rights with two steps: -(1) assert copyright on the software, and (2) offer you this License -giving you legal permission to copy, distribute and/or modify it. - - For the developers' and authors' protection, the GPL clearly explains -that there is no warranty for this free software. For both users' and -authors' sake, the GPL requires that modified versions be marked as -changed, so that their problems will not be attributed erroneously to -authors of previous versions. - - Some devices are designed to deny users access to install or run -modified versions of the software inside them, although the manufacturer -can do so. This is fundamentally incompatible with the aim of -protecting users' freedom to change the software. The systematic -pattern of such abuse occurs in the area of products for individuals to -use, which is precisely where it is most unacceptable. Therefore, we -have designed this version of the GPL to prohibit the practice for those -products. If such problems arise substantially in other domains, we -stand ready to extend this provision to those domains in future versions -of the GPL, as needed to protect the freedom of users. - - Finally, every program is threatened constantly by software patents. -States should not allow patents to restrict development and use of -software on general-purpose computers, but in those that do, we wish to -avoid the special danger that patents applied to a free program could -make it effectively proprietary. To prevent this, the GPL assures that -patents cannot be used to render the program non-free. - - The precise terms and conditions for copying, distribution and -modification follow. - - TERMS AND CONDITIONS - - 0. Definitions. - - "This License" refers to version 3 of the GNU General Public License. - - "Copyright" also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - - "The Program" refers to any copyrightable work licensed under this -License. Each licensee is addressed as "you". "Licensees" and -"recipients" may be individuals or organizations. - - To "modify" a work means to copy from or adapt all or part of the work -in a fashion requiring copyright permission, other than the making of an -exact copy. The resulting work is called a "modified version" of the -earlier work or a work "based on" the earlier work. - - A "covered work" means either the unmodified Program or a work based -on the Program. - - To "propagate" a work means to do anything with it that, without -permission, would make you directly or secondarily liable for -infringement under applicable copyright law, except executing it on a -computer or modifying a private copy. Propagation includes copying, -distribution (with or without modification), making available to the -public, and in some countries other activities as well. - - To "convey" a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through -a computer network, with no transfer of a copy, is not conveying. - - An interactive user interface displays "Appropriate Legal Notices" -to the extent that it includes a convenient and prominently visible -feature that (1) displays an appropriate copyright notice, and (2) -tells the user that there is no warranty for the work (except to the -extent that warranties are provided), that licensees may convey the -work under this License, and how to view a copy of this License. If -the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - - 1. Source Code. - - The "source code" for a work means the preferred form of the work -for making modifications to it. "Object code" means any non-source -form of a work. - - A "Standard Interface" means an interface that either is an official -standard defined by a recognized standards body, or, in the case of -interfaces specified for a particular programming language, one that -is widely used among developers working in that language. - - The "System Libraries" of an executable work include anything, other -than the work as a whole, that (a) is included in the normal form of -packaging a Major Component, but which is not part of that Major -Component, and (b) serves only to enable use of the work with that -Major Component, or to implement a Standard Interface for which an -implementation is available to the public in source code form. A -"Major Component", in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system -(if any) on which the executable work runs, or a compiler used to -produce the work, or an object code interpreter used to run it. - - The "Corresponding Source" for a work in object code form means all -the source code needed to generate, install, and (for an executable -work) run the object code and to modify the work, including scripts to -control those activities. However, it does not include the work's -System Libraries, or general-purpose tools or generally available free -programs which are used unmodified in performing those activities but -which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for -the work, and the source code for shared libraries and dynamically -linked subprograms that the work is specifically designed to require, -such as by intimate data communication or control flow between those -subprograms and other parts of the work. - - The Corresponding Source need not include anything that users -can regenerate automatically from other parts of the Corresponding -Source. - - The Corresponding Source for a work in source code form is that -same work. - - 2. Basic Permissions. - - All rights granted under this License are granted for the term of -copyright on the Program, and are irrevocable provided the stated -conditions are met. This License explicitly affirms your unlimited -permission to run the unmodified Program. The output from running a -covered work is covered by this License only if the output, given its -content, constitutes a covered work. This License acknowledges your -rights of fair use or other equivalent, as provided by copyright law. - - You may make, run and propagate covered works that you do not -convey, without conditions so long as your license otherwise remains -in force. You may convey covered works to others for the sole purpose -of having them make modifications exclusively for you, or provide you -with facilities for running those works, provided that you comply with -the terms of this License in conveying all material for which you do -not control copyright. Those thus making or running the covered works -for you must do so exclusively on your behalf, under your direction -and control, on terms that prohibit them from making any copies of -your copyrighted material outside their relationship with you. - - Conveying under any other circumstances is permitted solely under -the conditions stated below. Sublicensing is not allowed; section 10 -makes it unnecessary. - - 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - - No covered work shall be deemed part of an effective technological -measure under any applicable law fulfilling obligations under article -11 of the WIPO copyright treaty adopted on 20 December 1996, or -similar laws prohibiting or restricting circumvention of such -measures. - - When you convey a covered work, you waive any legal power to forbid -circumvention of technological measures to the extent such circumvention -is effected by exercising rights under this License with respect to -the covered work, and you disclaim any intention to limit operation or -modification of the work as a means of enforcing, against the work's -users, your or third parties' legal rights to forbid circumvention of -technological measures. - - 4. Conveying Verbatim Copies. - - You may convey verbatim copies of the Program's source code as you -receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice; -keep intact all notices stating that this License and any -non-permissive terms added in accord with section 7 apply to the code; -keep intact all notices of the absence of any warranty; and give all -recipients a copy of this License along with the Program. - - You may charge any price or no price for each copy that you convey, -and you may offer support or warranty protection for a fee. - - 5. Conveying Modified Source Versions. - - You may convey a work based on the Program, or the modifications to -produce it from the Program, in the form of source code under the -terms of section 4, provided that you also meet all of these conditions: - - a) The work must carry prominent notices stating that you modified - it, and giving a relevant date. - - b) The work must carry prominent notices stating that it is - released under this License and any conditions added under section - 7. This requirement modifies the requirement in section 4 to - "keep intact all notices". - - c) You must license the entire work, as a whole, under this - License to anyone who comes into possession of a copy. This - License will therefore apply, along with any applicable section 7 - additional terms, to the whole of the work, and all its parts, - regardless of how they are packaged. This License gives no - permission to license the work in any other way, but it does not - invalidate such permission if you have separately received it. - - d) If the work has interactive user interfaces, each must display - Appropriate Legal Notices; however, if the Program has interactive - interfaces that do not display Appropriate Legal Notices, your - work need not make them do so. - - A compilation of a covered work with other separate and independent -works, which are not by their nature extensions of the covered work, -and which are not combined with it such as to form a larger program, -in or on a volume of a storage or distribution medium, is called an -"aggregate" if the compilation and its resulting copyright are not -used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work -in an aggregate does not cause this License to apply to the other -parts of the aggregate. - - 6. Conveying Non-Source Forms. - - You may convey a covered work in object code form under the terms -of sections 4 and 5, provided that you also convey the -machine-readable Corresponding Source under the terms of this License, -in one of these ways: - - a) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by the - Corresponding Source fixed on a durable physical medium - customarily used for software interchange. - - b) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by a - written offer, valid for at least three years and valid for as - long as you offer spare parts or customer support for that product - model, to give anyone who possesses the object code either (1) a - copy of the Corresponding Source for all the software in the - product that is covered by this License, on a durable physical - medium customarily used for software interchange, for a price no - more than your reasonable cost of physically performing this - conveying of source, or (2) access to copy the - Corresponding Source from a network server at no charge. - - c) Convey individual copies of the object code with a copy of the - written offer to provide the Corresponding Source. This - alternative is allowed only occasionally and noncommercially, and - only if you received the object code with such an offer, in accord - with subsection 6b. - - d) Convey the object code by offering access from a designated - place (gratis or for a charge), and offer equivalent access to the - Corresponding Source in the same way through the same place at no - further charge. You need not require recipients to copy the - Corresponding Source along with the object code. If the place to - copy the object code is a network server, the Corresponding Source - may be on a different server (operated by you or a third party) - that supports equivalent copying facilities, provided you maintain - clear directions next to the object code saying where to find the - Corresponding Source. Regardless of what server hosts the - Corresponding Source, you remain obligated to ensure that it is - available for as long as needed to satisfy these requirements. - - e) Convey the object code using peer-to-peer transmission, provided - you inform other peers where the object code and Corresponding - Source of the work are being offered to the general public at no - charge under subsection 6d. - - A separable portion of the object code, whose source code is excluded -from the Corresponding Source as a System Library, need not be -included in conveying the object code work. - - A "User Product" is either (1) a "consumer product", which means any -tangible personal property which is normally used for personal, family, -or household purposes, or (2) anything designed or sold for incorporation -into a dwelling. In determining whether a product is a consumer product, -doubtful cases shall be resolved in favor of coverage. For a particular -product received by a particular user, "normally used" refers to a -typical or common use of that class of product, regardless of the status -of the particular user or of the way in which the particular user -actually uses, or expects or is expected to use, the product. A product -is a consumer product regardless of whether the product has substantial -commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - - "Installation Information" for a User Product means any methods, -procedures, authorization keys, or other information required to install -and execute modified versions of a covered work in that User Product from -a modified version of its Corresponding Source. The information must -suffice to ensure that the continued functioning of the modified object -code is in no case prevented or interfered with solely because -modification has been made. - - If you convey an object code work under this section in, or with, or -specifically for use in, a User Product, and the conveying occurs as -part of a transaction in which the right of possession and use of the -User Product is transferred to the recipient in perpetuity or for a -fixed term (regardless of how the transaction is characterized), the -Corresponding Source conveyed under this section must be accompanied -by the Installation Information. But this requirement does not apply -if neither you nor any third party retains the ability to install -modified object code on the User Product (for example, the work has -been installed in ROM). - - The requirement to provide Installation Information does not include a -requirement to continue to provide support service, warranty, or updates -for a work that has been modified or installed by the recipient, or for -the User Product in which it has been modified or installed. Access to a -network may be denied when the modification itself materially and -adversely affects the operation of the network or violates the rules and -protocols for communication across the network. - - Corresponding Source conveyed, and Installation Information provided, -in accord with this section must be in a format that is publicly -documented (and with an implementation available to the public in -source code form), and must require no special password or key for -unpacking, reading or copying. - - 7. Additional Terms. - - "Additional permissions" are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. -Additional permissions that are applicable to the entire Program shall -be treated as though they were included in this License, to the extent -that they are valid under applicable law. If additional permissions -apply only to part of the Program, that part may be used separately -under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - - When you convey a copy of a covered work, you may at your option -remove any additional permissions from that copy, or from any part of -it. (Additional permissions may be written to require their own -removal in certain cases when you modify the work.) You may place -additional permissions on material, added by you to a covered work, -for which you have or can give appropriate copyright permission. - - Notwithstanding any other provision of this License, for material you -add to a covered work, you may (if authorized by the copyright holders of -that material) supplement the terms of this License with terms: - - a) Disclaiming warranty or limiting liability differently from the - terms of sections 15 and 16 of this License; or - - b) Requiring preservation of specified reasonable legal notices or - author attributions in that material or in the Appropriate Legal - Notices displayed by works containing it; or - - c) Prohibiting misrepresentation of the origin of that material, or - requiring that modified versions of such material be marked in - reasonable ways as different from the original version; or - - d) Limiting the use for publicity purposes of names of licensors or - authors of the material; or - - e) Declining to grant rights under trademark law for use of some - trade names, trademarks, or service marks; or - - f) Requiring indemnification of licensors and authors of that - material by anyone who conveys the material (or modified versions of - it) with contractual assumptions of liability to the recipient, for - any liability that these contractual assumptions directly impose on - those licensors and authors. - - All other non-permissive additional terms are considered "further -restrictions" within the meaning of section 10. If the Program as you -received it, or any part of it, contains a notice stating that it is -governed by this License along with a term that is a further -restriction, you may remove that term. If a license document contains -a further restriction but permits relicensing or conveying under this -License, you may add to a covered work material governed by the terms -of that license document, provided that the further restriction does -not survive such relicensing or conveying. - - If you add terms to a covered work in accord with this section, you -must place, in the relevant source files, a statement of the -additional terms that apply to those files, or a notice indicating -where to find the applicable terms. - - Additional terms, permissive or non-permissive, may be stated in the -form of a separately written license, or stated as exceptions; -the above requirements apply either way. - - 8. Termination. - - You may not propagate or modify a covered work except as expressly -provided under this License. Any attempt otherwise to propagate or -modify it is void, and will automatically terminate your rights under -this License (including any patent licenses granted under the third -paragraph of section 11). - - However, if you cease all violation of this License, then your -license from a particular copyright holder is reinstated (a) -provisionally, unless and until the copyright holder explicitly and -finally terminates your license, and (b) permanently, if the copyright -holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - - Moreover, your license from a particular copyright holder is -reinstated permanently if the copyright holder notifies you of the -violation by some reasonable means, this is the first time you have -received notice of violation of this License (for any work) from that -copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - - Termination of your rights under this section does not terminate the -licenses of parties who have received copies or rights from you under -this License. If your rights have been terminated and not permanently -reinstated, you do not qualify to receive new licenses for the same -material under section 10. - - 9. Acceptance Not Required for Having Copies. - - You are not required to accept this License in order to receive or -run a copy of the Program. Ancillary propagation of a covered work -occurring solely as a consequence of using peer-to-peer transmission -to receive a copy likewise does not require acceptance. However, -nothing other than this License grants you permission to propagate or -modify any covered work. These actions infringe copyright if you do -not accept this License. Therefore, by modifying or propagating a -covered work, you indicate your acceptance of this License to do so. - - 10. Automatic Licensing of Downstream Recipients. - - Each time you convey a covered work, the recipient automatically -receives a license from the original licensors, to run, modify and -propagate that work, subject to this License. You are not responsible -for enforcing compliance by third parties with this License. - - An "entity transaction" is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an -organization, or merging organizations. If propagation of a covered -work results from an entity transaction, each party to that -transaction who receives a copy of the work also receives whatever -licenses to the work the party's predecessor in interest had or could -give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if -the predecessor has it or can get it with reasonable efforts. - - You may not impose any further restrictions on the exercise of the -rights granted or affirmed under this License. For example, you may -not impose a license fee, royalty, or other charge for exercise of -rights granted under this License, and you may not initiate litigation -(including a cross-claim or counterclaim in a lawsuit) alleging that -any patent claim is infringed by making, using, selling, offering for -sale, or importing the Program or any portion of it. - - 11. Patents. - - A "contributor" is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The -work thus licensed is called the contributor's "contributor version". - - A contributor's "essential patent claims" are all patent claims -owned or controlled by the contributor, whether already acquired or -hereafter acquired, that would be infringed by some manner, permitted -by this License, of making, using, or selling its contributor version, -but do not include claims that would be infringed only as a -consequence of further modification of the contributor version. For -purposes of this definition, "control" includes the right to grant -patent sublicenses in a manner consistent with the requirements of -this License. - - Each contributor grants you a non-exclusive, worldwide, royalty-free -patent license under the contributor's essential patent claims, to -make, use, sell, offer for sale, import and otherwise run, modify and -propagate the contents of its contributor version. - - In the following three paragraphs, a "patent license" is any express -agreement or commitment, however denominated, not to enforce a patent -(such as an express permission to practice a patent or covenant not to -sue for patent infringement). To "grant" such a patent license to a -party means to make such an agreement or commitment not to enforce a -patent against the party. - - If you convey a covered work, knowingly relying on a patent license, -and the Corresponding Source of the work is not available for anyone -to copy, free of charge and under the terms of this License, through a -publicly available network server or other readily accessible means, -then you must either (1) cause the Corresponding Source to be so -available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner -consistent with the requirements of this License, to extend the patent -license to downstream recipients. "Knowingly relying" means you have -actual knowledge that, but for the patent license, your conveying the -covered work in a country, or your recipient's use of the covered work -in a country, would infringe one or more identifiable patents in that -country that you have reason to believe are valid. - - If, pursuant to or in connection with a single transaction or -arrangement, you convey, or propagate by procuring conveyance of, a -covered work, and grant a patent license to some of the parties -receiving the covered work authorizing them to use, propagate, modify -or convey a specific copy of the covered work, then the patent license -you grant is automatically extended to all recipients of the covered -work and works based on it. - - A patent license is "discriminatory" if it does not include within -the scope of its coverage, prohibits the exercise of, or is -conditioned on the non-exercise of one or more of the rights that are -specifically granted under this License. You may not convey a covered -work if you are a party to an arrangement with a third party that is -in the business of distributing software, under which you make payment -to the third party based on the extent of your activity of conveying -the work, and under which the third party grants, to any of the -parties who would receive the covered work from you, a discriminatory -patent license (a) in connection with copies of the covered work -conveyed by you (or copies made from those copies), or (b) primarily -for and in connection with specific products or compilations that -contain the covered work, unless you entered into that arrangement, -or that patent license was granted, prior to 28 March 2007. - - Nothing in this License shall be construed as excluding or limiting -any implied license or other defenses to infringement that may -otherwise be available to you under applicable patent law. - - 12. No Surrender of Others' Freedom. - - If conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot convey a -covered work so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you may -not convey it at all. For example, if you agree to terms that obligate you -to collect a royalty for further conveying from those to whom you convey -the Program, the only way you could satisfy both those terms and this -License would be to refrain entirely from conveying the Program. - - 13. Use with the GNU Affero General Public License. - - Notwithstanding any other provision of this License, you have -permission to link or combine any covered work with a work licensed -under version 3 of the GNU Affero General Public License into a single -combined work, and to convey the resulting work. The terms of this -License will continue to apply to the part which is the covered work, -but the special requirements of the GNU Affero General Public License, -section 13, concerning interaction through a network will apply to the -combination as such. - - 14. Revised Versions of this License. - - The Free Software Foundation may publish revised and/or new versions of -the GNU General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - - Each version is given a distinguishing version number. If the -Program specifies that a certain numbered version of the GNU General -Public License "or any later version" applies to it, you have the -option of following the terms and conditions either of that numbered -version or of any later version published by the Free Software -Foundation. If the Program does not specify a version number of the -GNU General Public License, you may choose any version ever published -by the Free Software Foundation. - - If the Program specifies that a proxy can decide which future -versions of the GNU General Public License can be used, that proxy's -public statement of acceptance of a version permanently authorizes you -to choose that version for the Program. - - Later license versions may give you additional or different -permissions. However, no additional obligations are imposed on any -author or copyright holder as a result of your choosing to follow a -later version. - - 15. Disclaimer of Warranty. - - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY -APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT -HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY -OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, -THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM -IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF -ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. Limitation of Liability. - - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS -THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE -USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF -DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD -PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), -EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. - - 17. Interpretation of Sections 15 and 16. - - If the disclaimer of warranty and limitation of liability provided -above cannot be given local legal effect according to their terms, -reviewing courts shall apply local law that most closely approximates -an absolute waiver of all civil liability in connection with the -Program, unless a warranty or assumption of liability accompanies a -copy of the Program in return for a fee. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -state the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - <one line to give the program's name and a brief idea of what it does.> - Copyright (C) <year> <name of author> - - 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 <http://www.gnu.org/licenses/>. - -Also add information on how to contact you by electronic and paper mail. - - If the program does terminal interaction, make it output a short -notice like this when it starts in an interactive mode: - - <program> Copyright (C) <year> <name of author> - This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, your program's commands -might be different; for a GUI interface, you would use an "about box". - - You should also get your employer (if you work as a programmer) or school, -if any, to sign a "copyright disclaimer" for the program, if necessary. -For more information on this, and how to apply and follow the GNU GPL, see -<http://www.gnu.org/licenses/>. - - The GNU General Public License does not permit incorporating your program -into proprietary programs. If your program is a subroutine library, you -may consider it more useful to permit linking proprietary applications with -the library. If this is what you want to do, use the GNU Lesser General -Public License instead of this License. But first, please read -<http://www.gnu.org/philosophy/why-not-lgpl.html>. diff --git a/elpa/corfu-0.16/README.org b/elpa/corfu-0.16/README.org @@ -1,211 +0,0 @@ -#+title: corfu.el - Completion Overlay Region FUnction -#+author: Daniel Mendler -#+language: en -#+export_file_name: corfu.texi -#+texinfo_dir_category: Emacs -#+texinfo_dir_title: Corfu: (corfu). -#+texinfo_dir_desc: Completion Overlay Region FUnction - -#+html: <a href="https://www.gnu.org/software/emacs/"><img alt="GNU Emacs" src="https://github.com/minad/corfu/blob/screenshots/emacs.svg?raw=true"/></a> -#+html: <a href="http://elpa.gnu.org/packages/corfu.html"><img alt="GNU ELPA" src="https://elpa.gnu.org/packages/corfu.svg"/></a> -#+html: <a href="http://elpa.gnu.org/devel/corfu.html"><img alt="GNU-devel ELPA" src="https://elpa.gnu.org/devel/corfu.svg"/></a> - -* Introduction - - Corfu enhances the default completion in region function with a completion - overlay. The current candidates are shown in a popup below or above the point. - Corfu is the minimalistic ~completion-in-region~ counterpart of the [[https://github.com/minad/vertico][Vertico]] - minibuffer UI. - - Corfu is a minimal package, which relies on the Emacs completion facilities and - concentrates on providing a polished completion UI. Completions are either - provided by commands like ~dabbrev-completion~ or by pluggable backends - (~completion-at-point-functions~, Capfs). Most programming language major modes - implement a Capf. Furthermore the language server packages, [[https://github.com/joaotavora/eglot][Eglot]] and [[https://github.com/emacs-lsp/lsp-mode][Lsp-mode]], - both use Capfs which talk to the LSP server to retrieve the completions. - - Corfu does not include custom completion backends. In contrast, the complex - Company package includes custom completion backends, which deviate from the - Emacs completion infrastructure. The Emacs built-in Capfs are mostly - sufficient, but a few additional Capfs and completion functions are provided - by the [[https://github.com/minad/cape][Cape]] package. - - *NOTE*: Corfu uses child frames to show the popup; on non-graphical displays it - will fall back to the default setting of the ~completion-in-region-function~. - - [[https://github.com/minad/corfu/blob/screenshots/light.png?raw=true]] - - [[https://github.com/minad/corfu/blob/screenshots/dark.png?raw=true]] - -* Features - - - Timer-based auto-completions (/off/ by default, set ~corfu-auto~). - - Popup display with scrollbar indicator and arrow key navigation. - - The popup can be summoned explicitly by pressing =TAB= at any time. - - The current candidate is inserted with =TAB= and selected with =RET=. - - Candidates sorting by prefix, string length and alphabetically. - - The selected candidate is previewed (configuable via ~corfu-preview-current~). - - The selected candidate automatically committed on further input by default - (configurable via ~corfu-commit-predicate~). - - The [[https://github.com/oantolin/orderless][Orderless]] completion style is supported. The filter string can contain - arbitrary characters, including spaces, if ~corfu-quit-at-boundary~ is nil. - - Deferred completion style highlighting for performance. - - Jumping to location/documentation of current candidate. - - Show candidate documentation/signature string in the echo area. - - Deprecated candidates are crossed out in the display. - - Support for annotations (~annotation-function~, ~affixation-function~). - - Icons can be provided by an external package via margin formatter functions. - -* Installation and Configuration - - Corfu is available from [[http://elpa.gnu.org/packages/corfu.html][GNU ELPA]], such that it can be installed directly via - ~package-install~. After installation, the global minor mode can be enabled with - =M-x corfu-global-mode=. In order to configure Corfu and other packages in your - init.el, you may want to use ~use-package~. - - Corfu is highly flexible and customizable via ~corfu-*~ customization variables. - For filtering I recommend to give Orderless completion a try, which is - different from the familiar prefix TAB completion. Corfu can be used with the - default completion styles, the use of Orderless is not a necessity. See also - the [[https://github.com/minad/corfu/wiki][Corfu Wiki]] for additional configuration tips. In particular the Lsp-mode - configuration is documented in the Wiki. - - Here is an example configuration: - - #+begin_src emacs-lisp - (use-package corfu - ;; Optional customizations - ;; :custom - ;; (corfu-cycle t) ;; Enable cycling for `corfu-next/previous' - ;; (corfu-auto t) ;; Enable auto completion - ;; (corfu-commit-predicate nil) ;; Do not commit selected candidates on next input - ;; (corfu-quit-at-boundary t) ;; Automatically quit at word boundary - ;; (corfu-quit-no-match t) ;; Automatically quit if there is no match - ;; (corfu-preview-current nil) ;; Disable current candidate preview - ;; (corfu-preselect-first nil) ;; Disable candidate preselection - ;; (corfu-echo-documentation nil) ;; Disable documentation in the echo area - ;; (corfu-scroll-margin 5) ;; Use scroll margin - - ;; You may want to enable Corfu only for certain modes. - ;; :hook ((prog-mode . corfu-mode) - ;; (shell-mode . corfu-mode) - ;; (eshell-mode . corfu-mode)) - - ;; Recommended: Enable Corfu globally. - ;; This is recommended since dabbrev can be used globally (M-/). - :init - (corfu-global-mode)) - - ;; Optionally use the `orderless' completion style. See `+orderless-dispatch' - ;; in the Consult wiki for an advanced Orderless style dispatcher. - ;; Enable `partial-completion' for files to allow path expansion. - ;; You may prefer to use `initials' instead of `partial-completion'. - (use-package orderless - :init - ;; Configure a custom style dispatcher (see the Consult wiki) - ;; (setq orderless-style-dispatchers '(+orderless-dispatch) - ;; orderless-component-separator #'orderless-escapable-split-on-space) - (setq completion-styles '(orderless) - completion-category-defaults nil - completion-category-overrides '((file (styles . (partial-completion)))))) - - ;; Use dabbrev with Corfu! - (use-package dabbrev - ;; Swap M-/ and C-M-/ - :bind (("M-/" . dabbrev-completion) - ("C-M-/" . dabbrev-expand))) - - ;; A few more useful configurations... - (use-package emacs - :init - ;; TAB cycle if there are only few candidates - (setq completion-cycle-threshold 3) - - ;; Emacs 28: Hide commands in M-x which do not apply to the current mode. - ;; Corfu commands are hidden, since they are not supposed to be used via M-x. - ;; (setq read-extended-command-predicate - ;; #'command-completion-default-include-p) - - ;; Enable indentation+completion using the TAB key. - ;; `completion-at-point' is often bound to M-TAB. - (setq tab-always-indent 'complete)) - #+end_src - -** TAB-and-Go completion - -You may be interested in configuring Corfu in TAB-and-Go style. Pressing TAB -moves to the next candidate and further input will then commit the selection. - -#+begin_src emacs-lisp - (use-package corfu - ;; TAB-and-Go customizations - :custom - (corfu-cycle t) ;; Enable cycling for `corfu-next/previous' - (corfu-preselect-first nil) ;; Disable candidate preselection - - ;; Use TAB for cycling, default is `corfu-complete'. - :bind - (:map corfu-map - ("TAB" . corfu-next) - ([tab] . corfu-next) - ("S-TAB" . corfu-previous) - ([backtab] . corfu-previous)) - - :init - (corfu-global-mode)) -#+end_src - -* Key bindings - - Corfu uses a transient keymap ~corfu-map~ which is active while the popup is shown. - The keymap defines the following remappings and bindings: - - - ~beginning-of-buffer~ -> ~corfu-first~ - - ~end-of-buffer~ -> ~corfu-last~ - - ~scroll-down-command~ -> ~corfu-scroll-down~ - - ~scroll-up-command~ -> ~corfu-scroll-up~ - - ~next-line~, =down=, =M-n= -> ~corfu-next~ - - ~previous-line~, =up=, =M-p= -> ~corfu-previous~ - - ~completion-at-point~, =TAB= -> ~corfu-complete~ - - =RET= -> ~corfu-insert~ - - =M-g= -> ~corfu-show-location~ - - =M-h= -> ~corfu-show-documentation~ - - =C-g= -> ~corfu-quit~ - - ~keyboard-escape-quit~ -> ~corfu-reset~ - -* Complementary packages - - Corfu works well together with all packages providing code completion via the - ~completion-at-point-functions~. Furthermore it supports completion styles, - including the advanced [[https://github.com/oantolin/orderless][Orderless]] completion style, where the filtering - expressions are separated by spaces (see ~corfu-quit-at-boundary~). - - I collect additional Capf backends and =completion-in-region= commands in my - small [[https://github.com/minad/cape][Cape]] package. For example the package provides a file name and a dabbrev - completion backend. - - Icons are supported by Corfu via an external package. For example the - [[https://github.com/jdtsmith/kind-icon][kind-icon]] package provides beautifully styled SVG icons based on monochromatic - icon sets like material design. - - You may also want to look into my [[https://github.com/minad/vertico][Vertico]] package. Vertico is the minibuffer - counterpart of Corfu. - -* Caveats - - Corfu is robust in most scenarios. There are a few known technical caveats. - - - Corfu falls back to the default Completion buffer on non-graphical displays, - since Corfu requires child frames. - - No sorting by history, since ~completion-at-point~ does not - maintain a history (See branch =history= for a possible solution). - - There is currently no equivalent for =company-quickhelp=. Documentation and source - can be opened manually in a separate buffer. - - Company has the ability to merge/group the candidates of multiple backends - in some scenarios. This feature is implemented by the function - ~cape-super-capf~ of the [[https://github.com/minad/cape][Cape]] package. - -* Contributions - - Since this package is part of [[http://elpa.gnu.org/packages/corfu.html][GNU ELPA]] contributions require a copyright - assignment to the FSF. diff --git a/elpa/corfu-0.16/corfu-autoloads.el b/elpa/corfu-0.16/corfu-autoloads.el @@ -1,60 +0,0 @@ -;;; corfu-autoloads.el --- automatically extracted autoloads -;; -;;; Code: - -(add-to-list 'load-path (directory-file-name - (or (file-name-directory #$) (car load-path)))) - - -;;;### (autoloads nil "corfu" "corfu.el" (0 0 0 0)) -;;; Generated autoloads from corfu.el - -(autoload 'corfu-mode "corfu" "\ -Completion Overlay Region FUnction - -If called interactively, enable Corfu mode if ARG is positive, -and disable it if ARG is zero or negative. If called from Lisp, -also enable the mode if ARG is omitted or nil, and toggle it if -ARG is `toggle'; disable the mode otherwise. - -\(fn &optional ARG)" t nil) - -(put 'corfu-global-mode 'globalized-minor-mode t) - -(defvar corfu-global-mode nil "\ -Non-nil if Corfu-Global mode is enabled. -See the `corfu-global-mode' command -for a description of this minor mode. -Setting this variable directly does not take effect; -either customize it (see the info node `Easy Customization') -or call the function `corfu-global-mode'.") - -(custom-autoload 'corfu-global-mode "corfu" nil) - -(autoload 'corfu-global-mode "corfu" "\ -Toggle Corfu mode in all buffers. -With prefix ARG, enable Corfu-Global mode if ARG is positive; -otherwise, disable it. If called from Lisp, enable the mode if -ARG is omitted or nil. - -Corfu mode is enabled in all buffers where -`corfu--on' would do it. -See `corfu-mode' for more information on Corfu mode. - -\(fn &optional ARG)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "corfu" '("corfu-"))) - -;;;*** - -;;;### (autoloads nil nil ("corfu-pkg.el") (0 0 0 0)) - -;;;*** - -;; Local Variables: -;; version-control: never -;; no-byte-compile: t -;; no-update-autoloads: t -;; coding: utf-8 -;; End: -;;; corfu-autoloads.el ends here diff --git a/elpa/corfu-0.16/corfu-pkg.el b/elpa/corfu-0.16/corfu-pkg.el @@ -1,2 +0,0 @@ -;; Generated package description from corfu.el -*- no-byte-compile: t -*- -(define-package "corfu" "0.16" "Completion Overlay Region FUnction" '((emacs "27.1")) :authors '(("Daniel Mendler" . "mail@daniel-mendler.de")) :maintainer '("Daniel Mendler" . "mail@daniel-mendler.de") :url "https://github.com/minad/corfu") diff --git a/elpa/corfu-0.16/corfu.el b/elpa/corfu-0.16/corfu.el @@ -1,1193 +0,0 @@ -;;; corfu.el --- Completion Overlay Region FUnction -*- lexical-binding: t -*- - -;; Copyright (C) 2021 Free Software Foundation, Inc. - -;; Author: Daniel Mendler <mail@daniel-mendler.de> -;; Maintainer: Daniel Mendler <mail@daniel-mendler.de> -;; Created: 2021 -;; Version: 0.16 -;; Package-Requires: ((emacs "27.1")) -;; Homepage: 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 <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Corfu enhances the default completion in region function with a -;; completion overlay. The current candidates are shown in a popup -;; below or above the point. Corfu can be considered the minimalistic -;; completion-in-region counterpart of Vertico. - -;;; Code: - -(require 'seq) -(eval-when-compile - (require 'cl-lib) - (require 'subr-x)) - -(defgroup corfu nil - "Completion Overlay Region FUnction." - :group 'convenience - :prefix "corfu-") - -(defcustom corfu-count 10 - "Maximal number of candidates to show." - :type 'integer) - -(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 'integer) - -(defcustom corfu-min-width 15 - "Popup minimum width in characters." - :type 'integer) - -(defcustom corfu-max-width 100 - "Popup maximum width in characters." - :type 'integer) - -(defcustom corfu-cycle nil - "Enable cycling for `corfu-next' and `corfu-previous'." - :type 'boolean) - -(defcustom corfu-continue-commands - ;; nil is undefined command - '(nil ignore completion-at-point universal-argument universal-argument-more digit-argument - "\\`corfu-" "\\`scroll-other-window") - "Continue Corfu completion after executing these commands." - :type '(repeat (choice regexp symbol))) - -(defcustom corfu-commit-predicate #'corfu-candidate-previewed-p - "Automatically commit if the predicate returns t." - :type '(choice (const nil) function)) - -(defcustom corfu-preview-current t - "Preview currently selected candidate." - :type 'boolean) - -(defcustom corfu-preselect-first t - "Preselect first candidate." - :type 'boolean) - -(defcustom corfu-quit-at-boundary nil - "Automatically quit at completion field/word boundary. -If automatic quitting is disabled, Orderless filter strings with spaces -are allowed." - :type 'boolean) - -(defcustom corfu-quit-no-match 1.0 - "Automatically quit if no matching candidate is found. -If a floating point number, quit on no match only if the auto-started -completion began less than that number of seconds ago." - :type '(choice boolean float)) - -(defcustom corfu-excluded-modes nil - "List of modes excluded by `corfu-global-mode'." - :type '(repeat symbol)) - -(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-echo-documentation 0.5 - "Show documentation string in the echo area after that number of seconds." - :type '(choice boolean float)) - -(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." - :type 'hook) - -(defcustom corfu-sort-function #'corfu-sort-length-alpha - "Default sorting function, used if no `display-sort-function' is specified." - :type `(choice - (const :tag "No sorting" nil) - (const :tag "By length and alpha" ,#'corfu-sort-length-alpha) - (function :tag "Custom function"))) - -(defcustom corfu-auto-prefix 3 - "Minimum length of prefix for auto completion. -The completion backend can override this with -:company-prefix-length." - :type 'integer) - -(defcustom corfu-auto-delay 0.2 - "Delay for auto completion." - :type 'float) - -(defcustom corfu-auto-commands - '("self-insert-command\\'") - "Commands which initiate auto completion." - :type '(repeat (choice regexp symbol))) - -(defcustom corfu-auto nil - "Enable auto completion." - :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") - (t :background "gray")) - "Default face used for the popup, in particular the background and foreground color.") - -(defface corfu-current - '((((class color) (min-colors 88) (background dark)) - :background "#00415e" :foreground "white") - (((class color) (min-colors 88) (background light)) - :background "#c0efff" :foreground "black") - (t :background "blue" :foreground "white")) - "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 "gray")) - "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-echo - '((t :inherit completions-annotations)) - "Face used for echo area messages.") - -(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 corfu-map - (let ((map (make-sparse-keymap))) - (define-key map [remap beginning-of-buffer] #'corfu-first) - (define-key map [remap end-of-buffer] #'corfu-last) - (define-key map [remap scroll-down-command] #'corfu-scroll-down) - (define-key map [remap scroll-up-command] #'corfu-scroll-up) - (define-key map [remap next-line] #'corfu-next) - (define-key map [remap previous-line] #'corfu-previous) - (define-key map [remap completion-at-point] #'corfu-complete) - (define-key map [down] #'corfu-next) - (define-key map [up] #'corfu-previous) - (define-key map [remap keyboard-escape-quit] #'corfu-reset) - ;; XXX [tab] is bound because of org-mode - ;; The binding should be removed from org-mode-map. - (define-key map [tab] #'corfu-complete) - (define-key map "\en" #'corfu-next) - (define-key map "\ep" #'corfu-previous) - (define-key map "\C-g" #'corfu-quit) - (define-key map "\r" #'corfu-insert) - (define-key map "\t" #'corfu-complete) - (define-key map "\eg" #'corfu-show-location) - (define-key map "\eh" #'corfu-show-documentation) - map) - "Corfu keymap used when popup is shown.") - -(defvar corfu--auto-timer nil - "Auto completion timer.") - -(defvar-local corfu--candidates nil - "List of candidates.") - -(defvar-local corfu--metadata nil - "Completion metadata.") - -(defvar-local corfu--base 0 - "Size of the base string, which is concatenated with the candidate.") - -(defvar-local corfu--total 0 - "Length of the candidate list `corfu--candidates'.") - -(defvar-local corfu--highlight #'identity - "Deferred candidate highlighting function.") - -(defvar-local corfu--index -1 - "Index of current candidate or negative for prompt selection.") - -(defvar-local corfu--preselect -1 - "Index of preselected candidate, negative for prompt selection.") - -(defvar-local corfu--scroll 0 - "Scroll position.") - -(defvar-local corfu--input nil - "Cons of last prompt contents and point or t.") - -(defvar-local corfu--preview-ov nil - "Current candidate overlay.") - -(defvar-local corfu--extra nil - "Extra completion properties.") - -(defvar-local corfu--change-group nil - "Undo change group.") - -(defvar-local corfu--auto-start nil - "Auto completion start time.") - -(defvar-local corfu--echo-timer nil - "Echo area message timer.") - -(defvar-local corfu--echo-message nil - "Last echo message.") - -(defvar corfu--frame nil - "Popup frame.") - -(defconst corfu--state-vars - '(corfu--base - corfu--candidates - corfu--highlight - corfu--index - corfu--preselect - corfu--scroll - corfu--input - corfu--total - corfu--preview-ov - corfu--extra - corfu--auto-start - corfu--echo-timer - corfu--echo-message - corfu--change-group - corfu--metadata) - "Buffer-local state variables used by Corfu.") - -(defvar corfu--frame-parameters - '((no-accept-focus . t) - (no-focus-on-map . t) - (min-width . t) - (min-height . t) - (width . 0) - (height . 0) - (border-width . 0) - (child-frame-border-width . 1) - (left-fringe . 0) - (right-fringe . 0) - (vertical-scroll-bars . nil) - (horizontal-scroll-bars . nil) - (menu-bar-lines . 0) - (tool-bar-lines . 0) - (tab-bar-lines . 0) - (no-other-frame . t) - (no-other-window . t) - (no-delete-other-windows . t) - (unsplittable . t) - (undecorated . t) - (cursor-type . nil) - (visibility . nil) - (no-special-glyphs . t) - (desktop-dont-save . t)) - "Default child frame parameters.") - -(defvar corfu--buffer-parameters - '((mode-line-format . nil) - (header-line-format . nil) - (tab-line-format . nil) - (tab-bar-format . nil) ;; Emacs 28 tab-bar-format - (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 . nil) - (right-fringe-width . nil) - (left-margin-width . 0) - (right-margin-width . 0) - (fringes-outside-margins . 0) - (buffer-read-only . t)) - "Default child frame buffer parameters.") - -(defvar corfu--mouse-ignore-map - (let ((map (make-sparse-keymap))) - (dotimes (i 7) - (dolist (k '(mouse down-mouse drag-mouse double-mouse triple-mouse)) - (define-key map (vector (intern (format "%s-%s" k (1+ i)))) #'ignore))) - map) - "Ignore all mouse clicks.") - -(defun corfu--popup-redirect-focus () - "Redirect focus from popup." - (redirect-frame-focus corfu--frame (frame-parent corfu--frame))) - -(defun corfu--make-buffer (content) - "Create corfu buffer with CONTENT." - (let ((fr face-remapping-alist) - (buffer (get-buffer-create " *corfu*"))) - (with-current-buffer buffer - ;;; XXX HACK install redirect focus hook - (add-hook 'pre-command-hook #'corfu--popup-redirect-focus nil 'local) - ;;; XXX HACK install mouse ignore map - (use-local-map corfu--mouse-ignore-map) - (dolist (var corfu--buffer-parameters) - (set (make-local-variable (car var)) (cdr var))) - (setq-local face-remapping-alist (copy-tree fr)) - (cl-pushnew 'corfu-default (alist-get 'default face-remapping-alist)) - (let ((inhibit-modification-hooks t) - (inhibit-read-only t)) - (erase-buffer) - (insert content) - (goto-char (point-min)))) - buffer)) - -;; Function adapted from posframe.el by tumashu -(defun corfu--make-frame (x y width height content) - "Show child frame at X/Y with WIDTH/HEIGHT and CONTENT." - (let* ((window-min-height 1) - (window-min-width 1) - (x-gtk-resize-child-frames - (let ((case-fold-search t)) - (and - ;; 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 - (string-match-p "gtk3" system-configuration-features) - (string-match-p "gnome\\|cinnamon" (or (getenv "XDG_CURRENT_DESKTOP") - (getenv "DESKTOP_SESSION") "")) - 'resize-mode))) - (after-make-frame-functions) - (edge (window-inside-pixel-edges)) - (lh (default-line-height)) - (x (max 0 (min (+ (car edge) x - (- (alist-get 'child-frame-border-width corfu--frame-parameters))) - (- (frame-pixel-width) width)))) - (yb (+ (cadr edge) (window-tab-line-height) y lh)) - (y (if (> (+ yb height lh lh) (frame-pixel-height)) - (- yb height lh 1) - yb)) - (buffer (corfu--make-buffer content))) - (unless (and (frame-live-p corfu--frame) - (eq (frame-parent corfu--frame) (window-frame))) - (when corfu--frame (delete-frame corfu--frame)) - (setq corfu--frame (make-frame - `((parent-frame . ,(window-frame)) - (minibuffer . ,(minibuffer-window (window-frame))) - (line-spacing . ,line-spacing) - ;; Set `internal-border-width' for Emacs 27 - (internal-border-width - . ,(alist-get 'child-frame-border-width corfu--frame-parameters)) - ,@corfu--frame-parameters)))) - ;; XXX HACK Setting the same frame-parameter/face-background is not a nop (BUG!). - ;; Check explicitly before applying the setting. - ;; Without the check, the frame flickers on Mac. - ;; XXX HACK We have to apply the face background before adjusting the frame parameter, - ;; otherwise the border is not updated (BUG!). - (let* ((face (if (facep 'child-frame-border) 'child-frame-border 'internal-border)) - (new (face-attribute 'corfu-border :background nil 'default))) - (unless (equal (face-attribute face :background corfu--frame 'default) new) - (set-face-background face new corfu--frame))) - (let ((new (face-attribute 'corfu-default :background nil 'default))) - (unless (equal (frame-parameter corfu--frame 'background-color) new) - (set-frame-parameter corfu--frame 'background-color new))) - (let ((win (frame-root-window corfu--frame))) - (set-window-buffer win buffer) - ;; Mark window as dedicated to prevent frame reuse (#60) - (set-window-dedicated-p win t)) - ;; XXX HACK Make the frame invisible before moving the popup in order to avoid flicker. - (unless (eq (cdr (frame-position corfu--frame)) y) - (make-frame-invisible corfu--frame)) - (set-frame-position corfu--frame x y) - (set-frame-size corfu--frame width height t) - (make-frame-visible corfu--frame))) - -(defun 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* ((ch (default-line-height)) - (cw (default-font-width)) - (lm (ceiling (* cw corfu-left-margin-width))) - (rm (ceiling (* cw corfu-right-margin-width))) - (bw (ceiling (min rm (* cw corfu-bar-width)))) - (lmargin (and (> lm 0) (propertize " " 'display `(space :width (,lm))))) - (rmargin (and (> rm 0) (propertize " " 'display `(space :align-to right)))) - (sbar (when (> bw 0) - (concat (propertize " " 'display `(space :align-to (- right (,rm)))) - (propertize " " 'display `(space :width (,(- rm bw)))) - (propertize " " 'face 'corfu-bar 'display `(space :width (,bw)))))) - (row 0) - (pos (posn-x-y (posn-at-point pos))) - (x (or (car pos) 0)) - (y (or (cdr pos) 0))) - (corfu--make-frame - (- x lm (* cw off)) y - (+ (* width cw) lm rm) (* (length lines) ch) - (mapconcat (lambda (line) - (let ((str (concat lmargin line - (if (and lo (<= lo row (+ lo bar))) sbar rmargin)))) - (when (eq row curr) - (add-face-text-property - 0 (length str) 'corfu-current 'append str)) - (setq row (1+ row)) - str)) - lines "\n")))) - -(defun corfu--popup-hide () - "Hide Corfu popup." - (when (frame-live-p corfu--frame) - (make-frame-invisible corfu--frame) - (with-current-buffer (window-buffer (frame-root-window corfu--frame)) - (let ((inhibit-read-only t)) - (erase-buffer))))) - -(defun corfu--move-to-front (elem list) - "Move ELEM to front of LIST." - (if-let (found (member elem list)) - (let ((head (list (car found)))) - (nconc head (delq (setcar found nil) list))) - list)) - -;; bug#47711: Deferred highlighting for `completion-all-completions' -;; XXX There is one complication: `completion--twq-all' already adds `completions-common-part'. -(defun corfu--all-completions (&rest args) - "Compute all completions for ARGS with deferred highlighting." - (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 deferred 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)))) - ;; Defer the following highlighting functions - (hl #'identity) - ((symbol-function #'completion-hilit-commonality) - (lambda (cands prefix &optional base) - (setq hl (lambda (x) (nconc (completion-hilit-commonality x prefix base) nil))) - (and cands (nconc cands base)))) - ((symbol-function #'completion-pcm--hilit-commonality) - (lambda (pattern cands) - (setq hl (lambda (x) - ;; `completion-pcm--hilit-commonality' sometimes throws an internal error - ;; for example when entering "/sudo:://u". - (condition-case nil - (completion-pcm--hilit-commonality pattern x) - (t x)))) - cands))) - ;; Only advise orderless after it has been loaded to avoid load order issues - (if (and (fboundp 'orderless-highlight-matches) (fboundp 'orderless-pattern-compiler)) - (cl-letf (((symbol-function 'orderless-highlight-matches) - (lambda (pattern cands) - (let ((regexps (orderless-pattern-compiler pattern))) - (setq hl (lambda (x) (orderless-highlight-matches regexps x)))) - cands))) - (cons (apply #'completion-all-completions args) hl)) - (cons (apply #'completion-all-completions args) hl)))) - -(defun corfu--sort-predicate (x y) - "Sorting predicate which compares X and Y." - (or (< (length x) (length y)) (and (= (length x) (length y)) (string< x y)))) - -(defun corfu-sort-length-alpha (list) - "Sort LIST by length and alphabetically." - (sort list #'corfu--sort-predicate)) - -(defmacro corfu--partition! (list form) - "Evaluate FORM for every element and partition LIST." - (let ((head1 (make-symbol "head1")) - (head2 (make-symbol "head2")) - (tail1 (make-symbol "tail1")) - (tail2 (make-symbol "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 candidates) - "Move CANDIDATES which match prefix of FIELD to the beginning." - (let* ((word (replace-regexp-in-string " .*" "" field)) - (len (length word))) - (corfu--partition! candidates - (and (>= (length it) len) - (eq t (compare-strings word 0 len it 0 len)))))) - -(defun corfu--filter-files (files) - "Filter FILES by `completion-ignored-extensions'." - (let ((re (concat "\\(?:\\(?:\\`\\|/\\)\\.\\.?/\\|" - (regexp-opt completion-ignored-extensions) - "\\)\\'"))) - (or (seq-remove (lambda (x) (string-match-p re x)) files) files))) - -(defun corfu--sort-function () - "Return the sorting function." - (or (corfu--metadata-get 'display-sort-function) corfu-sort-function)) - -(defun corfu--recompute-candidates (str pt table pred) - "Recompute candidates from STR, PT, TABLE and PRED." - (pcase-let* ((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 between the slashes of "~//". - ;; See also vertico.el which has the same issue. - (bounds (or (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--all-completions str table pred pt corfu--metadata)) - (base (or (when-let (z (last all)) (prog1 (cdr z) (setcdr z nil))) 0))) - ;; 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 (corfu--filter-files all))) - (setq all (funcall (or (corfu--sort-function) #'identity) all)) - (unless (equal field "") - (setq 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--move-to-front field all))) - (list base all (length all) hl corfu--metadata - ;; Select the prompt when the input is a valid completion - ;; and if it is not equal to the first candidate. - (if (or (not corfu-preselect-first) (not all) - (and (not (equal field (car all))) - (not (and completing-file (equal (concat field "/") (car all)))) - (test-completion str table pred))) - -1 0)))) - -(defun corfu--update-candidates (str pt table pred) - "Update candidates from STR, PT, TABLE and PRED." - ;; Redisplay such that the input becomes immediately visible before the - ;; expensive candidate recomputation is performed (Issue #48). See also - ;; corresponding vertico#89. - (redisplay) - (pcase (while-no-input (corfu--recompute-candidates str pt table pred)) - ('nil (keyboard-quit)) - (`(,base ,candidates ,total ,hl ,metadata ,preselect) - (setq corfu--input (cons str pt) - corfu--candidates candidates - corfu--base base - corfu--total total - corfu--preselect preselect - corfu--index preselect - corfu--highlight hl - corfu--metadata metadata)))) - -(defun corfu--match-symbol-p (pattern sym) - "Return non-nil if SYM is matching an element of the PATTERN list." - (and (symbolp sym) - (cl-loop for x in pattern - thereis (if (symbolp x) - (eq sym x) - (string-match-p x (symbol-name sym)))))) - -(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. - (cancel-change-group corfu--change-group) - (activate-change-group (setq corfu--change-group (prepare-change-group))) - (when (eq last-command #'corfu-reset) (corfu-quit)))) - -(defun corfu--affixate (cands) - "Annotate CANDS with annotation function." - (setq cands - (if-let (aff (or (corfu--metadata-get 'affixation-function) - (plist-get corfu--extra :affixation-function))) - (funcall aff cands) - (if-let (ann (or (corfu--metadata-get 'annotation-function) - (plist-get corfu--extra :annotation-function))) - (cl-loop for cand in cands collect - (let ((suffix (or (funcall ann cand) ""))) - (list 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. - (if (text-property-not-all 0 (length suffix) 'face nil suffix) - suffix - (propertize suffix 'face 'corfu-annotations))))) - (cl-loop for cand in cands collect (list cand "" ""))))) - (let* ((dep (plist-get corfu--extra :company-deprecated)) - (completion-extra-properties corfu--extra) - (mf (run-hook-with-args-until-success 'corfu-margin-formatters corfu--metadata))) - (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))) - -(defun corfu--metadata-get (prop) - "Return PROP from completion metadata." - ;; Note: Do not use `completion-metadata-get' in order to avoid Marginalia. - ;; The Marginalia annotators are too heavy for the Corfu popup! - (cdr (assq prop corfu--metadata))) - -(defun corfu--format-candidates (cands) - "Format annotated CANDS." - (setq cands - (cl-loop for c in cands collect - (cl-loop for s in c collect - (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 (+ pw cw sw))) - (when (< width corfu-min-width) - (setq cw (+ cw (- corfu-min-width width)) - width corfu-min-width)) - ;; -4 because of margins and some additional safety - (setq width (min width corfu-max-width (- (frame-width) 4))) - (list pw width - (cl-loop for (cand prefix suffix) in cands collect - (truncate-string-to-width - (concat prefix - (make-string (- pw (string-width prefix)) ?\s) - cand - (when (/= sw 0) - (make-string (+ (- cw (string-width cand)) - (- sw (string-width suffix))) - ?\s)) - suffix) - width))))) - -(defun corfu--update-scroll () - "Update 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--update-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 (funcall corfu--highlight - (seq-subseq corfu--candidates corfu--scroll last)))) - (`(,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 corfu--base) pw width fcands (- corfu--index corfu--scroll) - (and (> corfu--total corfu-count) lo) bar))) - -(defun corfu--preview-current (beg end str) - "Show current candidate as overlay given BEG, END and STR." - (when-let (cand (and corfu-preview-current (>= corfu--index 0) - (/= corfu--index corfu--preselect) - (nth corfu--index corfu--candidates))) - (setq corfu--preview-ov (make-overlay beg end nil t t)) - (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) - (concat (substring str 0 corfu--base) cand)))) - -(defun corfu--echo-refresh () - "Refresh echo message to prevent flicker during redisplay." - (when corfu--echo-timer - (cancel-timer corfu--echo-timer) - (setq corfu--echo-timer nil)) - (when corfu--echo-message - (corfu--echo-show corfu--echo-message))) - -(defun corfu--echo-show (msg) - "Show MSG in echo area." - (let ((message-log-max nil)) - (setq corfu--echo-message msg) - (message "%s" (if (text-property-not-all 0 (length msg) 'face nil msg) - msg - (propertize msg 'face 'corfu-echo))))) - -(defun corfu--echo-documentation () - "Show documentation string of current candidate in echo area." - (when corfu-echo-documentation - (if-let* ((fun (plist-get corfu--extra :company-docsig)) - (cand (and (>= corfu--index 0) (nth corfu--index corfu--candidates))) - (doc (funcall fun cand))) - (if (or (eq corfu-echo-documentation t) corfu--echo-message) - (corfu--echo-show doc) - (setq corfu--echo-timer (run-with-idle-timer corfu-echo-documentation - nil #'corfu--echo-show doc))) - (when corfu--echo-message - (corfu--echo-show ""))))) - -(defun corfu--update () - "Refresh Corfu UI." - (pcase-let* ((`(,beg ,end ,table ,pred) completion-in-region--data) - (pt (- (point) beg)) - (str (buffer-substring-no-properties beg end)) - (initializing (not corfu--input)) - (continue (or (/= beg end) - (corfu--match-symbol-p corfu-continue-commands - this-command)))) - (corfu--echo-refresh) - (cond - ;; XXX Guard against errors during candidate generation. - ;; Turn off completion immediately if there are errors - ;; For example dabbrev throws error "No dynamic expansion ... found". - ;; TODO Report this as a bug? Are completion tables supposed to throw errors? - ((condition-case err - ;; Only recompute when input changed and when input is non-empty - (when (and continue (not (equal corfu--input (cons str pt)))) - (corfu--update-candidates str pt table pred) - nil) - (error (corfu-quit) - (message "Corfu completion error: %s" (error-message-string err))))) - ;; 1) Initializing, no candidates => Quit - ((and initializing (not corfu--candidates)) - (corfu-quit)) - ;; 2) Single matching candidate and no further completion is possible - ((and (not (equal str "")) - (equal corfu--candidates (list str)) - (not (consp (completion-try-completion str table pred pt corfu--metadata)))) - (corfu--done str 'finished)) - ;; 3) There exist candidates - ;; & Input is non-empty or continue command - ;; => Show candidates popup - ((and corfu--candidates continue) - (corfu--candidates-popup beg) - (corfu--echo-documentation) - (corfu--preview-current beg end str)) - ;; 4) There are no candidates & corfu-quit-no-match => Confirmation popup - ((not (or corfu--candidates - ;; When `corfu-quit-no-match' is a number of seconds and the auto completion wasn't - ;; initiated too long ago, quit directly without showing the "No match" popup. - (if (and corfu--auto-start (numberp corfu-quit-no-match)) - (< (- (float-time) corfu--auto-start) corfu-quit-no-match) - (eq t corfu-quit-no-match)))) - (corfu--popup-show beg 0 8 '(#("No match" 0 8 (face italic))))) - (t (corfu-quit))))) - -(defun corfu--pre-command () - "Insert selected candidate unless command is marked to continue completion." - (add-hook 'window-configuration-change-hook #'corfu-quit) - (when corfu--preview-ov - (delete-overlay corfu--preview-ov) - (setq corfu--preview-ov nil)) - (when (and corfu-commit-predicate - (not (corfu--match-symbol-p corfu-continue-commands this-command)) - (funcall corfu-commit-predicate)) - (corfu--insert 'exact))) - -(defun corfu-candidate-previewed-p () - "Return t if a candidate is selected and previewed." - (and corfu-preview-current (/= corfu--index corfu--preselect))) - -(defun corfu--post-command () - "Refresh Corfu after last command." - (remove-hook 'window-configuration-change-hook #'corfu-quit) - (or (pcase completion-in-region--data - (`(,beg ,end . ,_) - (when (let ((pt (point))) - (and (eq (marker-buffer beg) (current-buffer)) - (<= beg pt end) - (save-excursion - (goto-char beg) - (<= (line-beginning-position) pt (line-end-position))) - (or (not corfu-quit-at-boundary) - (funcall completion-in-region-mode--predicate)))) - (corfu--update) - t))) - (corfu-quit))) - -(defun corfu--goto (index) - "Go to candidate with INDEX." - (setq corfu--index (max corfu--preselect (min index (1- corfu--total))) - ;; Reset auto start in order to disable the `corfu-quit-no-match' timer - corfu--auto-start nil)) - -(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, or to the prompt when the first candidate is selected." - (interactive) - (corfu--goto (if (> corfu--index 0) 0 -1))) - -(defun corfu-last () - "Go to last candidate." - (interactive) - (corfu--goto (1- corfu--total))) - -(defun corfu--restore-on-next-command () - "Restore window configuration before next command." - (let ((config (current-window-configuration)) - (other other-window-scroll-buffer) - (restore (make-symbol "corfu--restore"))) - (fset restore - (lambda () - (when (memq this-command '(corfu-quit corfu-reset)) - (setq this-command #'ignore)) - (remove-hook 'pre-command-hook restore) - (setq other-window-scroll-buffer other) - (set-window-configuration config))) - (add-hook 'pre-command-hook restore))) - -;; Company support, taken from `company.el', see `company-show-doc-buffer'. -(defun corfu-show-documentation () - "Show documentation of current candidate." - (interactive) - (when (< corfu--index 0) - (user-error "No candidate selected")) - (if-let* ((fun (plist-get corfu--extra :company-doc-buffer)) - (res (funcall fun (nth corfu--index corfu--candidates)))) - (let ((buf (or (car-safe res) res))) - (corfu--restore-on-next-command) - (setq other-window-scroll-buffer (get-buffer buf)) - (set-window-start (display-buffer buf t) (or (cdr-safe res) (point-min)))) - (user-error "No documentation available"))) - -;; Company support, taken from `company.el', see `company-show-location'. -(defun corfu-show-location () - "Show location of current candidate." - (interactive) - (when (< corfu--index 0) - (user-error "No candidate selected")) - (if-let* ((fun (plist-get corfu--extra :company-location)) - (loc (funcall fun (nth corfu--index corfu--candidates)))) - (let ((buf (or (and (bufferp (car loc)) (car loc)) (find-file-noselect (car loc) t)))) - (corfu--restore-on-next-command) - (setq other-window-scroll-buffer buf) - (with-selected-window (display-buffer buf t) - (save-restriction - (widen) - (if (bufferp (car loc)) - (goto-char (cdr loc)) - (goto-char (point-min)) - (forward-line (1- (cdr loc)))) - (set-window-start nil (point))))) - (user-error "No candidate location available"))) - -(defun corfu-complete () - "Try to complete current input." - (interactive) - (pcase-let ((`(,beg ,end ,table ,pred) completion-in-region--data)) - (if completion-cycling - ;; Proceed with cycling - (let ((completion-extra-properties corfu--extra)) - (corfu--completion-in-region beg end table pred)) - (if (>= corfu--index 0) - ;; Continue completion with selected candidate - (corfu--insert nil) - ;; Try to complete the current input string - (let* ((pt (max 0 (- (point) beg))) - (str (buffer-substring-no-properties beg end)) - (metadata (completion-metadata (substring str 0 pt) table pred))) - (pcase (completion-try-completion str table pred pt metadata) - (`(,newstr . ,newpt) - (completion--replace beg end newstr) - (goto-char (+ beg newpt)))))) - ;; No further completion is possible and the current string is a valid - ;; match, exit with status 'finished. - (let* ((pt (max 0 (- (point) beg))) - (str (buffer-substring-no-properties beg end)) - (metadata (completion-metadata (substring str 0 pt) table pred))) - (when (and (not (consp (completion-try-completion str table pred pt metadata))) - (test-completion str table pred)) - (corfu--done str 'finished)))))) - -(defun corfu--insert (status) - "Insert current candidate, exit with STATUS if non-nil." - (pcase-let* ((`(,beg ,end ,table ,pred) completion-in-region--data) - (str (buffer-substring-no-properties beg end))) - ;; Replace if candidate is selected or if current input is not valid completion. - ;; For example str can be a valid path, e.g., ~/dir/. - (when (or (>= corfu--index 0) (equal str "") - (not (test-completion str table pred))) - ;; 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. - (setq str (concat (substring str 0 corfu--base) - (substring-no-properties (nth (max 0 corfu--index) corfu--candidates)))) - (completion--replace beg end str) - (corfu--goto -1)) ;; Reset selection, but continue completion. - (when status (corfu--done str status)))) ;; Exit with status - -(defun corfu--done (str status) - "Call the `:exit-function' with STR and STATUS and exit completion." - (let ((exit (plist-get corfu--extra :exit-function))) - ;; For successfull completions, amalgamate undo operations, - ;; such that completion can be undone in a single step. - (undo-amalgamate-change-group corfu--change-group) - (corfu-quit) - ;; XXX Is the :exit-function handling sufficient? - (when exit (funcall exit str status)))) - -(defun corfu-insert () - "Insert current candidate." - (interactive) - (if (> corfu--total 0) - (corfu--insert 'finished) - (corfu-quit))) - -(defun corfu--setup () - "Setup Corfu completion state." - (setq corfu--extra completion-extra-properties) - (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--pre-command nil 'local) - (add-hook 'post-command-hook #'corfu--post-command nil 'local) - ;; 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 teardown runs in the correct buffer, if still alive. - (unless completion-in-region-mode - (remove-hook 'completion-in-region-mode-hook sym) - (with-current-buffer (if (buffer-live-p buf) buf (current-buffer)) - (corfu--teardown))))) - (add-hook 'completion-in-region-mode-hook sym))) - -(defun corfu--teardown () - "Teardown Corfu." - ;; Redisplay such that the input becomes immediately visible before the popup - ;; hiding, which is slow (Issue #48). See also corresponding vertico#89. - (redisplay) - (corfu--popup-hide) - (remove-hook 'window-configuration-change-hook #'corfu-quit) - (remove-hook 'pre-command-hook #'corfu--pre-command 'local) - (remove-hook 'post-command-hook #'corfu--post-command 'local) - (when corfu--preview-ov (delete-overlay corfu--preview-ov)) - (when corfu--echo-timer (cancel-timer corfu--echo-timer)) - (when corfu--echo-message (corfu--echo-show "")) - (accept-change-group corfu--change-group) - (mapc #'kill-local-variable corfu--state-vars)) - -(defun corfu--completion-message (msg) - "Print completion MSG, do not hang like `completion--message'." - (when (and completion-show-inline-help - (member msg '("No match" "Sole completion"))) - (message msg))) - -(defun corfu--all-sorted-completions (&optional beg end) - "Compute all sorted completions for string between BEG and END." - (or completion-all-sorted-completions - (pcase-let ((`(,base ,all . ,_) (corfu--recompute-candidates - (buffer-substring-no-properties beg end) - (max 0 (- (point) beg)) - minibuffer-completion-table - minibuffer-completion-predicate))) - (when all - (completion--cache-all-sorted-completions - beg end (nconc all base)))))) - -(defun corfu--completion-in-region (&rest args) - "Corfu completion in region function passing ARGS to `completion--in-region'." - (barf-if-buffer-read-only) - (if (not (display-graphic-p)) - ;; XXX Warning this can result in an endless loop when `completion-in-region-function' - ;; is set *globally* to `corfu--completion-in-region'. This should never happen. - (apply (default-value 'completion-in-region-function) args) - ;; Restart the completion. This can happen for example if C-M-/ - ;; (`dabbrev-completion') is pressed while the Corfu popup is already open. - (when (and completion-in-region-mode (not completion-cycling)) - (corfu-quit)) - (prog1 - (cl-letf* ((completion-auto-help nil) - ;; Set the predicate to ensure that `completion-in-region-mode' is enabled. - (completion-in-region-mode-predicate - (or completion-in-region-mode-predicate (lambda () t))) - ;; Overwrite to avoid hanging. - ((symbol-function #'completion--message) - #'corfu--completion-message) - ;; Overwrite for performance and consistency. - ((symbol-function #'completion-all-sorted-completions) - #'corfu--all-sorted-completions)) - (apply #'completion--in-region args)) - (when (and completion-in-region-mode - ;; Do not show Corfu when "trivially" cycling, i.e., - ;; when the completion is finished after the candidate. - (not (and completion-cycling - (pcase-let* ((`(,beg ,end ,table ,pred) completion-in-region--data) - (pt (max 0 (- (point) beg))) - (str (buffer-substring-no-properties beg end)) - (before (substring str 0 pt)) - (after (substring str pt))) - (equal (completion-boundaries before table pred after) '(0 . 0)))))) - (corfu--setup))))) - -(defun corfu--auto-complete (buffer) - "Initiate auto completion after delay in BUFFER." - (setq corfu--auto-timer nil) - (when (and (not completion-in-region-mode) - (eq (current-buffer) buffer)) - (pcase (run-hook-wrapped 'completion-at-point-functions - #'completion--capf-wrapper 'all) - ((and `(,fun ,beg ,end ,table . ,plist) - (guard (integer-or-marker-p beg)) - (guard (<= beg (point) end)) - (guard - (let ((len (or (plist-get plist :company-prefix-length) (- (point) beg)))) - (or (eq len t) (>= len corfu-auto-prefix))))) - (let ((completion-extra-properties plist) - (completion-in-region-mode-predicate - (lambda () (eq beg (car-safe (funcall fun)))))) - (setq completion-in-region--data `(,(copy-marker beg) ,(copy-marker end t) - ,table ,(plist-get plist :predicate)) - corfu--auto-start (float-time)) - (undo-boundary) ;; Necessary to support `corfu-reset' - (completion-in-region-mode 1) - (corfu--setup) - (corfu--update)))))) - -(defun corfu--auto-post-command () - "Post command hook which initiates auto completion." - (when corfu--auto-timer - (cancel-timer corfu--auto-timer) - (setq corfu--auto-timer nil)) - (when (and (not completion-in-region-mode) - (corfu--match-symbol-p corfu-auto-commands this-command) - (display-graphic-p)) - ;; NOTE: Do not use idle timer since this leads to unacceptable slowdowns, - ;; in particular if flyspell-mode is enabled. - (setq corfu--auto-timer (run-at-time corfu-auto-delay nil - #'corfu--auto-complete - (current-buffer))))) - -;;;###autoload -(define-minor-mode corfu-mode - "Completion Overlay Region FUnction" - :global nil :group 'corfu - (cond - (corfu-mode - ;; FIXME: Install advice which fixes `completion--capf-wrapper', such that - ;; it respects the completion styles for non-exclusive capfs. See FIXME in - ;; the `completion--capf-wrapper' function in minibuffer.el, where the - ;; issue has been mentioned. We never uninstall this advice since the - ;; advice is active *globally*. - (advice-add #'completion--capf-wrapper :around #'corfu--capf-wrapper-advice) - (advice-add #'eldoc-display-message-no-interference-p :before-while #'corfu--allow-eldoc) - (and corfu-auto (add-hook 'post-command-hook #'corfu--auto-post-command nil 'local)) - (setq-local completion-in-region-function #'corfu--completion-in-region)) - (t - (remove-hook 'post-command-hook #'corfu--auto-post-command 'local) - (kill-local-variable 'completion-in-region-function)))) - -(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 ;; Only enable the advice when Corfu is active - (let ((res (funcall fun))) - (when (and (consp res) (integer-or-marker-p (car res)) ;; Valid capf result - (pcase-let ((`(,beg ,end ,table . ,plist) res)) - (and (<= beg (point) end) ;; Sanity checking - ;; For non-exclusive capfs, check for valid completion. - (or (not (eq 'no (plist-get plist :exclusive))) - (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))) - (completion-try-completion str table pred pt md)))))) - (cons fun res))) - (funcall orig fun which))) - -;;;###autoload -(define-globalized-minor-mode corfu-global-mode corfu-mode corfu--on :group 'corfu) - -(defun corfu--on () - "Turn `corfu-mode' on." - (unless (or noninteractive - (eq (aref (buffer-name) 0) ?\s) - (memq major-mode corfu-excluded-modes)) - (corfu-mode 1))) - -(defun corfu--allow-eldoc () - "Return non-nil if Corfu is currently not active." - (not (and corfu-mode completion-in-region-mode))) - -;; Emacs 28: 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-show-location corfu-show-documentation)) - (put sym 'completion-predicate #'ignore)) - -(provide 'corfu) -;;; corfu.el ends here diff --git a/elpa/corfu-0.16/corfu.elc b/elpa/corfu-0.16/corfu.elc Binary files differ. diff --git a/elpa/corfu-0.16/corfu.info b/elpa/corfu-0.16/corfu.info @@ -1,305 +0,0 @@ -This is corfu.info, produced by makeinfo version 6.7 from corfu.texi. - -INFO-DIR-SECTION Emacs -START-INFO-DIR-ENTRY -* Corfu: (corfu). Completion Overlay Region FUnction. -END-INFO-DIR-ENTRY - - -File: corfu.info, Node: Top, Next: Introduction, Up: (dir) - -corfu.el - Completion Overlay Region FUnction -********************************************* - -* Menu: - -* Introduction:: -* Features:: -* Installation and Configuration:: -* Key bindings:: -* Complementary packages:: -* Caveats:: -* Contributions:: - -— The Detailed Node Listing — - -Installation and Configuration - -* TAB-and-Go completion:: - - - -File: corfu.info, Node: Introduction, Next: Features, Prev: Top, Up: Top - -1 Introduction -************** - -Corfu enhances the default completion in region function with a -completion overlay. The current candidates are shown in a popup below -or above the point. Corfu is the minimalistic ‘completion-in-region’ -counterpart of the Vertico (https://github.com/minad/vertico) minibuffer -UI. - - Corfu is a minimal package, which relies on the Emacs completion -facilities and concentrates on providing a polished completion UI. -Completions are either provided by commands like ‘dabbrev-completion’ or -by pluggable backends (‘completion-at-point-functions’, Capfs). Most -programming language major modes implement a Capf. Furthermore the -language server packages, Eglot (https://github.com/joaotavora/eglot) -and Lsp-mode (https://github.com/emacs-lsp/lsp-mode), both use Capfs -which talk to the LSP server to retrieve the completions. - - Corfu does not include custom completion backends. In contrast, the -complex Company package includes custom completion backends, which -deviate from the Emacs completion infrastructure. The Emacs built-in -Capfs are mostly sufficient, but a few additional Capfs and completion -functions are provided by the Cape (https://github.com/minad/cape) -package. - - *NOTE*: Corfu uses child frames to show the popup; on non-graphical -displays it will fall back to the default setting of the -‘completion-in-region-function’. - - <https://github.com/minad/corfu/blob/screenshots/light.png?raw=true> - - <https://github.com/minad/corfu/blob/screenshots/dark.png?raw=true> - - -File: corfu.info, Node: Features, Next: Installation and Configuration, Prev: Introduction, Up: Top - -2 Features -********** - - • Timer-based auto-completions (_off_ by default, set ‘corfu-auto’). - • Popup display with scrollbar indicator and arrow key navigation. - • The popup can be summoned explicitly by pressing ‘TAB’ at any time. - • The current candidate is inserted with ‘TAB’ and selected with - ‘RET’. - • Candidates sorting by prefix, string length and alphabetically. - • The selected candidate is previewed (configuable via - ‘corfu-preview-current’). - • The selected candidate automatically committed on further input by - default (configurable via ‘corfu-commit-predicate’). - • The Orderless (https://github.com/oantolin/orderless) completion - style is supported. The filter string can contain arbitrary - characters, including spaces, if ‘corfu-quit-at-boundary’ is nil. - • Deferred completion style highlighting for performance. - • Jumping to location/documentation of current candidate. - • Show candidate documentation/signature string in the echo area. - • Deprecated candidates are crossed out in the display. - • Support for annotations (‘annotation-function’, - ‘affixation-function’). - • Icons can be provided by an external package via margin formatter - functions. - - -File: corfu.info, Node: Installation and Configuration, Next: Key bindings, Prev: Features, Up: Top - -3 Installation and Configuration -******************************** - -Corfu is available from GNU ELPA -(http://elpa.gnu.org/packages/corfu.html), such that it can be installed -directly via ‘package-install’. After installation, the global minor -mode can be enabled with ‘M-x corfu-global-mode’. In order to configure -Corfu and other packages in your init.el, you may want to use -‘use-package’. - - Corfu is highly flexible and customizable via ‘corfu-*’ customization -variables. For filtering I recommend to give Orderless completion a -try, which is different from the familiar prefix TAB completion. Corfu -can be used with the default completion styles, the use of Orderless is -not a necessity. See also the Corfu Wiki -(https://github.com/minad/corfu/wiki) for additional configuration tips. -In particular the Lsp-mode configuration is documented in the Wiki. - - Here is an example configuration: - - (use-package corfu - ;; Optional customizations - ;; :custom - ;; (corfu-cycle t) ;; Enable cycling for `corfu-next/previous' - ;; (corfu-auto t) ;; Enable auto completion - ;; (corfu-commit-predicate nil) ;; Do not commit selected candidates on next input - ;; (corfu-quit-at-boundary t) ;; Automatically quit at word boundary - ;; (corfu-quit-no-match t) ;; Automatically quit if there is no match - ;; (corfu-preview-current nil) ;; Disable current candidate preview - ;; (corfu-preselect-first nil) ;; Disable candidate preselection - ;; (corfu-echo-documentation nil) ;; Disable documentation in the echo area - ;; (corfu-scroll-margin 5) ;; Use scroll margin - - ;; You may want to enable Corfu only for certain modes. - ;; :hook ((prog-mode . corfu-mode) - ;; (shell-mode . corfu-mode) - ;; (eshell-mode . corfu-mode)) - - ;; Recommended: Enable Corfu globally. - ;; This is recommended since dabbrev can be used globally (M-/). - :init - (corfu-global-mode)) - - ;; Optionally use the `orderless' completion style. See `+orderless-dispatch' - ;; in the Consult wiki for an advanced Orderless style dispatcher. - ;; Enable `partial-completion' for files to allow path expansion. - ;; You may prefer to use `initials' instead of `partial-completion'. - (use-package orderless - :init - ;; Configure a custom style dispatcher (see the Consult wiki) - ;; (setq orderless-style-dispatchers '(+orderless-dispatch) - ;; orderless-component-separator #'orderless-escapable-split-on-space) - (setq completion-styles '(orderless) - completion-category-defaults nil - completion-category-overrides '((file (styles . (partial-completion)))))) - - ;; Use dabbrev with Corfu! - (use-package dabbrev - ;; Swap M-/ and C-M-/ - :bind (("M-/" . dabbrev-completion) - ("C-M-/" . dabbrev-expand))) - - ;; A few more useful configurations... - (use-package emacs - :init - ;; TAB cycle if there are only few candidates - (setq completion-cycle-threshold 3) - - ;; Emacs 28: Hide commands in M-x which do not apply to the current mode. - ;; Corfu commands are hidden, since they are not supposed to be used via M-x. - ;; (setq read-extended-command-predicate - ;; #'command-completion-default-include-p) - - ;; Enable indentation+completion using the TAB key. - ;; `completion-at-point' is often bound to M-TAB. - (setq tab-always-indent 'complete)) - -* Menu: - -* TAB-and-Go completion:: - - -File: corfu.info, Node: TAB-and-Go completion, Up: Installation and Configuration - -3.1 TAB-and-Go completion -========================= - -You may be interested in configuring Corfu in TAB-and-Go style. -Pressing TAB moves to the next candidate and further input will then -commit the selection. - - (use-package corfu - ;; TAB-and-Go customizations - :custom - (corfu-cycle t) ;; Enable cycling for `corfu-next/previous' - (corfu-preselect-first nil) ;; Disable candidate preselection - - ;; Use TAB for cycling, default is `corfu-complete'. - :bind - (:map corfu-map - ("TAB" . corfu-next) - ([tab] . corfu-next) - ("S-TAB" . corfu-previous) - ([backtab] . corfu-previous)) - - :init - (corfu-global-mode)) - - -File: corfu.info, Node: Key bindings, Next: Complementary packages, Prev: Installation and Configuration, Up: Top - -4 Key bindings -************** - -Corfu uses a transient keymap ‘corfu-map’ which is active while the -popup is shown. The keymap defines the following remappings and -bindings: - - • ‘beginning-of-buffer’ -> ‘corfu-first’ - • ‘end-of-buffer’ -> ‘corfu-last’ - • ‘scroll-down-command’ -> ‘corfu-scroll-down’ - • ‘scroll-up-command’ -> ‘corfu-scroll-up’ - • ‘next-line’, ‘down’, ‘M-n’ -> ‘corfu-next’ - • ‘previous-line’, ‘up’, ‘M-p’ -> ‘corfu-previous’ - • ‘completion-at-point’, ‘TAB’ -> ‘corfu-complete’ - • ‘RET’ -> ‘corfu-insert’ - • ‘M-g’ -> ‘corfu-show-location’ - • ‘M-h’ -> ‘corfu-show-documentation’ - • ‘C-g’ -> ‘corfu-quit’ - • ‘keyboard-escape-quit’ -> ‘corfu-reset’ - - -File: corfu.info, Node: Complementary packages, Next: Caveats, Prev: Key bindings, Up: Top - -5 Complementary packages -************************ - -Corfu works well together with all packages providing code completion -via the ‘completion-at-point-functions’. Furthermore it supports -completion styles, including the advanced Orderless -(https://github.com/oantolin/orderless) completion style, where the -filtering expressions are separated by spaces (see -‘corfu-quit-at-boundary’). - - I collect additional Capf backends and ‘completion-in-region’ -commands in my small Cape (https://github.com/minad/cape) package. For -example the package provides a file name and a dabbrev completion -backend. - - Icons are supported by Corfu via an external package. For example -the kind-icon (https://github.com/jdtsmith/kind-icon) package provides -beautifully styled SVG icons based on monochromatic icon sets like -material design. - - You may also want to look into my Vertico -(https://github.com/minad/vertico) package. Vertico is the minibuffer -counterpart of Corfu. - - -File: corfu.info, Node: Caveats, Next: Contributions, Prev: Complementary packages, Up: Top - -6 Caveats -********* - -Corfu is robust in most scenarios. There are a few known technical -caveats. - - • Corfu falls back to the default Completion buffer on non-graphical - displays, since Corfu requires child frames. - • No sorting by history, since ‘completion-at-point’ does not - maintain a history (See branch ‘history’ for a possible solution). - • There is currently no equivalent for ‘company-quickhelp’. - Documentation and source can be opened manually in a separate - buffer. - • Company has the ability to merge/group the candidates of multiple - backends in some scenarios. This feature is implemented by the - function ‘cape-super-capf’ of the Cape - (https://github.com/minad/cape) package. - - -File: corfu.info, Node: Contributions, Prev: Caveats, Up: Top - -7 Contributions -*************** - -Since this package is part of GNU ELPA -(http://elpa.gnu.org/packages/corfu.html) contributions require a -copyright assignment to the FSF. - - - -Tag Table: -Node: Top195 -Node: Introduction597 -Node: Features2215 -Node: Installation and Configuration3619 -Node: TAB-and-Go completion7339 -Node: Key bindings8149 -Node: Complementary packages9101 -Node: Caveats10175 -Node: Contributions11030 - -End Tag Table - - -Local Variables: -coding: utf-8 -End: diff --git a/elpa/corfu-0.16/dir b/elpa/corfu-0.16/dir @@ -1,18 +0,0 @@ -This is the file .../info/dir, which contains the -topmost node of the Info hierarchy, called (dir)Top. -The first time you invoke Info you start off looking at this node. - -File: dir, Node: Top This is the top of the INFO tree - - This (the Directory node) gives a menu of major topics. - Typing "q" exits, "H" lists all Info commands, "d" returns here, - "h" gives a primer for first-timers, - "mEmacs<Return>" visits the Emacs manual, etc. - - In Emacs, you can click mouse button 2 on a menu item or cross reference - to select it. - -* Menu: - -Emacs -* Corfu: (corfu). Completion Overlay Region FUnction. diff --git a/elpa/eglot-1.7/eglot-autoloads.el b/elpa/eglot-1.7/eglot-autoloads.el @@ -1,56 +0,0 @@ -;;; eglot-autoloads.el --- automatically extracted autoloads -;; -;;; Code: - -(add-to-list 'load-path (directory-file-name - (or (file-name-directory #$) (car load-path)))) - - -;;;### (autoloads nil "eglot" "eglot.el" (0 0 0 0)) -;;; Generated autoloads from eglot.el - -(autoload 'eglot "eglot" "\ -Manage a project with a Language Server Protocol (LSP) server. - -The LSP server of CLASS started (or contacted) via CONTACT. If -this operation is successful, current *and future* file buffers -of MANAGED-MAJOR-MODE inside PROJECT automatically become -\"managed\" by the LSP server, meaning information about their -contents is exchanged periodically to provide enhanced -code-analysis via `xref-find-definitions', `flymake-mode', -`eldoc-mode', `completion-at-point', among others. - -Interactively, the command attempts to guess MANAGED-MAJOR-MODE -from current buffer, CLASS and CONTACT from -`eglot-server-programs' and PROJECT from `project-current'. If -it can't guess, the user is prompted. With a single -\\[universal-argument] prefix arg, it always prompt for COMMAND. -With two \\[universal-argument] prefix args, also prompts for -MANAGED-MAJOR-MODE. - -PROJECT is a project instance as returned by `project-current'. - -CLASS is a subclass of symbol `eglot-lsp-server'. - -CONTACT specifies how to contact the server. It is a -keyword-value plist used to initialize CLASS or a plain list as -described in `eglot-server-programs', which see. - -INTERACTIVE is t if called interactively. - -\(fn MANAGED-MAJOR-MODE PROJECT CLASS CONTACT &optional INTERACTIVE)" t nil) - -(autoload 'eglot-ensure "eglot" "\ -Start Eglot session for current buffer if there isn't one." nil nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "eglot" '("eglot-"))) - -;;;*** - -;; Local Variables: -;; version-control: never -;; no-byte-compile: t -;; no-update-autoloads: t -;; coding: utf-8 -;; End: -;;; eglot-autoloads.el ends here diff --git a/elpa/eglot-1.7/eglot-pkg.el b/elpa/eglot-1.7/eglot-pkg.el @@ -1,2 +0,0 @@ -;;; Generated package description from eglot.el -*- no-byte-compile: t -*- -(define-package "eglot" "1.7" "Client for Language Server Protocol (LSP) servers" '((emacs "26.1") (jsonrpc "1.0.14") (flymake "1.0.9") (project "0.3.0") (xref "1.0.1") (eldoc "1.11.0")) :commit "4edd4782f1c16c0516533b52e16b02b772812d16" :authors '(("João Távora" . "joaotavora@gmail.com")) :maintainer '("João Távora" . "joaotavora@gmail.com") :keywords '("convenience" "languages") :url "https://github.com/joaotavora/eglot") diff --git a/elpa/eglot-1.7/eglot.el b/elpa/eglot-1.7/eglot.el @@ -1,2753 +0,0 @@ -;;; eglot.el --- Client for Language Server Protocol (LSP) servers -*- lexical-binding: t; -*- - -;; Copyright (C) 2018-2020 Free Software Foundation, Inc. - -;; Version: 1.7 -;; Package-Version: 1.7 -;; Package-Commit: 4edd4782f1c16c0516533b52e16b02b772812d16 -;; Author: João Távora <joaotavora@gmail.com> -;; Maintainer: João Távora <joaotavora@gmail.com> -;; URL: https://github.com/joaotavora/eglot -;; Keywords: convenience, languages -;; Package-Requires: ((emacs "26.1") (jsonrpc "1.0.14") (flymake "1.0.9") (project "0.3.0") (xref "1.0.1") (eldoc "1.11.0")) - -;; 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 <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Simply M-x eglot should be enough to get you started, but here's a -;; little info (see the accompanying README.md or the URL for more). -;; -;; M-x eglot starts a server via a shell-command guessed from -;; `eglot-server-programs', using the current major-mode (for whatever -;; language you're programming in) as a hint. If it can't guess, it -;; prompts you in the mini-buffer for these things. Actually, the -;; server needen't be locally started: you can connect to a running -;; server via TCP by entering a <host:port> syntax. -;; -;; Anyway, if the connection is successful, you should see an `eglot' -;; indicator pop up in your mode-line. More importantly, this means -;; current *and future* file buffers of that major mode *inside your -;; current project* automatically become \"managed\" by the LSP -;; server, i.e. information about their contents is exchanged -;; periodically to provide enhanced code analysis via -;; `xref-find-definitions', `flymake-mode', `eldoc-mode', -;; `completion-at-point', among others. -;; -;; To "unmanage" these buffers, shutdown the server with M-x -;; eglot-shutdown. -;; -;; You can also do: -;; -;; (add-hook 'foo-mode-hook 'eglot-ensure) -;; -;; To attempt to start an eglot session automatically everytime a -;; foo-mode buffer is visited. -;; -;;; Code: - -(require 'json) -(require 'imenu) -(require 'cl-lib) -(require 'project) -(require 'url-parse) -(require 'url-util) -(require 'pcase) -(require 'compile) ; for some faces -(require 'warnings) -(require 'flymake) -(require 'xref) -(eval-when-compile - (require 'subr-x)) -(require 'jsonrpc) -(require 'filenotify) -(require 'ert) -(require 'array) - -;; ElDoc is preloaded in Emacs, so `require'-ing won't guarantee we are -;; using the latest version from GNU Elpa when we load eglot.el. Use an -;; heuristic to see if we need to `load' it in Emacs < 28. -(if (and (< emacs-major-version 28) - (not (boundp 'eldoc-documentation-strategy))) - (load "eldoc") - (require 'eldoc)) - -;; forward-declare, but don't require (Emacs 28 doesn't seem to care) -(defvar markdown-fontify-code-blocks-natively) -(defvar company-backends) -(defvar company-tooltip-align-annotations) - - - -;;; User tweakable stuff -(defgroup eglot nil - "Interaction with Language Server Protocol servers" - :prefix "eglot-" - :group 'applications) - -(defvar eglot-server-programs '((rust-mode . (eglot-rls "rls")) - (python-mode . ("pyls")) - ((js-mode - typescript-mode) - . ("javascript-typescript-stdio")) - (sh-mode . ("bash-language-server" "start")) - (php-mode - . ("php" "vendor/felixfbecker/\ -language-server/bin/php-language-server.php")) - ((c++-mode c-mode) . ("ccls")) - ((caml-mode tuareg-mode reason-mode) - . ("ocaml-language-server" "--stdio")) - (ruby-mode - . ("solargraph" "socket" "--port" :autoport)) - (haskell-mode - . ("haskell-language-server-wrapper" "--lsp")) - (elm-mode . ("elm-language-server")) - (kotlin-mode . ("kotlin-language-server")) - (go-mode . ("gopls")) - ((R-mode ess-r-mode) . ("R" "--slave" "-e" - "languageserver::run()")) - (java-mode . eglot--eclipse-jdt-contact) - (dart-mode . ("dart_language_server")) - (elixir-mode . ("language_server.sh")) - (ada-mode . ("ada_language_server")) - (scala-mode . ("metals-emacs")) - ((tex-mode context-mode texinfo-mode bibtex-mode) - . ("digestif")) - (erlang-mode . ("erlang_ls" "--transport" "stdio")) - (gdscript-mode . ("localhost" 6008))) - "How the command `eglot' guesses the server to start. -An association list of (MAJOR-MODE . CONTACT) pairs. MAJOR-MODE -is a mode symbol, or a list of mode symbols. The associated -CONTACT specifies how to connect to a server for managing buffers -of those modes. CONTACT can be: - -* In the most common case, a list of strings (PROGRAM [ARGS...]). - PROGRAM is called with ARGS and is expected to serve LSP requests - over the standard input/output channels. - -* A list (HOST PORT [TCP-ARGS...]) where HOST is a string and - PORT is a positive integer for connecting to a server via TCP. - Remaining ARGS are passed to `open-network-stream' for - upgrading the connection with encryption or other capabilities. - -* A list (PROGRAM [ARGS...] :autoport [MOREARGS...]), whereupon a - combination of the two previous options is used. First, an - attempt is made to find an available server port, then PROGRAM - is launched with ARGS; the `:autoport' keyword substituted for - that number; and MOREARGS. Eglot then attempts to establish a - TCP connection to that port number on the localhost. - -* A cons (CLASS-NAME . INITARGS) where CLASS-NAME is a symbol - designating a subclass of `eglot-lsp-server', for representing - experimental LSP servers. INITARGS is a keyword-value plist - used to initialize the object of CLASS-NAME, or a plain list - interpreted as the previous descriptions of CONTACT. In the - latter case that plain list is used to produce a plist with a - suitable :PROCESS initarg to CLASS-NAME. The class - `eglot-lsp-server' descends from `jsonrpc-process-connection', - which you should see for the semantics of the mandatory - :PROCESS argument. - -* A function of a single argument producing any of the above - values for CONTACT. The argument's value is non-nil if the - connection was requested interactively (e.g. from the `eglot' - command), and nil if it wasn't (e.g. from `eglot-ensure'). If - the call is interactive, the function can ask the user for - hints on finding the required programs, etc. Otherwise, it - should not ask the user for any input, and return nil or signal - an error if it can't produce a valid CONTACT.") - -(defface eglot-mode-line - '((t (:inherit font-lock-constant-face :weight bold))) - "Face for package-name in EGLOT's mode line.") - -(defcustom eglot-autoreconnect 3 - "Control ability to reconnect automatically to the LSP server. -If t, always reconnect automatically (not recommended). If nil, -never reconnect automatically after unexpected server shutdowns, -crashes or network failures. A positive integer number says to -only autoreconnect if the previous successful connection attempt -lasted more than that many seconds." - :type '(choice (boolean :tag "Whether to inhibit autoreconnection") - (integer :tag "Number of seconds"))) - -(defcustom eglot-connect-timeout 30 - "Number of seconds before timing out LSP connection attempts. -If nil, never time out." - :type 'number) - -(defcustom eglot-sync-connect 3 - "Control blocking of LSP connection attempts. -If t, block for `eglot-connect-timeout' seconds. A positive -integer number means block for that many seconds, and then wait -for the connection in the background. nil has the same meaning -as 0, i.e. don't block at all." - :type '(choice (boolean :tag "Whether to inhibit autoreconnection") - (integer :tag "Number of seconds"))) - -(defcustom eglot-autoshutdown nil - "If non-nil, shut down server after killing last managed buffer." - :type 'boolean) - -(defcustom eglot-send-changes-idle-time 0.5 - "Don't tell server of changes before Emacs's been idle for this many seconds." - :type 'number) - -(defcustom eglot-events-buffer-size 2000000 - "Control the size of the Eglot events buffer. -If a number, don't let the buffer grow larger than that many -characters. If 0, don't use an event's buffer at all. If nil, -let the buffer grow forever." - :type '(choice (const :tag "No limit" nil) - (integer :tag "Number of characters"))) - -(defcustom eglot-confirm-server-initiated-edits 'confirm - "Non-nil if server-initiated edits should be confirmed with user." - :type '(choice (const :tag "Don't show confirmation prompt" nil) - (symbol :tag "Show confirmation prompt" 'confirm))) - - -;;; Constants -;;; -(defconst eglot--symbol-kind-names - `((1 . "File") (2 . "Module") - (3 . "Namespace") (4 . "Package") (5 . "Class") - (6 . "Method") (7 . "Property") (8 . "Field") - (9 . "Constructor") (10 . "Enum") (11 . "Interface") - (12 . "Function") (13 . "Variable") (14 . "Constant") - (15 . "String") (16 . "Number") (17 . "Boolean") - (18 . "Array") (19 . "Object") (20 . "Key") - (21 . "Null") (22 . "EnumMember") (23 . "Struct") - (24 . "Event") (25 . "Operator") (26 . "TypeParameter"))) - -(defconst eglot--kind-names - `((1 . "Text") (2 . "Method") (3 . "Function") (4 . "Constructor") - (5 . "Field") (6 . "Variable") (7 . "Class") (8 . "Interface") - (9 . "Module") (10 . "Property") (11 . "Unit") (12 . "Value") - (13 . "Enum") (14 . "Keyword") (15 . "Snippet") (16 . "Color") - (17 . "File") (18 . "Reference"))) - -(defconst eglot--{} (make-hash-table) "The empty JSON object.") - - - -;;; Message verification helpers -;;; -(eval-and-compile - (defvar eglot--lsp-interface-alist - `( - (CodeAction (:title) (:kind :diagnostics :edit :command :isPreferred)) - (ConfigurationItem () (:scopeUri :section)) - (Command ((:title . string) (:command . string)) (:arguments)) - (CompletionItem (:label) - (:kind :detail :documentation :deprecated :preselect - :sortText :filterText :insertText :insertTextFormat - :textEdit :additionalTextEdits :commitCharacters - :command :data)) - (Diagnostic (:range :message) (:severity :code :source :relatedInformation)) - (DocumentHighlight (:range) (:kind)) - (FileSystemWatcher (:globPattern) (:kind)) - (Hover (:contents) (:range)) - (InitializeResult (:capabilities) (:serverInfo)) - (Location (:uri :range)) - (LogMessageParams (:type :message)) - (MarkupContent (:kind :value)) - (ParameterInformation (:label) (:documentation)) - (Position (:line :character)) - (Range (:start :end)) - (Registration (:id :method) (:registerOptions)) - (Registration (:id :method) (:registerOptions)) - (ResponseError (:code :message) (:data)) - (ShowMessageParams (:type :message)) - (ShowMessageRequestParams (:type :message) (:actions)) - (SignatureHelp (:signatures) (:activeSignature :activeParameter)) - (SignatureInformation (:label) (:documentation :parameters)) - (SymbolInformation (:name :kind :location) - (:deprecated :containerName)) - (DocumentSymbol (:name :range :selectionRange :kind) - ;; `:containerName' isn't really allowed , but - ;; it simplifies the impl of `eglot-imenu'. - (:detail :deprecated :children :containerName)) - (TextDocumentEdit (:textDocument :edits) ()) - (TextEdit (:range :newText)) - (VersionedTextDocumentIdentifier (:uri :version) ()) - (WorkspaceEdit () (:changes :documentChanges)) - ) - "Alist (INTERFACE-NAME . INTERFACE) of known external LSP interfaces. - -INTERFACE-NAME is a symbol designated by the spec as -\"interface\". INTERFACE is a list (REQUIRED OPTIONAL) where -REQUIRED and OPTIONAL are lists of KEYWORD designating field -names that must be, or may be, respectively, present in a message -adhering to that interface. KEY can be a keyword or a cons (SYM -TYPE), where type is used by `cl-typep' to check types at -runtime. - -Here's what an element of this alist might look like: - - (Command ((:title . string) (:command . string)) (:arguments))")) - -(eval-and-compile - (defvar eglot-strict-mode (if load-file-name '() - '(disallow-non-standard-keys - ;; Uncomment these two for fun at - ;; compile-time or with flymake-mode. - ;; - ;; enforce-required-keys - ;; enforce-optional-keys - )) - "How strictly to check LSP interfaces at compile- and run-time. - -Value is a list of symbols (if the list is empty, no checks are -performed). - -If the symbol `disallow-non-standard-keys' is present, an error -is raised if any extraneous fields are sent by the server. At -compile-time, a warning is raised if a destructuring spec -includes such a field. - -If the symbol `enforce-required-keys' is present, an error is -raised if any required fields are missing from the message sent -from the server. At compile-time, a warning is raised if a -destructuring spec doesn't use such a field. - -If the symbol `enforce-optional-keys' is present, nothing special -happens at run-time. At compile-time, a warning is raised if a -destructuring spec doesn't use all optional fields. - -If the symbol `disallow-unknown-methods' is present, Eglot warns -on unknown notifications and errors on unknown requests. -")) - -(defun eglot--plist-keys (plist) - (cl-loop for (k _v) on plist by #'cddr collect k)) - -(cl-defun eglot--check-object (interface-name - object - &optional - (enforce-required t) - (disallow-non-standard t) - (check-types t)) - "Check that OBJECT conforms to INTERFACE. Error otherwise." - (cl-destructuring-bind - (&key types required-keys optional-keys &allow-other-keys) - (eglot--interface interface-name) - (when-let ((missing (and enforce-required - (cl-set-difference required-keys - (eglot--plist-keys object))))) - (eglot--error "A `%s' must have %s" interface-name missing)) - (when-let ((excess (and disallow-non-standard - (cl-set-difference - (eglot--plist-keys object) - (append required-keys optional-keys))))) - (eglot--error "A `%s' mustn't have %s" interface-name excess)) - (when check-types - (cl-loop - for (k v) on object by #'cddr - for type = (or (cdr (assoc k types)) t) ;; FIXME: enforce nil type? - unless (cl-typep v type) - do (eglot--error "A `%s' must have a %s as %s, but has %s" - interface-name ))) - t)) - -(eval-and-compile - (defun eglot--keywordize-vars (vars) - (mapcar (lambda (var) (intern (format ":%s" var))) vars)) - - (defun eglot--ensure-type (k) (if (consp k) k (cons k t))) - - (defun eglot--interface (interface-name) - (let* ((interface (assoc interface-name eglot--lsp-interface-alist)) - (required (mapcar #'eglot--ensure-type (car (cdr interface)))) - (optional (mapcar #'eglot--ensure-type (cadr (cdr interface))))) - (list :types (append required optional) - :required-keys (mapcar #'car required) - :optional-keys (mapcar #'car optional)))) - - (defun eglot--check-dspec (interface-name dspec) - "Check destructuring spec DSPEC against INTERFACE-NAME." - (cl-destructuring-bind (&key required-keys optional-keys &allow-other-keys) - (eglot--interface interface-name) - (cond ((or required-keys optional-keys) - (let ((too-many - (and - (memq 'disallow-non-standard-keys eglot-strict-mode) - (cl-set-difference - (eglot--keywordize-vars dspec) - (append required-keys optional-keys)))) - (ignored-required - (and - (memq 'enforce-required-keys eglot-strict-mode) - (cl-set-difference - required-keys (eglot--keywordize-vars dspec)))) - (missing-out - (and - (memq 'enforce-optional-keys eglot-strict-mode) - (cl-set-difference - optional-keys (eglot--keywordize-vars dspec))))) - (when too-many (byte-compile-warn - "Destructuring for %s has extraneous %s" - interface-name too-many)) - (when ignored-required (byte-compile-warn - "Destructuring for %s ignores required %s" - interface-name ignored-required)) - (when missing-out (byte-compile-warn - "Destructuring for %s is missing out on %s" - interface-name missing-out)))) - (t - (byte-compile-warn "Unknown LSP interface %s" interface-name)))))) - -(cl-defmacro eglot--dbind (vars object &body body) - "Destructure OBJECT, binding VARS in BODY. -VARS is ([(INTERFACE)] SYMS...) -Honour `eglot-strict-mode'." - (declare (indent 2) (debug (sexp sexp &rest form))) - (let ((interface-name (if (consp (car vars)) - (car (pop vars)))) - (object-once (make-symbol "object-once")) - (fn-once (make-symbol "fn-once"))) - (cond (interface-name - (eglot--check-dspec interface-name vars) - `(let ((,object-once ,object)) - (cl-destructuring-bind (&key ,@vars &allow-other-keys) ,object-once - (eglot--check-object ',interface-name ,object-once - (memq 'enforce-required-keys eglot-strict-mode) - (memq 'disallow-non-standard-keys eglot-strict-mode) - (memq 'check-types eglot-strict-mode)) - ,@body))) - (t - `(let ((,object-once ,object) - (,fn-once (lambda (,@vars) ,@body))) - (if (memq 'disallow-non-standard-keys eglot-strict-mode) - (cl-destructuring-bind (&key ,@vars) ,object-once - (funcall ,fn-once ,@vars)) - (cl-destructuring-bind (&key ,@vars &allow-other-keys) ,object-once - (funcall ,fn-once ,@vars)))))))) - - -(cl-defmacro eglot--lambda (cl-lambda-list &body body) - "Function of args CL-LAMBDA-LIST for processing INTERFACE objects. -Honour `eglot-strict-mode'." - (declare (indent 1) (debug (sexp &rest form))) - (let ((e (cl-gensym "jsonrpc-lambda-elem"))) - `(lambda (,e) (eglot--dbind ,cl-lambda-list ,e ,@body)))) - -(cl-defmacro eglot--dcase (obj &rest clauses) - "Like `pcase', but for the LSP object OBJ. -CLAUSES is a list (DESTRUCTURE FORMS...) where DESTRUCTURE is -treated as in `eglot-dbind'." - (declare (indent 1) (debug (sexp &rest (sexp &rest form)))) - (let ((obj-once (make-symbol "obj-once"))) - `(let ((,obj-once ,obj)) - (cond - ,@(cl-loop - for (vars . body) in clauses - for vars-as-keywords = (eglot--keywordize-vars vars) - for interface-name = (if (consp (car vars)) - (car (pop vars))) - for condition = - (cond (interface-name - (eglot--check-dspec interface-name vars) - ;; In this mode, in runtime, we assume - ;; `eglot-strict-mode' is partially on, otherwise we - ;; can't disambiguate between certain types. - `(ignore-errors - (eglot--check-object - ',interface-name ,obj-once - t - (memq 'disallow-non-standard-keys eglot-strict-mode) - t))) - (t - ;; In this interface-less mode we don't check - ;; `eglot-strict-mode' at all: just check that the object - ;; has all the keys the user wants to destructure. - `(null (cl-set-difference - ',vars-as-keywords - (eglot--plist-keys ,obj-once))))) - collect `(,condition - (cl-destructuring-bind (&key ,@vars &allow-other-keys) - ,obj-once - ,@body))) - (t - (eglot--error "%S didn't match any of %S" - ,obj-once - ',(mapcar #'car clauses))))))) - - -;;; API (WORK-IN-PROGRESS!) -;;; -(cl-defmacro eglot--when-live-buffer (buf &rest body) - "Check BUF live, then do BODY in it." (declare (indent 1) (debug t)) - (let ((b (cl-gensym))) - `(let ((,b ,buf)) (if (buffer-live-p ,b) (with-current-buffer ,b ,@body))))) - -(cl-defmacro eglot--when-buffer-window (buf &body body) - "Check BUF showing somewhere, then do BODY in it" (declare (indent 1) (debug t)) - (let ((b (cl-gensym))) - `(let ((,b ,buf)) - ;;notice the exception when testing with `ert' - (when (or (get-buffer-window ,b) (ert-running-test)) - (with-current-buffer ,b ,@body))))) - -(cl-defmacro eglot--widening (&rest body) - "Save excursion and restriction. Widen. Then run BODY." (declare (debug t)) - `(save-excursion (save-restriction (widen) ,@body))) - -(cl-defgeneric eglot-handle-request (server method &rest params) - "Handle SERVER's METHOD request with PARAMS.") - -(cl-defgeneric eglot-handle-notification (server method &rest params) - "Handle SERVER's METHOD notification with PARAMS.") - -(cl-defgeneric eglot-execute-command (server command arguments) - "Ask SERVER to execute COMMAND with ARGUMENTS.") - -(cl-defgeneric eglot-initialization-options (server) - "JSON object to send under `initializationOptions'" - (:method (_s) eglot--{})) ; blank default - -(cl-defgeneric eglot-register-capability (server method id &rest params) - "Ask SERVER to register capability METHOD marked with ID." - (:method - (_s method _id &rest _params) - (eglot--warn "Server tried to register unsupported capability `%s'" - method))) - -(cl-defgeneric eglot-unregister-capability (server method id &rest params) - "Ask SERVER to register capability METHOD marked with ID." - (:method - (_s method _id &rest _params) - (eglot--warn "Server tried to unregister unsupported capability `%s'" - method))) - -(cl-defgeneric eglot-client-capabilities (server) - "What the EGLOT LSP client supports for SERVER." - (:method (_s) - (list - :workspace (list - :applyEdit t - :executeCommand `(:dynamicRegistration :json-false) - :workspaceEdit `(:documentChanges :json-false) - :didChangeWatchedFiles `(:dynamicRegistration t) - :symbol `(:dynamicRegistration :json-false) - :configuration t) - :textDocument - (list - :synchronization (list - :dynamicRegistration :json-false - :willSave t :willSaveWaitUntil t :didSave t) - :completion (list :dynamicRegistration :json-false - :completionItem - `(:snippetSupport - ,(if (eglot--snippet-expansion-fn) - t - :json-false)) - :contextSupport t) - :hover (list :dynamicRegistration :json-false - :contentFormat - (if (fboundp 'gfm-view-mode) - ["markdown" "plaintext"] - ["plaintext"])) - :signatureHelp (list :dynamicRegistration :json-false - :signatureInformation - `(:parameterInformation - (:labelOffsetSupport t))) - :references `(:dynamicRegistration :json-false) - :definition `(:dynamicRegistration :json-false) - :declaration `(:dynamicRegistration :json-false) - :implementation `(:dynamicRegistration :json-false) - :typeDefinition `(:dynamicRegistration :json-false) - :documentSymbol (list - :dynamicRegistration :json-false - :hierarchicalDocumentSymbolSupport t - :symbolKind `(:valueSet - [,@(mapcar - #'car eglot--symbol-kind-names)])) - :documentHighlight `(:dynamicRegistration :json-false) - :codeAction (list - :dynamicRegistration :json-false - :codeActionLiteralSupport - '(:codeActionKind - (:valueSet - ["quickfix" - "refactor" "refactor.extract" - "refactor.inline" "refactor.rewrite" - "source" "source.organizeImports"])) - :isPreferredSupport t) - :formatting `(:dynamicRegistration :json-false) - :rangeFormatting `(:dynamicRegistration :json-false) - :rename `(:dynamicRegistration :json-false) - :publishDiagnostics `(:relatedInformation :json-false)) - :experimental eglot--{}))) - -(defclass eglot-lsp-server (jsonrpc-process-connection) - ((project-nickname - :documentation "Short nickname for the associated project." - :accessor eglot--project-nickname - :reader eglot-project-nickname) - (major-mode - :documentation "Major mode symbol." - :accessor eglot--major-mode) - (capabilities - :documentation "JSON object containing server capabilities." - :accessor eglot--capabilities) - (server-info - :documentation "JSON object containing server info." - :accessor eglot--server-info) - (shutdown-requested - :documentation "Flag set when server is shutting down." - :accessor eglot--shutdown-requested) - (project - :documentation "Project associated with server." - :accessor eglot--project) - (spinner - :documentation "List (ID DOING-WHAT DONE-P) representing server progress." - :initform `(nil nil t) :accessor eglot--spinner) - (inhibit-autoreconnect - :initform t - :documentation "Generalized boolean inhibiting auto-reconnection if true." - :accessor eglot--inhibit-autoreconnect) - (file-watches - :documentation "Map ID to list of WATCHES for `didChangeWatchedFiles'." - :initform (make-hash-table :test #'equal) :accessor eglot--file-watches) - (managed-buffers - :documentation "List of buffers managed by server." - :accessor eglot--managed-buffers) - (saved-initargs - :documentation "Saved initargs for reconnection purposes." - :accessor eglot--saved-initargs) - (inferior-process - :documentation "Server subprocess started automatically." - :accessor eglot--inferior-process)) - :documentation - "Represents a server. Wraps a process for LSP communication.") - - -;;; Process management -(defvar eglot--servers-by-project (make-hash-table :test #'equal) - "Keys are projects. Values are lists of processes.") - -(defun eglot-shutdown (server &optional _interactive timeout preserve-buffers) - "Politely ask SERVER to quit. -Interactively, read SERVER from the minibuffer unless there is -only one and it's managing the current buffer. - -Forcefully quit it if it doesn't respond within TIMEOUT seconds. -Don't leave this function with the server still running. - -If PRESERVE-BUFFERS is non-nil (interactively, when called with a -prefix argument), do not kill events and output buffers of -SERVER. ." - (interactive (list (eglot--read-server "Shutdown which server" - (eglot-current-server)) - t nil current-prefix-arg)) - (eglot--message "Asking %s politely to terminate" (jsonrpc-name server)) - (unwind-protect - (progn - (setf (eglot--shutdown-requested server) t) - (jsonrpc-request server :shutdown nil :timeout (or timeout 1.5)) - (jsonrpc-notify server :exit nil)) - ;; Now ask jsonrpc.el to shut down the server. - (jsonrpc-shutdown server (not preserve-buffers)) - (unless preserve-buffers (kill-buffer (jsonrpc-events-buffer server))))) - -(defun eglot--on-shutdown (server) - "Called by jsonrpc.el when SERVER is already dead." - ;; Turn off `eglot--managed-mode' where appropriate. - (dolist (buffer (eglot--managed-buffers server)) - (let (;; Avoid duplicate shutdowns (github#389) - (eglot-autoshutdown nil)) - (eglot--when-live-buffer buffer (eglot--managed-mode-off)))) - ;; Kill any expensive watches - (maphash (lambda (_id watches) - (mapcar #'file-notify-rm-watch watches)) - (eglot--file-watches server)) - ;; Kill any autostarted inferior processes - (when-let (proc (eglot--inferior-process server)) - (delete-process proc)) - ;; Sever the project/server relationship for `server' - (setf (gethash (eglot--project server) eglot--servers-by-project) - (delq server - (gethash (eglot--project server) eglot--servers-by-project))) - (cond ((eglot--shutdown-requested server) - t) - ((not (eglot--inhibit-autoreconnect server)) - (eglot--warn "Reconnecting after unexpected server exit.") - (eglot-reconnect server)) - ((timerp (eglot--inhibit-autoreconnect server)) - (eglot--warn "Not auto-reconnecting, last one didn't last long.")))) - -(defun eglot--all-major-modes () - "Return all known major modes." - (let ((retval)) - (mapatoms (lambda (sym) - (when (plist-member (symbol-plist sym) 'derived-mode-parent) - (push sym retval)))) - retval)) - -(defvar eglot--command-history nil - "History of CONTACT arguments to `eglot'.") - -(defun eglot--guess-contact (&optional interactive) - "Helper for `eglot'. -Return (MANAGED-MODE PROJECT CLASS CONTACT). If INTERACTIVE is -non-nil, maybe prompt user, else error as soon as something can't -be guessed." - (let* ((guessed-mode (if buffer-file-name major-mode)) - (managed-mode - (cond - ((and interactive - (or (>= (prefix-numeric-value current-prefix-arg) 16) - (not guessed-mode))) - (intern - (completing-read - "[eglot] Start a server to manage buffers of what major mode? " - (mapcar #'symbol-name (eglot--all-major-modes)) nil t - (symbol-name guessed-mode) nil (symbol-name guessed-mode) nil))) - ((not guessed-mode) - (eglot--error "Can't guess mode to manage for `%s'" (current-buffer))) - (t guessed-mode))) - (project (or (project-current) `(transient . ,default-directory))) - (guess (cdr (assoc managed-mode eglot-server-programs - (lambda (m1 m2) - (cl-find - m2 (if (listp m1) m1 (list m1)) - :test #'provided-mode-derived-p))))) - (guess (if (functionp guess) - (funcall guess interactive) - guess)) - (class (or (and (consp guess) (symbolp (car guess)) - (prog1 (car guess) (setq guess (cdr guess)))) - 'eglot-lsp-server)) - (program (and (listp guess) - (stringp (car guess)) - ;; A second element might be the port of a (host, port) - ;; pair, but in that case it is not a string. - (or (null (cdr guess)) (stringp (cadr guess))) - (car guess))) - (base-prompt - (and interactive - "Enter program to execute (or <host>:<port>): ")) - (program-guess - (and program - (combine-and-quote-strings (cl-subst ":autoport:" - :autoport guess)))) - (prompt - (and base-prompt - (cond (current-prefix-arg base-prompt) - ((null guess) - (format "[eglot] Sorry, couldn't guess for `%s'!\n%s" - managed-mode base-prompt)) - ((and program (not (executable-find program))) - (concat (format "[eglot] I guess you want to run `%s'" - program-guess) - (format ", but I can't find `%s' in PATH!" program) - "\n" base-prompt))))) - (contact - (or (and prompt - (let ((s (read-shell-command - prompt - program-guess - 'eglot-command-history))) - (if (string-match "^\\([^\s\t]+\\):\\([[:digit:]]+\\)$" - (string-trim s)) - (list (match-string 1 s) - (string-to-number (match-string 2 s))) - (cl-subst - :autoport ":autoport:" (split-string-and-unquote s) - :test #'equal)))) - guess - (eglot--error "Couldn't guess for `%s'!" managed-mode)))) - (list managed-mode project class contact))) - -;;;###autoload -(defun eglot (managed-major-mode project class contact &optional interactive) - "Manage a project with a Language Server Protocol (LSP) server. - -The LSP server of CLASS started (or contacted) via CONTACT. If -this operation is successful, current *and future* file buffers -of MANAGED-MAJOR-MODE inside PROJECT automatically become -\"managed\" by the LSP server, meaning information about their -contents is exchanged periodically to provide enhanced -code-analysis via `xref-find-definitions', `flymake-mode', -`eldoc-mode', `completion-at-point', among others. - -Interactively, the command attempts to guess MANAGED-MAJOR-MODE -from current buffer, CLASS and CONTACT from -`eglot-server-programs' and PROJECT from `project-current'. If -it can't guess, the user is prompted. With a single -\\[universal-argument] prefix arg, it always prompt for COMMAND. -With two \\[universal-argument] prefix args, also prompts for -MANAGED-MAJOR-MODE. - -PROJECT is a project instance as returned by `project-current'. - -CLASS is a subclass of symbol `eglot-lsp-server'. - -CONTACT specifies how to contact the server. It is a -keyword-value plist used to initialize CLASS or a plain list as -described in `eglot-server-programs', which see. - -INTERACTIVE is t if called interactively." - (interactive (append (eglot--guess-contact t) '(t))) - (let* ((current-server (eglot-current-server)) - (live-p (and current-server (jsonrpc-running-p current-server)))) - (if (and live-p - interactive - (y-or-n-p "[eglot] Live process found, reconnect instead? ")) - (eglot-reconnect current-server interactive) - (when live-p (ignore-errors (eglot-shutdown current-server))) - (eglot--connect managed-major-mode project class contact)))) - -(defun eglot-reconnect (server &optional interactive) - "Reconnect to SERVER. -INTERACTIVE is t if called interactively." - (interactive (list (eglot--current-server-or-lose) t)) - (when (jsonrpc-running-p server) - (ignore-errors (eglot-shutdown server interactive nil 'preserve-buffers))) - (eglot--connect (eglot--major-mode server) - (eglot--project server) - (eieio-object-class-name server) - (eglot--saved-initargs server)) - (eglot--message "Reconnected!")) - -(defvar eglot--managed-mode) ; forward decl - -;;;###autoload -(defun eglot-ensure () - "Start Eglot session for current buffer if there isn't one." - (let ((buffer (current-buffer))) - (cl-labels - ((maybe-connect - () - (remove-hook 'post-command-hook #'maybe-connect nil) - (eglot--when-live-buffer buffer - (unless eglot--managed-mode - (apply #'eglot--connect (eglot--guess-contact)))))) - (when buffer-file-name - (add-hook 'post-command-hook #'maybe-connect 'append nil))))) - -(defun eglot-events-buffer (server) - "Display events buffer for SERVER. -Use current server's or first available Eglot events buffer." - (interactive (list (eglot-current-server))) - (let ((buffer (if server (jsonrpc-events-buffer server) - (cl-find "\\*EGLOT.*events\\*" - (buffer-list) - :key #'buffer-name :test #'string-match)))) - (if buffer (display-buffer buffer) - (eglot--error "Can't find an Eglot events buffer!")))) - -(defun eglot-stderr-buffer (server) - "Display stderr buffer for SERVER." - (interactive (list (eglot--current-server-or-lose))) - (display-buffer (jsonrpc-stderr-buffer server))) - -(defun eglot-forget-pending-continuations (server) - "Forget pending requests for SERVER." - (interactive (list (eglot--current-server-or-lose))) - (jsonrpc-forget-pending-continuations server)) - -(defvar eglot-connect-hook - '(eglot-signal-didChangeConfiguration) - "Hook run after connecting in `eglot--connect'.") - -(defvar eglot-server-initialized-hook - '() - "Hook run after a `eglot-lsp-server' instance is created. - -That is before a connection was established. Use -`eglot-connect-hook' to hook into when a connection was -successfully established and the server on the other side has -received the initializing configuration. - -Each function is passed the server as an argument") - -(defun eglot--connect (managed-major-mode project class contact) - "Connect to MANAGED-MAJOR-MODE, PROJECT, CLASS and CONTACT. -This docstring appeases checkdoc, that's all." - (let* ((default-directory (project-root project)) - (nickname (file-name-base (directory-file-name default-directory))) - (readable-name (format "EGLOT (%s/%s)" nickname managed-major-mode)) - autostart-inferior-process - (contact (if (functionp contact) (funcall contact) contact)) - (initargs - (cond ((keywordp (car contact)) contact) - ((integerp (cadr contact)) - `(:process ,(lambda () - (apply #'open-network-stream - readable-name nil - (car contact) (cadr contact) - (cddr contact))))) - ((and (stringp (car contact)) (memq :autoport contact)) - `(:process ,(lambda () - (pcase-let ((`(,connection . ,inferior) - (eglot--inferior-bootstrap - readable-name - contact))) - (setq autostart-inferior-process inferior) - connection)))) - ((stringp (car contact)) - `(:process - ,(lambda () - (let ((default-directory default-directory)) - (make-process - :name readable-name - :command contact - :connection-type 'pipe - :coding 'utf-8-emacs-unix - :noquery t - :stderr (get-buffer-create - (format "*%s stderr*" readable-name))))))))) - (spread (lambda (fn) (lambda (server method params) - (apply fn server method (append params nil))))) - (server - (apply - #'make-instance class - :name readable-name - :events-buffer-scrollback-size eglot-events-buffer-size - :notification-dispatcher (funcall spread #'eglot-handle-notification) - :request-dispatcher (funcall spread #'eglot-handle-request) - :on-shutdown #'eglot--on-shutdown - initargs)) - (cancelled nil) - (tag (make-symbol "connected-catch-tag"))) - (setf (eglot--saved-initargs server) initargs) - (setf (eglot--project server) project) - (setf (eglot--project-nickname server) nickname) - (setf (eglot--major-mode server) managed-major-mode) - (setf (eglot--inferior-process server) autostart-inferior-process) - (run-hook-with-args 'eglot-server-initialized-hook server) - ;; Now start the handshake. To honour `eglot-sync-connect' - ;; maybe-sync-maybe-async semantics we use `jsonrpc-async-request' - ;; and mimic most of `jsonrpc-request'. - (unwind-protect - (condition-case _quit - (let ((retval - (catch tag - (jsonrpc-async-request - server - :initialize - (list :processId (unless (eq (jsonrpc-process-type server) - 'network) - (emacs-pid)) - :rootPath (expand-file-name default-directory) - :rootUri (eglot--path-to-uri default-directory) - :initializationOptions (eglot-initialization-options - server) - :capabilities (eglot-client-capabilities server)) - :success-fn - (eglot--lambda ((InitializeResult) capabilities serverInfo) - (unless cancelled - (push server - (gethash project eglot--servers-by-project)) - (setf (eglot--capabilities server) capabilities) - (setf (eglot--server-info server) serverInfo) - (jsonrpc-notify server :initialized eglot--{}) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - ;; No need to pass SERVER as an argument: it has - ;; been registered in `eglot--servers-by-project', - ;; so that it can be found (and cached) from - ;; `eglot--maybe-activate-editing-mode' in any - ;; managed buffer. - (eglot--maybe-activate-editing-mode))) - (setf (eglot--inhibit-autoreconnect server) - (cond - ((booleanp eglot-autoreconnect) - (not eglot-autoreconnect)) - ((cl-plusp eglot-autoreconnect) - (run-with-timer - eglot-autoreconnect nil - (lambda () - (setf (eglot--inhibit-autoreconnect server) - (null eglot-autoreconnect))))))) - (let ((default-directory (project-root project)) - (major-mode managed-major-mode)) - (hack-dir-local-variables-non-file-buffer) - (run-hook-with-args 'eglot-connect-hook server)) - (eglot--message - "Connected! Server `%s' now managing `%s' buffers \ -in project `%s'." - (or (plist-get serverInfo :name) - (jsonrpc-name server)) - managed-major-mode - (eglot-project-nickname server)) - (when tag (throw tag t)))) - :timeout eglot-connect-timeout - :error-fn (eglot--lambda ((ResponseError) code message) - (unless cancelled - (jsonrpc-shutdown server) - (let ((msg (format "%s: %s" code message))) - (if tag (throw tag `(error . ,msg)) - (eglot--error msg))))) - :timeout-fn (lambda () - (unless cancelled - (jsonrpc-shutdown server) - (let ((msg (format "Timed out"))) - (if tag (throw tag `(error . ,msg)) - (eglot--error msg)))))) - (cond ((numberp eglot-sync-connect) - (accept-process-output nil eglot-sync-connect)) - (eglot-sync-connect - (while t (accept-process-output nil 30))))))) - (pcase retval - (`(error . ,msg) (eglot--error msg)) - (`nil (eglot--message "Waiting in background for server `%s'" - (jsonrpc-name server)) - nil) - (_ server))) - (quit (jsonrpc-shutdown server) (setq cancelled 'quit))) - (setq tag nil)))) - -(defun eglot--inferior-bootstrap (name contact &optional connect-args) - "Use CONTACT to start a server, then connect to it. -Return a cons of two process objects (CONNECTION . INFERIOR). -Name both based on NAME. -CONNECT-ARGS are passed as additional arguments to -`open-network-stream'." - (let* ((port-probe (make-network-process :name "eglot-port-probe-dummy" - :server t - :host "localhost" - :service 0)) - (port-number (unwind-protect - (process-contact port-probe :service) - (delete-process port-probe))) - inferior connection) - (unwind-protect - (progn - (setq inferior - (make-process - :name (format "autostart-inferior-%s" name) - :stderr (format "*%s stderr*" name) - :noquery t - :command (cl-subst - (format "%s" port-number) :autoport contact))) - (setq connection - (cl-loop - repeat 10 for i from 1 - do (accept-process-output nil 0.5) - while (process-live-p inferior) - do (eglot--message - "Trying to connect to localhost and port %s (attempt %s)" - port-number i) - thereis (ignore-errors - (apply #'open-network-stream - (format "autoconnect-%s" name) - nil - "localhost" port-number connect-args)))) - (cons connection inferior)) - (cond ((and (process-live-p connection) - (process-live-p inferior)) - (eglot--message "Done, connected to %s!" port-number)) - (t - (when inferior (delete-process inferior)) - (when connection (delete-process connection)) - (eglot--error "Could not start and connect to server%s" - (if inferior - (format " started with %s" - (process-command inferior)) - "!"))))))) - - -;;; Helpers (move these to API?) -;;; -(defun eglot--error (format &rest args) - "Error out with FORMAT with ARGS." - (error "[eglot] %s" (apply #'format format args))) - -(defun eglot--message (format &rest args) - "Message out with FORMAT with ARGS." - (message "[eglot] %s" (apply #'format format args))) - -(defun eglot--warn (format &rest args) - "Warning message with FORMAT and ARGS." - (apply #'eglot--message (concat "(warning) " format) args) - (let ((warning-minimum-level :error)) - (display-warning 'eglot (apply #'format format args) :warning))) - -(defun eglot-current-column () (- (point) (point-at-bol))) - -(defvar eglot-current-column-function #'eglot-lsp-abiding-column - "Function to calculate the current column. - -This is the inverse operation of -`eglot-move-to-column-function' (which see). It is a function of -no arguments returning a column number. For buffers managed by -fully LSP-compliant servers, this should be set to -`eglot-lsp-abiding-column' (the default), and -`eglot-current-column' for all others.") - -(defun eglot-lsp-abiding-column (&optional lbp) - "Calculate current COLUMN as defined by the LSP spec. -LBP defaults to `line-beginning-position'." - (/ (- (length (encode-coding-region (or lbp (line-beginning-position)) - (point) 'utf-16 t)) - 2) - 2)) - -(defun eglot--pos-to-lsp-position (&optional pos) - "Convert point POS to LSP position." - (eglot--widening - (list :line (1- (line-number-at-pos pos t)) ; F!@&#$CKING OFF-BY-ONE - :character (progn (when pos (goto-char pos)) - (funcall eglot-current-column-function))))) - -(defvar eglot-move-to-column-function #'eglot-move-to-lsp-abiding-column - "Function to move to a column reported by the LSP server. - -According to the standard, LSP column/character offsets are based -on a count of UTF-16 code units, not actual visual columns. So -when LSP says position 3 of a line containing just \"aXbc\", -where X is a multi-byte character, it actually means `b', not -`c'. However, many servers don't follow the spec this closely. - -For buffers managed by fully LSP-compliant servers, this should -be set to `eglot-move-to-lsp-abiding-column' (the default), and -`eglot-move-to-column' for all others.") - -(defun eglot-move-to-column (column) - "Move to COLUMN without closely following the LSP spec." - ;; We cannot use `move-to-column' here, because it moves to *visual* - ;; columns, which can be different from LSP columns in case of - ;; `whitespace-mode', `prettify-symbols-mode', etc. (github#296, - ;; github#297) - (goto-char (min (+ (line-beginning-position) column) - (line-end-position)))) - -(defun eglot-move-to-lsp-abiding-column (column) - "Move to COLUMN abiding by the LSP spec." - (save-restriction - (cl-loop - with lbp = (line-beginning-position) - initially - (narrow-to-region lbp (line-end-position)) - (move-to-column column) - for diff = (- column - (eglot-lsp-abiding-column lbp)) - until (zerop diff) - do (condition-case eob-err - (forward-char (/ (if (> diff 0) (1+ diff) (1- diff)) 2)) - (end-of-buffer (cl-return eob-err)))))) - -(defun eglot--lsp-position-to-point (pos-plist &optional marker) - "Convert LSP position POS-PLIST to Emacs point. -If optional MARKER, return a marker instead" - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (forward-line (min most-positive-fixnum - (plist-get pos-plist :line))) - (unless (eobp) ;; if line was excessive leave point at eob - (let ((tab-width 1) - (col (plist-get pos-plist :character))) - (unless (wholenump col) - (eglot--warn - "Caution: LSP server sent invalid character position %s. Using 0 instead." - col) - (setq col 0)) - (funcall eglot-move-to-column-function col))) - (if marker (copy-marker (point-marker)) (point))))) - -(defun eglot--path-to-uri (path) - "URIfy PATH." - (url-hexify-string - (concat "file://" (if (eq system-type 'windows-nt) "/") (file-truename path)) - url-path-allowed-chars)) - -(defun eglot--uri-to-path (uri) - "Convert URI to a file path." - (when (keywordp uri) (setq uri (substring (symbol-name uri) 1))) - (let ((retval (url-filename (url-generic-parse-url (url-unhex-string uri))))) - (if (eq system-type 'windows-nt) (substring retval 1) retval))) - -(defun eglot--snippet-expansion-fn () - "Compute a function to expand snippets. -Doubles as an indicator of snippet support." - (and (boundp 'yas-minor-mode) - (symbol-value 'yas-minor-mode) - 'yas-expand-snippet)) - -(defun eglot--format-markup (markup) - "Format MARKUP according to LSP's spec." - (pcase-let ((`(,string ,mode) - (if (stringp markup) (list markup 'gfm-view-mode) - (list (plist-get markup :value) - (pcase (plist-get markup :kind) - ("markdown" 'gfm-view-mode) - ("plaintext" 'text-mode) - (_ major-mode)))))) - (with-temp-buffer - (setq-local markdown-fontify-code-blocks-natively t) - (insert string) - (ignore-errors (delay-mode-hooks (funcall mode))) - (font-lock-ensure) - (string-trim (filter-buffer-substring (point-min) (point-max)))))) - -(defcustom eglot-ignored-server-capabilites (list) - "LSP server capabilities that Eglot could use, but won't. -You could add, for instance, the symbol -`:documentHighlightProvider' to prevent automatic highlighting -under cursor." - :type '(repeat - (choice - (const :tag "Documentation on hover" :hoverProvider) - (const :tag "Code completion" :completionProvider) - (const :tag "Function signature help" :signatureHelpProvider) - (const :tag "Go to definition" :definitionProvider) - (const :tag "Go to type definition" :typeDefinitionProvider) - (const :tag "Go to implementation" :implementationProvider) - (const :tag "Go to declaration" :implementationProvider) - (const :tag "Find references" :referencesProvider) - (const :tag "Highlight symbols automatically" :documentHighlightProvider) - (const :tag "List symbols in buffer" :documentSymbolProvider) - (const :tag "List symbols in workspace" :workspaceSymbolProvider) - (const :tag "Execute code actions" :codeActionProvider) - (const :tag "Code lens" :codeLensProvider) - (const :tag "Format buffer" :documentFormattingProvider) - (const :tag "Format portion of buffer" :documentRangeFormattingProvider) - (const :tag "On-type formatting" :documentOnTypeFormattingProvider) - (const :tag "Rename symbol" :renameProvider) - (const :tag "Highlight links in document" :documentLinkProvider) - (const :tag "Decorate color references" :colorProvider) - (const :tag "Fold regions of buffer" :foldingRangeProvider) - (const :tag "Execute custom commands" :executeCommandProvider) - (symbol :tag "Other")))) - -(defun eglot--server-capable (&rest feats) - "Determine if current server is capable of FEATS." - (unless (cl-some (lambda (feat) - (memq feat eglot-ignored-server-capabilites)) - feats) - (cl-loop for caps = (eglot--capabilities (eglot--current-server-or-lose)) - then (cadr probe) - for (feat . more) on feats - for probe = (plist-member caps feat) - if (not probe) do (cl-return nil) - if (eq (cadr probe) :json-false) do (cl-return nil) - if (not (listp (cadr probe))) do (cl-return (if more nil (cadr probe))) - finally (cl-return (or (cadr probe) t))))) - -(defun eglot--range-region (range &optional markers) - "Return region (BEG . END) that represents LSP RANGE. -If optional MARKERS, make markers." - (let* ((st (plist-get range :start)) - (beg (eglot--lsp-position-to-point st markers)) - (end (eglot--lsp-position-to-point (plist-get range :end) markers))) - (cons beg end))) - -(defun eglot--read-server (prompt &optional dont-if-just-the-one) - "Read a running Eglot server from minibuffer using PROMPT. -If DONT-IF-JUST-THE-ONE and there's only one server, don't prompt -and just return it. PROMPT shouldn't end with a question mark." - (let ((servers (cl-loop for servers - being hash-values of eglot--servers-by-project - append servers)) - (name (lambda (srv) - (format "%s/%s" (eglot-project-nickname srv) - (eglot--major-mode srv))))) - (cond ((null servers) - (eglot--error "No servers!")) - ((or (cdr servers) (not dont-if-just-the-one)) - (let* ((default (when-let ((current (eglot-current-server))) - (funcall name current))) - (read (completing-read - (if default - (format "%s (default %s)? " prompt default) - (concat prompt "? ")) - (mapcar name servers) - nil t - nil nil - default))) - (cl-find read servers :key name :test #'equal))) - (t (car servers))))) - - -;;; Minor modes -;;; -(defvar eglot-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [remap display-local-help] 'eldoc-doc-buffer) - map)) - -(defvar-local eglot--current-flymake-report-fn nil - "Current flymake report function for this buffer") - -(defvar-local eglot--saved-bindings nil - "Bindings saved by `eglot--setq-saving'.") - -(defvar eglot-stay-out-of '() - "List of Emacs things that Eglot should try to stay of. -Each element is a string, a symbol, or a regexp which is matched -against a variable's name. Examples include the string -\"company\" or the symbol `xref'. - -Before Eglot starts \"managing\" a particular buffer, it -opinionatedly sets some peripheral Emacs facilites, such as -Flymake, Xref and Company. These overriding settings help ensure -consistent Eglot behaviour and only stay in place until -\"managing\" stops (usually via `eglot-shutdown'), whereupon the -previous settings are restored. - -However, if you wish for Eglot to stay out of a particular Emacs -facility that you'd like to keep control of add an element to -this list and Eglot will refrain from setting it. - -For example, to keep your Company customization use - -(add-to-list 'eglot-stay-out-of 'company)") - -(defun eglot--stay-out-of-p (symbol) - "Tell if EGLOT should stay of of SYMBOL." - (cl-find (symbol-name symbol) eglot-stay-out-of - :test (lambda (s thing) - (let ((re (if (symbolp thing) (symbol-name thing) thing))) - (string-match re s))))) - -(defmacro eglot--setq-saving (symbol binding) - `(unless (or (not (boundp ',symbol)) (eglot--stay-out-of-p ',symbol)) - (push (cons ',symbol (symbol-value ',symbol)) eglot--saved-bindings) - (setq-local ,symbol ,binding))) - -(defvar-local eglot--cached-server nil - "A cached reference to the current EGLOT server.") - -(defun eglot-managed-p () - "Tell if current buffer is managed by EGLOT." - eglot--managed-mode) - -(make-obsolete-variable - 'eglot--managed-mode-hook 'eglot-managed-mode-hook "1.6") - -(defvar eglot-managed-mode-hook nil - "A hook run by EGLOT after it started/stopped managing a buffer. -Use `eglot-managed-p' to determine if current buffer is managed.") - -(define-minor-mode eglot--managed-mode - "Mode for source buffers managed by some EGLOT project." - nil nil eglot-mode-map - (cond - (eglot--managed-mode - (add-hook 'after-change-functions 'eglot--after-change nil t) - (add-hook 'before-change-functions 'eglot--before-change nil t) - (add-hook 'kill-buffer-hook #'eglot--managed-mode-off nil t) - ;; Prepend "didClose" to the hook after the "nonoff", so it will run first - (add-hook 'kill-buffer-hook 'eglot--signal-textDocument/didClose nil t) - (add-hook 'before-revert-hook 'eglot--signal-textDocument/didClose nil t) - (add-hook 'after-revert-hook 'eglot--after-revert-hook nil t) - (add-hook 'before-save-hook 'eglot--signal-textDocument/willSave nil t) - (add-hook 'after-save-hook 'eglot--signal-textDocument/didSave nil t) - (unless (eglot--stay-out-of-p 'xref) - (add-hook 'xref-backend-functions 'eglot-xref-backend nil t)) - (add-hook 'completion-at-point-functions #'eglot-completion-at-point nil t) - (add-hook 'change-major-mode-hook #'eglot--managed-mode-off nil t) - (add-hook 'post-self-insert-hook 'eglot--post-self-insert-hook nil t) - (add-hook 'pre-command-hook 'eglot--pre-command-hook nil t) - (eglot--setq-saving eldoc-documentation-functions - '(eglot-signature-eldoc-function - eglot-hover-eldoc-function)) - (eglot--setq-saving eldoc-documentation-strategy - #'eldoc-documentation-enthusiast) - (eglot--setq-saving xref-prompt-for-identifier nil) - (eglot--setq-saving flymake-diagnostic-functions '(eglot-flymake-backend t)) - (eglot--setq-saving company-backends '(company-capf)) - (eglot--setq-saving company-tooltip-align-annotations t) - (unless (eglot--stay-out-of-p 'imenu) - (add-function :before-until (local 'imenu-create-index-function) - #'eglot-imenu)) - (flymake-mode 1) - (eldoc-mode 1) - (cl-pushnew (current-buffer) (eglot--managed-buffers eglot--cached-server))) - (t - (remove-hook 'after-change-functions 'eglot--after-change t) - (remove-hook 'before-change-functions 'eglot--before-change t) - (remove-hook 'kill-buffer-hook #'eglot--managed-mode-off t) - (remove-hook 'kill-buffer-hook 'eglot--signal-textDocument/didClose t) - (remove-hook 'before-revert-hook 'eglot--signal-textDocument/didClose t) - (remove-hook 'after-revert-hook 'eglot--after-revert-hook t) - (remove-hook 'before-save-hook 'eglot--signal-textDocument/willSave t) - (remove-hook 'after-save-hook 'eglot--signal-textDocument/didSave t) - (remove-hook 'xref-backend-functions 'eglot-xref-backend t) - (remove-hook 'completion-at-point-functions #'eglot-completion-at-point t) - (remove-hook 'change-major-mode-hook #'eglot--managed-mode-off t) - (remove-hook 'post-self-insert-hook 'eglot--post-self-insert-hook t) - (remove-hook 'pre-command-hook 'eglot--pre-command-hook t) - (cl-loop for (var . saved-binding) in eglot--saved-bindings - do (set (make-local-variable var) saved-binding)) - (remove-function (local 'imenu-create-index-function) #'eglot-imenu) - (setq eglot--current-flymake-report-fn nil) - (let ((server eglot--cached-server)) - (setq eglot--cached-server nil) - (when server - (setf (eglot--managed-buffers server) - (delq (current-buffer) (eglot--managed-buffers server))) - (when (and eglot-autoshutdown - (null (eglot--managed-buffers server))) - (eglot-shutdown server)))))) - ;; Note: the public hook runs before the internal eglot--managed-mode-hook. - (run-hooks 'eglot-managed-mode-hook)) - -(defun eglot--managed-mode-off () - "Turn off `eglot--managed-mode' unconditionally." - (eglot--managed-mode -1)) - -(defun eglot-current-server () - "Return logical EGLOT server for current buffer, nil if none." - eglot--cached-server) - -(defun eglot--current-server-or-lose () - "Return current logical EGLOT server connection or error." - (or eglot--cached-server - (jsonrpc-error "No current JSON-RPC connection"))) - -(defvar-local eglot--unreported-diagnostics nil - "Unreported Flymake diagnostics for this buffer.") - -(defvar revert-buffer-preserve-modes) -(defun eglot--after-revert-hook () - "Eglot's `after-revert-hook'." - (when revert-buffer-preserve-modes (eglot--signal-textDocument/didOpen))) - -(defun eglot--maybe-activate-editing-mode () - "Maybe activate `eglot--managed-mode'. - -If it is activated, also signal textDocument/didOpen." - (unless eglot--managed-mode - ;; Called when `revert-buffer-in-progress-p' is t but - ;; `revert-buffer-preserve-modes' is nil. - (when (and buffer-file-name - (or - eglot--cached-server - (setq eglot--cached-server - (cl-find major-mode - (gethash (or (project-current) - `(transient . ,default-directory)) - eglot--servers-by-project) - :key #'eglot--major-mode)))) - (setq eglot--unreported-diagnostics `(:just-opened . nil)) - (eglot--managed-mode) - (eglot--signal-textDocument/didOpen)))) - -(add-hook 'find-file-hook 'eglot--maybe-activate-editing-mode) -(add-hook 'after-change-major-mode-hook 'eglot--maybe-activate-editing-mode) - -(defun eglot-clear-status (server) - "Clear the last JSONRPC error for SERVER." - (interactive (list (eglot--current-server-or-lose))) - (setf (jsonrpc-last-error server) nil)) - - -;;; Mode-line, menu and other sugar -;;; -(defvar eglot--mode-line-format `(:eval (eglot--mode-line-format))) - -(put 'eglot--mode-line-format 'risky-local-variable t) - -(defun eglot--mouse-call (what) - "Make an interactive lambda for calling WHAT from mode-line." - (lambda (event) - (interactive "e") - (let ((start (event-start event))) (with-selected-window (posn-window start) - (save-excursion - (goto-char (or (posn-point start) - (point))) - (call-interactively what) - (force-mode-line-update t)))))) - -(defun eglot--mode-line-props (thing face defs &optional prepend) - "Helper for function `eglot--mode-line-format'. -Uses THING, FACE, DEFS and PREPEND." - (cl-loop with map = (make-sparse-keymap) - for (elem . rest) on defs - for (key def help) = elem - do (define-key map `[mode-line ,key] (eglot--mouse-call def)) - concat (format "%s: %s" key help) into blurb - when rest concat "\n" into blurb - finally (return `(:propertize ,thing - face ,face - keymap ,map help-echo ,(concat prepend blurb) - mouse-face mode-line-highlight)))) - -(defun eglot--mode-line-format () - "Compose the EGLOT's mode-line." - (pcase-let* ((server (eglot-current-server)) - (nick (and server (eglot-project-nickname server))) - (pending (and server (hash-table-count - (jsonrpc--request-continuations server)))) - (`(,_id ,doing ,done-p ,_detail) (and server (eglot--spinner server))) - (last-error (and server (jsonrpc-last-error server)))) - (append - `(,(eglot--mode-line-props "eglot" 'eglot-mode-line nil)) - (when nick - `(":" ,(eglot--mode-line-props - nick 'eglot-mode-line - '((C-mouse-1 eglot-stderr-buffer "go to stderr buffer") - (mouse-1 eglot-events-buffer "go to events buffer") - (mouse-2 eglot-shutdown "quit server") - (mouse-3 eglot-reconnect "reconnect to server"))) - ,@(when last-error - `("/" ,(eglot--mode-line-props - "error" 'compilation-mode-line-fail - '((mouse-3 eglot-clear-status "clear this status")) - (format "An error occured: %s\n" (plist-get last-error - :message))))) - ,@(when (and doing (not done-p)) - `("/" ,(eglot--mode-line-props doing - 'compilation-mode-line-run '()))) - ,@(when (cl-plusp pending) - `("/" ,(eglot--mode-line-props - (format "%d" pending) 'warning - '((mouse-3 eglot-forget-pending-continuations - "forget pending continuations")))))))))) - -(add-to-list 'mode-line-misc-info - `(eglot--managed-mode (" [" eglot--mode-line-format "] "))) - -(put 'eglot-note 'flymake-category 'flymake-note) -(put 'eglot-warning 'flymake-category 'flymake-warning) -(put 'eglot-error 'flymake-category 'flymake-error) - -(defalias 'eglot--make-diag 'flymake-make-diagnostic) -(defalias 'eglot--diag-data 'flymake-diagnostic-data) - -(cl-loop for i from 1 - for type in '(eglot-note eglot-warning eglot-error ) - do (put type 'flymake-overlay-control - `((mouse-face . highlight) - (priority . ,(+ 50 i)) - (keymap . ,(let ((map (make-sparse-keymap))) - (define-key map [mouse-1] - (eglot--mouse-call 'eglot-code-actions)) - map))))) - - -;;; Protocol implementation (Requests, notifications, etc) -;;; -(cl-defmethod eglot-handle-notification - (_server method &key &allow-other-keys) - "Handle unknown notification" - (unless (or (string-prefix-p "$" (format "%s" method)) - (not (memq 'disallow-unknown-methods eglot-strict-mode))) - (eglot--warn "Server sent unknown notification method `%s'" method))) - -(cl-defmethod eglot-handle-request - (_server method &key &allow-other-keys) - "Handle unknown request" - (when (memq 'disallow-unknown-methods eglot-strict-mode) - (jsonrpc-error "Unknown request method `%s'" method))) - -(cl-defmethod eglot-execute-command - (server command arguments) - "Execute COMMAND on SERVER with `:workspace/executeCommand'. -COMMAND is a symbol naming the command." - (jsonrpc-request server :workspace/executeCommand - `(:command ,(format "%s" command) :arguments ,arguments))) - -(cl-defmethod eglot-handle-notification - (_server (_method (eql window/showMessage)) &key type message) - "Handle notification window/showMessage" - (eglot--message (propertize "Server reports (type=%s): %s" - 'face (if (<= type 1) 'error)) - type message)) - -(cl-defmethod eglot-handle-request - (_server (_method (eql window/showMessageRequest)) &key type message actions) - "Handle server request window/showMessageRequest" - (let ((label (completing-read - (concat - (format (propertize "[eglot] Server reports (type=%s): %s" - 'face (if (<= type 1) 'error)) - type message) - "\nChoose an option: ") - (or (mapcar (lambda (obj) (plist-get obj :title)) actions) - '("OK")) - nil t (plist-get (elt actions 0) :title)))) - (if label `(:title ,label) :null))) - -(cl-defmethod eglot-handle-notification - (_server (_method (eql window/logMessage)) &key _type _message) - "Handle notification window/logMessage") ;; noop, use events buffer - -(cl-defmethod eglot-handle-notification - (_server (_method (eql telemetry/event)) &rest _any) - "Handle notification telemetry/event") ;; noop, use events buffer - -(cl-defmethod eglot-handle-notification - (server (_method (eql textDocument/publishDiagnostics)) &key uri diagnostics - &allow-other-keys) ; FIXME: doesn't respect `eglot-strict-mode' - "Handle notification publishDiagnostics" - (if-let ((buffer (find-buffer-visiting (eglot--uri-to-path uri)))) - (with-current-buffer buffer - (cl-loop - for diag-spec across diagnostics - collect (eglot--dbind ((Diagnostic) range message severity source) - diag-spec - (setq message (concat source ": " message)) - (pcase-let - ((sev severity) - (`(,beg . ,end) (eglot--range-region range))) - ;; Fallback to `flymake-diag-region' if server - ;; botched the range - (when (= beg end) - (if-let* ((st (plist-get range :start)) - (diag-region - (flymake-diag-region - (current-buffer) (1+ (plist-get st :line)) - (plist-get st :character)))) - (setq beg (car diag-region) end (cdr diag-region)) - (eglot--widening - (goto-char (point-min)) - (setq beg - (point-at-bol - (1+ (plist-get (plist-get range :start) :line)))) - (setq end - (point-at-eol - (1+ (plist-get (plist-get range :end) :line))))))) - (eglot--make-diag (current-buffer) beg end - (cond ((<= sev 1) 'eglot-error) - ((= sev 2) 'eglot-warning) - (t 'eglot-note)) - message `((eglot-lsp-diag . ,diag-spec))))) - into diags - finally (cond ((and flymake-mode eglot--current-flymake-report-fn) - (save-restriction - (widen) - (funcall eglot--current-flymake-report-fn diags - ;; If the buffer hasn't changed since last - ;; call to the report function, flymake won't - ;; delete old diagnostics. Using :region - ;; keyword forces flymake to delete - ;; them (github#159). - :region (cons (point-min) (point-max)))) - (setq eglot--unreported-diagnostics nil)) - (t - (setq eglot--unreported-diagnostics (cons t diags)))))) - (jsonrpc--debug server "Diagnostics received for unvisited %s" uri))) - -(cl-defun eglot--register-unregister (server things how) - "Helper for `registerCapability'. -THINGS are either registrations or unregisterations (sic)." - (cl-loop - for thing in (cl-coerce things 'list) - do (eglot--dbind ((Registration) id method registerOptions) thing - (apply (cl-ecase how - (register 'eglot-register-capability) - (unregister 'eglot-unregister-capability)) - server (intern method) id registerOptions)))) - -(cl-defmethod eglot-handle-request - (server (_method (eql client/registerCapability)) &key registrations) - "Handle server request client/registerCapability" - (eglot--register-unregister server registrations 'register)) - -(cl-defmethod eglot-handle-request - (server (_method (eql client/unregisterCapability)) - &key unregisterations) ;; XXX: "unregisterations" (sic) - "Handle server request client/unregisterCapability" - (eglot--register-unregister server unregisterations 'unregister)) - -(cl-defmethod eglot-handle-request - (_server (_method (eql workspace/applyEdit)) &key _label edit) - "Handle server request workspace/applyEdit" - (eglot--apply-workspace-edit edit eglot-confirm-server-initiated-edits)) - -(defun eglot--TextDocumentIdentifier () - "Compute TextDocumentIdentifier object for current buffer." - `(:uri ,(eglot--path-to-uri (or buffer-file-name - (ignore-errors - (buffer-file-name - (buffer-base-buffer))))))) - -(defvar-local eglot--versioned-identifier 0) - -(defun eglot--VersionedTextDocumentIdentifier () - "Compute VersionedTextDocumentIdentifier object for current buffer." - (append (eglot--TextDocumentIdentifier) - `(:version ,eglot--versioned-identifier))) - -(defun eglot--TextDocumentItem () - "Compute TextDocumentItem object for current buffer." - (append - (eglot--VersionedTextDocumentIdentifier) - (list :languageId - (if (string-match "\\(.*\\)-mode" (symbol-name major-mode)) - (match-string 1 (symbol-name major-mode)) - "unknown") - :text - (eglot--widening - (buffer-substring-no-properties (point-min) (point-max)))))) - -(defun eglot--TextDocumentPositionParams () - "Compute TextDocumentPositionParams." - (list :textDocument (eglot--TextDocumentIdentifier) - :position (eglot--pos-to-lsp-position))) - -(defvar-local eglot--last-inserted-char nil - "If non-nil, value of the last inserted character in buffer.") - -(defun eglot--post-self-insert-hook () - "Set `eglot--last-inserted-char'." - (setq eglot--last-inserted-char last-input-event)) - -(defun eglot--pre-command-hook () - "Reset `eglot--last-inserted-char'." - (setq eglot--last-inserted-char nil)) - -(defun eglot--CompletionParams () - (append - (eglot--TextDocumentPositionParams) - `(:context - ,(if-let (trigger (and (characterp eglot--last-inserted-char) - (cl-find eglot--last-inserted-char - (eglot--server-capable :completionProvider - :triggerCharacters) - :key (lambda (str) (aref str 0)) - :test #'char-equal))) - `(:triggerKind 2 :triggerCharacter ,trigger) `(:triggerKind 1))))) - -(defvar-local eglot--recent-changes nil - "Recent buffer changes as collected by `eglot--before-change'.") - -(cl-defmethod jsonrpc-connection-ready-p ((_server eglot-lsp-server) _what) - "Tell if SERVER is ready for WHAT in current buffer." - (and (cl-call-next-method) (not eglot--recent-changes))) - -(defvar-local eglot--change-idle-timer nil "Idle timer for didChange signals.") - -(defun eglot--before-change (beg end) - "Hook onto `before-change-functions' with BEG and END." - (when (listp eglot--recent-changes) - ;; Records BEG and END, crucially convert them into LSP - ;; (line/char) positions before that information is lost (because - ;; the after-change thingy doesn't know if newlines were - ;; deleted/added). Also record markers of BEG and END - ;; (github#259) - (push `(,(eglot--pos-to-lsp-position beg) - ,(eglot--pos-to-lsp-position end) - (,beg . ,(copy-marker beg nil)) - (,end . ,(copy-marker end t))) - eglot--recent-changes))) - -(defun eglot--after-change (beg end pre-change-length) - "Hook onto `after-change-functions'. -Records BEG, END and PRE-CHANGE-LENGTH locally." - (cl-incf eglot--versioned-identifier) - (pcase (and (listp eglot--recent-changes) - (car eglot--recent-changes)) - (`(,lsp-beg ,lsp-end - (,b-beg . ,b-beg-marker) - (,b-end . ,b-end-marker)) - ;; github#259 and github#367: With `capitalize-word' or somesuch, - ;; `before-change-functions' always records the whole word's - ;; `b-beg' and `b-end'. Similarly, when coalescing two lines - ;; into one, `fill-paragraph' they mark the end of the first line - ;; up to the end of the second line. In both situations, args - ;; received here contradict that information: `beg' and `end' - ;; will differ by 1 and will likely only encompass the letter - ;; that was capitalized or, in the sentence-joining situation, - ;; the replacement of the newline with a space. That's we keep - ;; markers _and_ positions so we're able to detect and correct - ;; this. We ignore `beg', `len' and `pre-change-len' and send - ;; "fuller" information about the region from the markers. I've - ;; also experimented with doing this unconditionally but it seems - ;; to break when newlines are added. - (if (and (= b-end b-end-marker) (= b-beg b-beg-marker) - (or (/= beg b-beg) (/= end b-end))) - (setcar eglot--recent-changes - `(,lsp-beg ,lsp-end ,(- b-end-marker b-beg-marker) - ,(buffer-substring-no-properties b-beg-marker - b-end-marker))) - (setcar eglot--recent-changes - `(,lsp-beg ,lsp-end ,pre-change-length - ,(buffer-substring-no-properties beg end))))) - (_ (setf eglot--recent-changes :emacs-messup))) - (when eglot--change-idle-timer (cancel-timer eglot--change-idle-timer)) - (let ((buf (current-buffer))) - (setq eglot--change-idle-timer - (run-with-idle-timer - eglot-send-changes-idle-time - nil (lambda () (eglot--when-live-buffer buf - (when eglot--managed-mode - (eglot--signal-textDocument/didChange) - (setq eglot--change-idle-timer nil)))))))) - -;; HACK! Launching a deferred sync request with outstanding changes is a -;; bad idea, since that might lead to the request never having a -;; chance to run, because `jsonrpc-connection-ready-p'. -(advice-add #'jsonrpc-request :before - (cl-function (lambda (_proc _method _params &key - deferred &allow-other-keys) - (when (and eglot--managed-mode deferred) - (eglot--signal-textDocument/didChange)))) - '((name . eglot--signal-textDocument/didChange))) - -(defvar-local eglot-workspace-configuration () - "Alist of (SECTION . VALUE) entries configuring the LSP server. -SECTION should be a keyword or a string, value can be anything -that can be converted to JSON.") - -(put 'eglot-workspace-configuration 'safe-local-variable 'listp) - -(defun eglot-signal-didChangeConfiguration (server) - "Send a `:workspace/didChangeConfiguration' signal to SERVER. -When called interactively, use the currently active server" - (interactive (list (eglot--current-server-or-lose))) - (jsonrpc-notify - server :workspace/didChangeConfiguration - (list - :settings - (cl-loop for (section . v) in eglot-workspace-configuration - collect (if (keywordp section) - section - (intern (format ":%s" section))) - collect v)))) - -(cl-defmethod eglot-handle-request - (server (_method (eql workspace/configuration)) &key items) - "Handle server request workspace/configuration." - (apply #'vector - (mapcar - (eglot--lambda ((ConfigurationItem) scopeUri section) - (with-temp-buffer - (let* ((uri-path (eglot--uri-to-path scopeUri)) - (default-directory - (if (and (not (string-empty-p uri-path)) - (file-directory-p uri-path)) - uri-path - (project-root (eglot--project server))))) - (setq-local major-mode (eglot--major-mode server)) - (hack-dir-local-variables-non-file-buffer) - (alist-get section eglot-workspace-configuration - nil nil - (lambda (wsection section) - (string= - (if (keywordp wsection) - (substring (symbol-name wsection) 1) - wsection) - section)))))) - items))) - -(defun eglot--signal-textDocument/didChange () - "Send textDocument/didChange to server." - (when eglot--recent-changes - (let* ((server (eglot--current-server-or-lose)) - (sync-capability (eglot--server-capable :textDocumentSync)) - (sync-kind (if (numberp sync-capability) sync-capability - (plist-get sync-capability :change))) - (full-sync-p (or (eq sync-kind 1) - (eq :emacs-messup eglot--recent-changes)))) - (jsonrpc-notify - server :textDocument/didChange - (list - :textDocument (eglot--VersionedTextDocumentIdentifier) - :contentChanges - (if full-sync-p - (vector `(:text ,(eglot--widening - (buffer-substring-no-properties (point-min) -