config

Personal configuration.
git clone git://code.dwrz.net/config
Log | Files | Refs

embark.el (191373B)


      1 ;;; embark.el --- Conveniently act on minibuffer completions   -*- lexical-binding: t; -*-
      2 
      3 ;; Copyright (C) 2021-2023  Free Software Foundation, Inc.
      4 
      5 ;; Author: Omar Antolín Camarena <omar@matem.unam.mx>
      6 ;; Maintainer: Omar Antolín Camarena <omar@matem.unam.mx>
      7 ;; Keywords: convenience
      8 ;; Package-Version: 20241003.1953
      9 ;; Package-Revision: d2daad08e040
     10 ;; Homepage: https://github.com/oantolin/embark
     11 ;; Package-Requires: ((emacs "28.1") (compat "30"))
     12 
     13 ;; This file is part of GNU Emacs.
     14 
     15 ;; This program is free software; you can redistribute it and/or modify
     16 ;; it under the terms of the GNU General Public License as published by
     17 ;; the Free Software Foundation, either version 3 of the License, or
     18 ;; (at your option) any later version.
     19 
     20 ;; This program is distributed in the hope that it will be useful,
     21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
     22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     23 ;; GNU General Public License for more details.
     24 
     25 ;; You should have received a copy of the GNU General Public License
     26 ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
     27 
     28 ;;; Commentary:
     29 
     30 ;; This package provides a sort of right-click contextual menu for
     31 ;; Emacs, accessed through the `embark-act' command (which you should
     32 ;; bind to a convenient key), offering you relevant actions to use on
     33 ;; a target determined by the context:
     34 
     35 ;; - In the minibuffer, the target is the current best completion
     36 ;;  candidate.
     37 ;; - In the `*Completions*' buffer the target is the completion at point.
     38 ;; - In a regular buffer, the target is the region if active, or else the
     39 ;;  file, symbol or url at point.
     40 
     41 ;; The type of actions offered depend on the type of the target:
     42 
     43 ;; - For files you get offered actions like deleting, copying,
     44 ;;  renaming, visiting in another window, running a shell command on the
     45 ;;  file, etc.
     46 ;; - For buffers the actions include switching to or killing the buffer.
     47 ;; - For package names the actions include installing, removing or
     48 ;;  visiting the homepage.
     49 
     50 ;; Everything is easily configurable: determining the current target,
     51 ;; classifying it, and deciding with actions are offered for each type
     52 ;; in the classification.  The above introduction just mentions part of
     53 ;; the default configuration.
     54 
     55 ;; Configuring which actions are offered for a type is particularly
     56 ;; easy and requires no programming: the `embark-keymap-alist'
     57 ;; variable associates target types with variable containing keymaps,
     58 ;; and those keymaps containing binds for the actions.  For example,
     59 ;; in the default configuration the type `file' is associated with the
     60 ;; symbol `embark-file-map'.  That symbol names a keymap with
     61 ;; single-letter key bindings for common Emacs file commands, for
     62 ;; instance `c' is bound to `copy-file'.  This means that if while you
     63 ;; are in the minibuffer after running a command that prompts for a
     64 ;; file, such as `find-file' or `rename-file', you can copy a file by
     65 ;; running `embark-act' and then pressing `c'.
     66 
     67 ;; These action keymaps are very convenient but not strictly necessary
     68 ;; when using `embark-act': you can use any command that reads from the
     69 ;; minibuffer as an action and the target of the action will be inserted
     70 ;; at the first minibuffer prompt.  After running `embark-act' all of your
     71 ;; key bindings and even `execute-extended-command' can be used to run a
     72 ;; command.  The action keymaps are normal Emacs keymaps and you should
     73 ;; feel free to bind in them whatever commands you find useful as actions.
     74 
     75 ;; The actions in `embark-general-map' are available no matter what
     76 ;; type of completion you are in the middle of.  By default this
     77 ;; includes bindings to save the current candidate in the kill ring
     78 ;; and to insert the current candidate in the previously selected
     79 ;; buffer (the buffer that was current when you executed a command
     80 ;; that opened up the minibuffer).
     81 
     82 ;; You can read about the Embark GitHub project wiki:
     83 ;; https://github.com/oantolin/embark/wiki/Default-Actions
     84 
     85 ;; Besides acting individually on targets, Embark lets you work
     86 ;; collectively on a set of target candidates.  For example, while
     87 ;; you are in the minibuffer the candidates are simply the possible
     88 ;; completions of your input.  Embark provides three commands to work
     89 ;; on candidate sets:
     90 
     91 ;; - The `embark-act-all' command runs the same action on each of the
     92 ;;   current candidates.  It is just like using `embark-act' on each
     93 ;;   candidate in turn.
     94 
     95 ;; - The `embark-collect' command produces a buffer listing all
     96 ;;   candidates, for you to peruse and run actions on at your leisure.
     97 ;;   The candidates are displayed as a list showing additional
     98 ;;   annotations.
     99 
    100 ;; - The `embark-export' command tries to open a buffer in an
    101 ;;   appropriate major mode for the set of candidates.  If the
    102 ;;   candidates are files export produces a Dired buffer; if they are
    103 ;;   buffers, you get an Ibuffer buffer; and if they are packages you
    104 ;;   get a buffer in package menu mode.
    105 
    106 ;; These are always available as "actions" (although they do not act
    107 ;; on just the current target but on all candidates) for embark-act
    108 ;; and are bound to A, S (for "snapshot") and E, respectively, in
    109 ;; embark-general-map.  This means that you do not have to bind your
    110 ;; own key bindings for these (although you can, of course), just a
    111 ;; key binding for `embark-act'.
    112 
    113 ;;; Code:
    114 
    115 (require 'compat)
    116 (eval-when-compile (require 'subr-x))
    117 
    118 (require 'ffap) ; used to recognize file and url targets
    119 
    120 ;;; User facing options
    121 
    122 (defgroup embark nil
    123   "Emacs Mini-Buffer Actions Rooted in Keymaps."
    124   :link '(info-link :tag "Info Manual" "(embark)")
    125   :link '(url-link :tag "Homepage" "https://github.com/oantolin/embark")
    126   :link '(emacs-library-link :tag "Library Source" "embark.el")
    127   :group 'minibuffer
    128   :prefix "embark-")
    129 
    130 (defcustom embark-keymap-alist
    131   '((file embark-file-map)
    132     (library embark-library-map)
    133     (environment-variables embark-file-map) ; they come up in file completion
    134     (url embark-url-map)
    135     (email embark-email-map)
    136     (buffer embark-buffer-map)
    137     (tab embark-tab-map)
    138     (expression embark-expression-map)
    139     (identifier embark-identifier-map)
    140     (defun embark-defun-map)
    141     (symbol embark-symbol-map)
    142     (face embark-face-map)
    143     (command embark-command-map)
    144     (variable embark-variable-map)
    145     (function embark-function-map)
    146     (minor-mode embark-command-map)
    147     (unicode-name embark-unicode-name-map)
    148     (package embark-package-map)
    149     (bookmark embark-bookmark-map)
    150     (region embark-region-map)
    151     (sentence embark-sentence-map)
    152     (paragraph embark-paragraph-map)
    153     (kill-ring embark-kill-ring-map)
    154     (heading embark-heading-map)
    155     (flymake embark-flymake-map)
    156     (smerge smerge-basic-map embark-general-map)
    157     (t embark-general-map))
    158   "Alist of action types and corresponding keymaps.
    159 The special key t is associated with the default keymap to use.
    160 Each value can be either a single symbol whose value is a keymap,
    161 or a list of such symbols."
    162   :type '(alist :key-type (symbol :tag "Target type")
    163                 :value-type (choice (variable :tag "Keymap")
    164                              (repeat :tag "Keymaps" variable))))
    165 
    166 (defcustom embark-target-finders
    167   '(embark-target-top-minibuffer-candidate
    168     embark-target-active-region
    169     embark-target-collect-candidate
    170     embark-target-completion-list-candidate
    171     embark-target-text-heading-at-point
    172     embark-target-bug-reference-at-point
    173     embark-target-flymake-at-point
    174     embark-target-smerge-at-point
    175     embark-target-package-at-point
    176     embark-target-email-at-point
    177     embark-target-url-at-point
    178     embark-target-file-at-point
    179     embark-target-custom-variable-at-point
    180     embark-target-identifier-at-point
    181     embark-target-guess-file-at-point
    182     embark-target-expression-at-point
    183     embark-target-sentence-at-point
    184     embark-target-paragraph-at-point
    185     embark-target-defun-at-point
    186     embark-target-prog-heading-at-point)
    187   "List of functions to determine the target in current context.
    188 Each function should take no arguments and return one of:
    189 
    190 1. a cons (TYPE . TARGET) where TARGET is a string and TYPE is a
    191    symbol (which is looked up in `embark-keymap-alist' to
    192    determine which additional keybindings for actions to setup);
    193 
    194 2. a dotted list of the form (TYPE TARGET START . END), where
    195    START and END are the buffer positions bounding TARGET, used
    196    for highlighting; or
    197 
    198 3. a possibly empty list of targets, each of type 1 or 2 (in
    199    particular if a target finder does not find any targets, it
    200    should return nil)."
    201   :type 'hook)
    202 
    203 (defcustom embark-transformer-alist
    204   '((minor-mode . embark--lookup-lighter-minor-mode)
    205     (embark-keybinding . embark--keybinding-command)
    206     (project-file . embark--project-file-full-path)
    207     (package . embark--remove-package-version)
    208     (multi-category . embark--refine-multi-category)
    209     (file . embark--simplify-path))
    210   "Alist associating type to functions for transforming targets.
    211 Each function should take a type and a target string and return a
    212 pair of the form a `cons' of the new type and the new target."
    213   :type '(alist :key-type symbol :value-type function))
    214 
    215 (defcustom embark-become-keymaps
    216   '(embark-become-help-map
    217     embark-become-file+buffer-map
    218     embark-become-shell-command-map
    219     embark-become-match-map)
    220   "List of keymaps for `embark-become'.
    221 Each keymap groups a set of related commands that can
    222 conveniently become one another."
    223   :type '(repeat variable))
    224 
    225 (defcustom embark-prompter 'embark-keymap-prompter
    226   "Function used to prompt the user for actions.
    227 This should be set to a function that prompts the use for an
    228 action and returns the symbol naming the action command.  The
    229 default value, `embark-keymap-prompter' activates the type
    230 specific action keymap given in `embark-keymap-alist'.
    231 There is also `embark-completing-read-prompter' which
    232 prompts for an action with completion."
    233   :type '(choice (const :tag "Use action keymaps" embark-keymap-prompter)
    234                  (const :tag "Read action with completion"
    235                         embark-completing-read-prompter)
    236                  (function :tag "Other")))
    237 
    238 (defcustom embark-keymap-prompter-key "@"
    239   "Key to switch to the keymap prompter from `embark-completing-read-prompter'.
    240 
    241 The key must be either nil or a string.  The
    242 string must be accepted by `key-valid-p'."
    243   :type '(choice key (const :tag "None" nil)))
    244 
    245 (defcustom embark-cycle-key nil
    246   "Key used for `embark-cycle'.
    247 
    248 If the key is set to nil it defaults to the global binding of
    249 `embark-act'.  The key must be a string which is accepted by
    250 `key-valid-p'."
    251   :type '(choice key (const :tag "Use embark-act key" nil)))
    252 
    253 (defcustom embark-help-key "C-h"
    254   "Key used for help.
    255 
    256 The key must be either nil or a string.  The
    257 string must be accepted by `key-valid-p'."
    258   :type '(choice (const "C-h")
    259                  (const "?")
    260                  (const :tag "None" nil)
    261                  key))
    262 
    263 (defcustom embark-keybinding-repeat
    264   (propertize "*" 'face 'embark-keybinding-repeat)
    265   "Indicator string for repeatable keybindings.
    266 Keybindings are formatted by the `completing-read' prompter and
    267 the verbose indicator."
    268   :type 'string)
    269 
    270 (defface embark-keybinding-repeat
    271   '((t :inherit font-lock-builtin-face))
    272   "Face used to indicate keybindings as repeatable.")
    273 
    274 (defface embark-keybinding '((t :inherit success))
    275   "Face used to display key bindings.
    276 Used by `embark-completing-read-prompter' and `embark-keymap-help'.")
    277 
    278 (defface embark-keymap '((t :slant italic))
    279   "Face used to display keymaps.
    280 Used by `embark-completing-read-prompter' and `embark-keymap-help'.")
    281 
    282 (defface embark-target '((t :inherit highlight))
    283   "Face used to highlight the target at point during `embark-act'.")
    284 
    285 (defcustom embark-quit-after-action t
    286   "Should `embark-act' quit the minibuffer?
    287 This controls whether calling `embark-act' without a prefix
    288 argument quits the minibuffer or not.  You can always get the
    289 opposite behavior to that indicated by this variable by calling
    290 `embark-act' with \\[universal-argument].
    291 
    292 Note that `embark-act' can also be called from outside the
    293 minibuffer and this variable is irrelevant in that case.
    294 
    295 In addition to t or nil this variable can also be set to an
    296 alist to specify the minibuffer quitting behavior per command.
    297 In the alist case one can additionally use the key t to
    298 prescribe a default for commands not used as alist keys."
    299   :type '(choice (const :tag "Always quit" t)
    300                  (const :tag "Never quit" nil)
    301                  (alist :tag "Configure per action"
    302                         :key-type (choice (function :tag "Action")
    303                                           (const :tag "All other actions" t))
    304                         :value-type (choice (const :tag "Quit" t)
    305                                             (const :tag "Do not quit" nil)))))
    306 
    307 (defcustom embark-confirm-act-all t
    308   "Should `embark-act-all' prompt the user for confirmation?
    309 Even if this variable is nil you may still be prompted to confirm
    310 some uses of `embark-act-all', namely, for those actions whose
    311 entry in `embark-pre-action-hooks' includes `embark--confirm'."
    312   :type 'boolean)
    313 
    314 (defcustom embark-default-action-overrides nil
    315   "Alist associating target types with overriding default actions.
    316 When the source of a target is minibuffer completion, the default
    317 action for it is usually the command that opened the minibuffer
    318 in the first place but this can be overridden for a given type by
    319 an entry in this list.
    320 
    321 For example, if you run `delete-file' the default action for its
    322 completion candidates is `delete-file' itself.  You may prefer to
    323 make `find-file' the default action for all files, even if they
    324 were obtained from a `delete-file' prompt.  In that case you can
    325 configure that by adding an entry to this variable pairing `file'
    326 with `find-file'.
    327 
    328 In addition to target types, you can also use as keys in this alist,
    329 pairs of a target type and a command name.  Such a pair indicates that
    330 the override only applies if the target was obtained from minibuffer
    331 completion from that command.  For example adding an
    332 entry (cons (cons \\='file \\='delete-file) \\='find-file) to this alist would
    333 indicate that for files at the prompt of the `delete-file' command,
    334 `find-file' should be used as the default action."
    335   :type '(alist :key-type (choice (symbol :tag "Type")
    336                                   (cons (symbol :tag "Type")
    337                                         (symbol :tag "Command")))
    338                 :value-type (function :tag "Default action")))
    339 
    340 (defcustom embark-target-injection-hooks
    341   '((async-shell-command embark--allow-edit embark--shell-prep)
    342     (shell-command embark--allow-edit embark--shell-prep)
    343     (pp-eval-expression embark--eval-prep)
    344     (eval-expression embark--eval-prep)
    345     (package-delete embark--force-complete)
    346     ;; commands evaluating code found in the buffer, which may in turn prompt
    347     (embark-pp-eval-defun embark--ignore-target)
    348     (eval-defun embark--ignore-target)
    349     (eval-last-sexp embark--ignore-target)
    350     (embark-eval-replace embark--ignore-target)
    351     ;; commands which prompt for something that is *not* the target
    352     (write-region embark--ignore-target)
    353     (append-to-file embark--ignore-target)
    354     (append-to-buffer embark--ignore-target)
    355     (shell-command-on-region embark--ignore-target)
    356     (format-encode-region embark--ignore-target)
    357     (format-decode-region embark--ignore-target)
    358     (xref-find-definitions embark--ignore-target)
    359     (xref-find-references embark--ignore-target)
    360     (sort-regexp-fields embark--ignore-target)
    361     (align-regexp embark--ignore-target))
    362   "Alist associating commands with post-injection setup hooks.
    363 For commands appearing as keys in this alist, run the
    364 corresponding value as a setup hook after injecting the target
    365 into in the minibuffer and before acting on it.  The hooks must
    366 accept arbitrary keyword arguments.  The :action command, the
    367 :target string and target :type are always present.  For actions
    368 at point the target :bounds are passed too.  The default pre-action
    369 hook is specified by the entry with key t.  Furthermore, hooks with
    370 the key :always are executed always."
    371   :type '(alist :key-type
    372                 (choice symbol
    373                         (const :tag "Default" t)
    374                         (const :tag "Always" :always))
    375                 :value-type hook))
    376 
    377 (defcustom embark-pre-action-hooks
    378   `(;; commands that need to position point at the beginning or end
    379     (eval-last-sexp embark--end-of-target)
    380     (indent-pp-sexp embark--beginning-of-target)
    381     (backward-up-list embark--beginning-of-target)
    382     (backward-list embark--beginning-of-target)
    383     (forward-list embark--end-of-target)
    384     (forward-sexp embark--end-of-target)
    385     (backward-sexp embark--beginning-of-target)
    386     (raise-sexp embark--beginning-of-target)
    387     (kill-sexp embark--beginning-of-target)
    388     (mark-sexp embark--beginning-of-target)
    389     (transpose-sexps embark--end-of-target)
    390     (transpose-sentences embark--end-of-target)
    391     (transpose-paragraphs embark--end-of-target)
    392     (forward-sentence embark--end-of-target)
    393     (backward-sentence embark--beginning-of-target)
    394     (backward-paragraph embark--beginning-of-target)
    395     (embark-insert embark--end-of-target)
    396     ;; commands we want to be able to jump back from
    397     ;; (embark-find-definition achieves this by calling
    398     ;; xref-find-definitions which pushes the markers itself)
    399     (find-library embark--xref-push-marker)
    400     ;; commands which prompt the user for confirmation before running
    401     (delete-file embark--confirm)
    402     (delete-directory embark--confirm)
    403     (kill-buffer embark--confirm)
    404     (embark-kill-buffer-and-window embark--confirm)
    405     (bookmark-delete embark--confirm)
    406     (package-delete embark--confirm)
    407     (,'tab-bar-close-tab-by-name embark--confirm) ;; Avoid package-lint warning
    408     ;; search for region contents outside said region
    409     (embark-isearch-forward embark--unmark-target)
    410     (embark-isearch-backward embark--unmark-target)
    411     (occur embark--unmark-target)
    412     (query-replace embark--beginning-of-target embark--unmark-target)
    413     (query-replace-regexp embark--beginning-of-target embark--unmark-target)
    414     (replace-string embark--beginning-of-target embark--unmark-target)
    415     (replace-regexp embark--beginning-of-target embark--unmark-target)
    416     ;; mark pseudo-action
    417     (mark embark--mark-target)
    418     ;; shells in new buffers
    419     (shell embark--universal-argument)
    420     (eshell embark--universal-argument))
    421   "Alist associating commands with pre-action hooks.
    422 The hooks are run right before an action is embarked upon.  See
    423 `embark-target-injection-hooks' for information about the hook
    424 arguments and more details."
    425   :type '(alist :key-type
    426                 (choice symbol
    427                         (const :tag "Default" t)
    428                         (const :tag "Always" :always))
    429                 :value-type hook))
    430 
    431 (defcustom embark-post-action-hooks
    432   `((bookmark-delete embark--restart)
    433     (bookmark-rename embark--restart)
    434     (delete-file embark--restart)
    435     (embark-kill-ring-remove embark--restart)
    436     (embark-recentf-remove embark--restart)
    437     (embark-history-remove embark--restart)
    438     (rename-file embark--restart)
    439     (copy-file embark--restart)
    440     (delete-directory embark--restart)
    441     (make-directory embark--restart)
    442     (kill-buffer embark--restart)
    443     (embark-rename-buffer embark--restart)
    444     (,'tab-bar-rename-tab-by-name embark--restart) ;; Avoid package-lint warning
    445     (,'tab-bar-close-tab-by-name embark--restart)
    446     (package-delete embark--restart))
    447   "Alist associating commands with post-action hooks.
    448 The hooks are run after an embarked upon action concludes.  See
    449 `embark-target-injection-hooks' for information about the hook
    450 arguments and more details."
    451   :type '(alist :key-type
    452                 (choice symbol
    453                         (const :tag "Default" t)
    454                         (const :tag "Always" :always))
    455                 :value-type hook))
    456 
    457 (defcustom embark-around-action-hooks
    458   '(;; use directory of target as default-directory
    459     (shell embark--cd)
    460     (eshell embark--cd)
    461     ;; mark the target preserving point and previous mark
    462     (kill-region embark--mark-target)
    463     (kill-ring-save embark--mark-target)
    464     (indent-region embark--mark-target)
    465     (ispell-region embark--mark-target)
    466     (fill-region embark--mark-target)
    467     (upcase-region embark--mark-target)
    468     (downcase-region embark--mark-target)
    469     (capitalize-region embark--mark-target)
    470     (count-words-region embark--mark-target)
    471     (count-words embark--mark-target)
    472     (delete-duplicate-lines embark--mark-target)
    473     (shell-command-on-region embark--mark-target)
    474     (delete-region embark--mark-target)
    475     (format-encode-region embark--mark-target)
    476     (format-decode-region embark--mark-target)
    477     (write-region embark--mark-target)
    478     (append-to-file embark--mark-target)
    479     (append-to-buffer embark--mark-target)
    480     (shell-command-on-region embark--mark-target)
    481     (embark-eval-replace embark--mark-target)
    482     (delete-indentation embark--mark-target)
    483     (comment-dwim embark--mark-target)
    484     (insert-parentheses embark--mark-target)
    485     (insert-pair embark--mark-target)
    486     (org-emphasize embark--mark-target)
    487     ;; do the actual work of selecting & deselecting targets
    488     (embark-select embark--select))
    489   "Alist associating commands with post-action hooks.
    490 The hooks are run instead of the embarked upon action.  The hook
    491 can decide whether or not to run the action or it can run it
    492 in some special environment, like inside a let-binding or inside
    493 `save-excursion'.  Each hook is called with keyword argument :run
    494 providing a function encapsulating the following around hooks and
    495 the action; the hook additionally receives the keyword arguments
    496 used for other types of action hooks, for more details see
    497 `embark-target-injection-hooks'."
    498   :type '(alist :key-type
    499                 (choice symbol
    500                         (const :tag "Default" t)
    501                         (const :tag "Always" :always))
    502                 :value-type hook))
    503 
    504 (static-if (< emacs-major-version 29)
    505   ;; narrow to target for duration of action
    506   (setf (alist-get 'repunctuate-sentences embark-around-action-hooks)
    507         '(embark--narrow-to-target)))
    508 
    509 (defcustom embark-multitarget-actions '(embark-insert embark-copy-as-kill)
    510   "Commands for which `embark-act-all' should pass a list of targets.
    511 Normally `embark-act-all' runs the same action on each candidate
    512 separately, but when a command included in this variable's value
    513 is used as an action, `embark-act-all' will instead call it
    514 non-interactively with a single argument: the list of all
    515 candidates.  For commands on this list `embark-act' behaves
    516 similarly: it calls them non-interactively with a single
    517 argument: a one element list containing the target."
    518   :type '(repeat function))
    519 
    520 (defcustom embark-repeat-actions
    521   '((mark . region)
    522     ;; outline commands
    523     outline-next-visible-heading outline-previous-visible-heading
    524     outline-forward-same-level outline-backward-same-level
    525     outline-demote outline-promote
    526     outline-show-subtree (outline-mark-subtree . region)
    527     outline-move-subtree-up outline-move-subtree-down
    528     outline-up-heading outline-hide-subtree outline-cycle
    529     ;; org commands (remapped outline commands)
    530     org-forward-heading-same-level org-backward-heading-same-level
    531     org-next-visible-heading org-previous-visible-heading
    532     org-demote-subtree org-promote-subtree
    533     org-show-subtree (org-mark-subtree . region)
    534     org-move-subtree-up org-move-subtree-down
    535     ;; transpose commands
    536     transpose-sexps transpose-sentences transpose-paragraphs
    537     ;; navigation commands
    538     flymake-goto-next-error flymake-goto-prev-error
    539     embark-next-symbol embark-previous-symbol
    540     backward-up-list backward-list forward-list forward-sexp
    541     backward-sexp forward-sentence backward-sentence
    542     forward-paragraph backward-paragraph
    543     ;; smerge commands
    544     smerge-refine smerge-combine-with-next smerge-prev smerge-next)
    545   "List of repeatable actions.
    546 When you use a command on this list as an Embark action from
    547 outside the minibuffer, `embark-act' does not exit but instead
    548 lets you act again on the possibly new target you reach.
    549 
    550 By default, after using one of these actions, when `embark-act'
    551 looks for targets again, it will start the target cycle at the
    552 same type as the previously acted upon target; that is, you
    553 \"don't loose your place in the target cycle\".
    554 
    555 Sometimes, however, you'll want to prioritize a different type of
    556 target to continue acting on.  The main example of this that if
    557 you use a marking command as an action, you almost always want to
    558 act on the region next.  For those cases, in addition to
    559 commands, you can also place on this list a pair of a command and
    560 the desired starting type for the target cycle for the next
    561 action."
    562   :type '(repeat (choice function
    563                          (cons function
    564                                (symbol :tag "Next target type")))))
    565 
    566 ;;; Overlay properties
    567 
    568 ;; high priority to override both bug reference and the lazy
    569 ;; isearch highlights in embark-isearch-highlight-indicator
    570 (put 'embark-target-overlay 'face 'embark-target)
    571 (put 'embark-target-overlay 'priority 1001)
    572 (put 'embark-selected-overlay 'face 'embark-selected)
    573 (put 'embark-selected-overlay 'priority 1001)
    574 
    575 ;;; Stashing information for actions in buffer local variables
    576 
    577 (defvar-local embark--type nil
    578   "Cache for the completion type, meant to be set buffer-locally.")
    579 
    580 (defvar-local embark--target-buffer nil
    581   "Cache for the previous buffer, meant to be set buffer-locally.")
    582 
    583 (defvar-local embark--target-window nil
    584   "Cache for the previous window, meant to be set buffer-locally.
    585 Since windows can be reused to display different buffers, this
    586 window should only be used if it displays the buffer stored in
    587 the variable `embark--target-buffer'.")
    588 
    589 (defvar-local embark--command nil
    590   "Command that started the completion session.")
    591 
    592 (defvar-local embark--toggle-quit nil
    593   "Should we toggle the default quitting behavior for the next action?")
    594 
    595 (defun embark--minibuffer-point ()
    596   "Return length of minibuffer contents."
    597   (max 0 (- (point) (minibuffer-prompt-end))))
    598 
    599 (defun embark--default-directory ()
    600   "Guess a reasonable default directory for the current candidates."
    601   (if (and (minibufferp) minibuffer-completing-file-name)
    602       (let ((end (minibuffer-prompt-end))
    603             (contents (minibuffer-contents)))
    604         (expand-file-name
    605          (substitute-in-file-name
    606           (buffer-substring
    607            end
    608            (+ end
    609               (or (cdr
    610                    (last
    611                     (completion-all-completions
    612                      contents
    613                      minibuffer-completion-table
    614                      minibuffer-completion-predicate
    615                      (embark--minibuffer-point))))
    616                   (cl-position ?/ contents :from-end t)
    617                   0))))))
    618     default-directory))
    619 
    620 (defun embark--target-buffer ()
    621   "Return buffer that should be targeted by Embark actions."
    622   (cond
    623    ((and (minibufferp) minibuffer-completion-table (minibuffer-selected-window))
    624     (window-buffer (minibuffer-selected-window)))
    625    ((and embark--target-buffer (buffer-live-p embark--target-buffer))
    626     embark--target-buffer)
    627    (t (current-buffer))))
    628 
    629 (defun embark--target-window (&optional display)
    630   "Return window which should be selected when Embark actions run.
    631 If DISPLAY is non-nil, call `display-buffer' to produce the
    632 window if necessary."
    633   (cond
    634    ((and (minibufferp) minibuffer-completion-table (minibuffer-selected-window))
    635     (minibuffer-selected-window))
    636    ((and embark--target-window
    637          (window-live-p embark--target-window)
    638          (or (not (buffer-live-p embark--target-buffer))
    639              (eq (window-buffer embark--target-window) embark--target-buffer)))
    640     embark--target-window)
    641    ((and embark--target-buffer (buffer-live-p embark--target-buffer))
    642     (or (get-buffer-window embark--target-buffer)
    643         (when display (display-buffer embark--target-buffer))))
    644    (display (selected-window))))
    645 
    646 (defun embark--cache-info (buffer)
    647   "Cache information needed for actions in variables local to BUFFER.
    648 BUFFER defaults to the current buffer."
    649   (let ((cmd embark--command)
    650         (dir (embark--default-directory))
    651         (target-buffer (embark--target-buffer))
    652         (target-window (embark--target-window)))
    653     (with-current-buffer buffer
    654       (setq embark--command cmd
    655             default-directory dir
    656             embark--target-buffer target-buffer
    657             embark--target-window target-window))))
    658 
    659 (defun embark--cache-info--completion-list ()
    660   "Cache information needed for actions in a *Completions* buffer.
    661 Meant to be be added to `completion-setup-hook'."
    662   ;; when completion-setup-hook hook runs, the *Completions* buffer is
    663   ;; available in the variable standard-output
    664   (embark--cache-info standard-output)
    665   (with-current-buffer standard-output
    666     (when (minibufferp completion-reference-buffer)
    667       (setq embark--type
    668             (completion-metadata-get
    669              (with-current-buffer completion-reference-buffer
    670                (embark--metadata))
    671              'category)))))
    672 
    673 ;; We have to add this *after* completion-setup-function because that's
    674 ;; when the buffer is put in completion-list-mode and turning the mode
    675 ;; on kills all local variables! So we use a depth of 5.
    676 (add-hook 'completion-setup-hook #'embark--cache-info--completion-list 5)
    677 
    678 ;;;###autoload
    679 (progn
    680   (defun embark--record-this-command ()
    681     "Record command which opened the minibuffer.
    682 We record this because it will be the default action.
    683 This function is meant to be added to `minibuffer-setup-hook'."
    684     (setq-local embark--command this-command))
    685   (add-hook 'minibuffer-setup-hook #'embark--record-this-command))
    686 
    687 ;;; Internal variables
    688 
    689 (defvar embark--prompter-history nil
    690   "History used by the `embark-completing-read-prompter'.")
    691 
    692 ;;; Core functionality
    693 
    694 (defconst embark--verbose-indicator-buffer " *Embark Actions*")
    695 
    696 (defvar embark--minimal-indicator-overlay nil)
    697 
    698 (defun embark--metadata ()
    699   "Return current minibuffer completion metadata."
    700   (completion-metadata
    701    (buffer-substring-no-properties
    702     (minibuffer-prompt-end)
    703     (max (minibuffer-prompt-end) (point)))
    704    minibuffer-completion-table
    705    minibuffer-completion-predicate))
    706 
    707 (defun embark-target-active-region ()
    708   "Target the region if active."
    709   (when (use-region-p)
    710     (let ((start (region-beginning))
    711           (end (region-end)))
    712       `(region ,(buffer-substring start end) . (,start . ,end)))))
    713 
    714 (autoload 'dired-get-filename "dired")
    715 (declare-function image-dired-original-file-name "image-dired")
    716 
    717 (defun embark-target-guess-file-at-point ()
    718   "Target the file guessed by `ffap' at point."
    719   (when-let ((tap-file (thing-at-point 'filename))
    720              ((not (ffap-url-p tap-file))) ; no URLs, those have a target finder
    721              (bounds (bounds-of-thing-at-point 'filename))
    722              (file (ffap-file-at-point)))
    723     ;; ffap doesn't make bounds available, so we use
    724     ;; thingatpt bounds, which might be a little off
    725     ;; adjust bounds if thingatpt gobbled punctuation around file
    726     (when (or (string-match (regexp-quote file) tap-file)
    727               (string-match (regexp-quote (file-name-base file)) tap-file))
    728       (setq bounds (cons (+ (car bounds) (match-beginning 0))
    729                          (- (cdr bounds) (- (length tap-file)
    730                                             (match-end 0))))))
    731     `(file ,(abbreviate-file-name (expand-file-name file)) ,@bounds)))
    732 
    733 (defun embark-target-file-at-point ()
    734   "Target file at point.
    735 This function mostly relies on `ffap-file-at-point', with the
    736 following exceptions:
    737 
    738 - In `dired-mode', it uses `dired-get-filename' instead.
    739 
    740 - In `imaged-dired-thumbnail-mode', it uses
    741   `image-dired-original-file-name' instead."
    742   (let (file bounds)
    743     (or (and (derived-mode-p 'dired-mode)
    744              (setq file (dired-get-filename t 'no-error-if-not-filep))
    745              (setq bounds
    746                    (cons
    747                     (save-excursion (dired-move-to-filename) (point))
    748                     (save-excursion (dired-move-to-end-of-filename) (point)))))
    749         (and (derived-mode-p 'image-dired-thumbnail-mode)
    750              (setq file (image-dired-original-file-name))
    751              (setq bounds (cons (point) (1+ (point)))))
    752         (when-let ((tap-file (thing-at-point 'filename))
    753                    ((not (equal (file-name-base tap-file) tap-file)))
    754                    (guess (embark-target-guess-file-at-point)))
    755           (setq file (cadr guess) bounds (cddr guess))))
    756     (when file
    757       `(file ,(abbreviate-file-name (expand-file-name file)) ,@bounds))))
    758 
    759 (defun embark-target-package-at-point ()
    760   "Target the package on the current line in a packages buffer."
    761   (when (derived-mode-p 'package-menu-mode)
    762     (when-let ((pkg (get-text-property (point) 'tabulated-list-id)))
    763       `(package ,(symbol-name (package-desc-name pkg))
    764                 ,(line-beginning-position) . ,(line-end-position)))))
    765 
    766 (defun embark-target-email-at-point ()
    767   "Target the email address at point."
    768   (when-let ((email (thing-at-point 'email)))
    769     (when (string-prefix-p "mailto:" email)
    770       (setq email (string-remove-prefix "mailto:" email)))
    771     `(email ,email . ,(bounds-of-thing-at-point 'email))))
    772 
    773 (defun embark-target-url-at-point ()
    774   "Target the URL at point."
    775   (if-let ((url (or (get-text-property (point) 'shr-url)
    776                     (get-text-property (point) 'image-url))))
    777       `(url ,url
    778             ,(previous-single-property-change
    779               (min (1+ (point)) (point-max)) 'mouse-face nil (point-min))
    780             . ,(next-single-property-change
    781                 (point) 'mouse-face nil (point-max)))
    782     (when-let ((url (thing-at-point 'url)))
    783       `(url ,url . ,(thing-at-point-bounds-of-url-at-point t)))))
    784 
    785 (declare-function widget-at "wid-edit")
    786 
    787 (defun embark-target-custom-variable-at-point ()
    788   "Target the variable corresponding to the customize widget at point."
    789   (when (derived-mode-p 'Custom-mode)
    790     (save-excursion
    791       (beginning-of-line)
    792       (when-let* ((widget (widget-at (point)))
    793                   (var (and (eq (car widget) 'custom-visibility)
    794                             (plist-get (cdr widget) :parent)))
    795                   (sym (and (eq (car var) 'custom-variable)
    796                             (plist-get (cdr var) :value))))
    797         `(variable
    798           ,(symbol-name sym)
    799           ,(point)
    800           . ,(progn
    801                (re-search-forward ":" (line-end-position) 'noerror)
    802                (point)))))))
    803 
    804 ;; NOTE: There is also (thing-at-point 'list), however it does
    805 ;; not work on strings and requires the point to be inside the
    806 ;; parentheses. This version here is slightly more general.
    807 (defun embark-target-expression-at-point ()
    808   "Target expression at point."
    809   (cl-flet ((syntax-p (class &optional (delta 0))
    810               (and (<= (point-min) (+ (point) delta) (point-max))
    811                    (eq (pcase class
    812                          ('open 4) ('close 5) ('prefix 6) ('string 7))
    813                        (syntax-class (syntax-after (+ (point) delta)))))))
    814     (when-let
    815         ((start
    816           (pcase-let ((`(_ ,open _ ,string _ _ _ _ ,start _ _) (syntax-ppss)))
    817             (ignore-errors ; set start=nil if delimiters are unbalanced
    818               (cond
    819                 (string start)
    820                 ((or (syntax-p 'open) (syntax-p 'prefix))
    821                  (save-excursion (backward-prefix-chars) (point)))
    822                 ((syntax-p 'close -1)
    823                  (save-excursion
    824                    (backward-sexp) (backward-prefix-chars) (point)))
    825                 ((syntax-p 'string) (point))
    826                 ((syntax-p 'string -1) (scan-sexps (point) -1))
    827                 (t open)))))
    828          (end (ignore-errors (scan-sexps start 1))))
    829       (unless (eq start (car (bounds-of-thing-at-point 'defun)))
    830       `(expression ,(buffer-substring start end) ,start . ,end)))))
    831 
    832 (defmacro embark-define-overlay-target (name prop &optional pred type target)
    833   "Define a target finder for NAME that targets overlays with property PROP.
    834 The function defined is named embark-target-NAME-at-point and it
    835 returns Embark targets based on the overlays around point.  An
    836 overlay provides a target if its property named PROP is non-nil.
    837 
    838 If the optional PRED argument is given, it should be an
    839 expression and it further restricts the targets to only those
    840 overlays for which PRED evaluates to non-nil.
    841 
    842 The target finder returns target type NAME or optional symbol
    843 TYPE if given.
    844 
    845 The target finder returns the substring of the buffer covered by
    846 the overlay as the target string or the result of evaluating the
    847 optional TARGET expression if given.
    848 
    849 PRED and TARGET are expressions (not functions) and when evaluated the
    850 symbols `%o' and `%p' are bound to the overlay and the overlay's
    851 property respectively."
    852   `(defun ,(intern (format "embark-target-%s-at-point" name)) ()
    853      ,(format "Target %s at point." name)
    854      (when-let ((%o (seq-find
    855                            (lambda (%o)
    856                              (when-let ((%p (overlay-get %o ',prop)))
    857                                (ignore %p)
    858                                ,(or pred t)))
    859                            (overlays-in (max (point-min) (1- (point)))
    860                                         (min (point-max) (1+ (point))))))
    861                 (%p (overlay-get %o ',prop)))
    862        (ignore %p)
    863        (cons ',(or type name)
    864              (cons ,(or target `(buffer-substring-no-properties
    865                                  (overlay-start %o) (overlay-end %o)))
    866                    (cons (overlay-start %o) (overlay-end %o)))))))
    867 
    868 (embark-define-overlay-target flymake flymake-diagnostic)
    869 (embark-define-overlay-target bug-reference bug-reference-url nil url %p)
    870 (embark-define-overlay-target smerge smerge (eq %p 'conflict))
    871 
    872 (defmacro embark-define-thingatpt-target (thing &rest modes)
    873   "Define a target finder for THING using the thingatpt library.
    874 The function defined is named embark-target-NAME-at-point and it
    875 uses (thing-at-point \\='THING) to find its targets.
    876 
    877 If any MODES are given, the target finder only applies to buffers
    878 in one of those major modes."
    879   (declare (indent 1))
    880   `(defun ,(intern (format "embark-target-%s-at-point" thing)) ()
    881      ,(format "Target %s at point." thing)
    882      (when ,(if modes `(derived-mode-p ,@(mapcar (lambda (m) `',m) modes)) t)
    883        (when-let (bounds (bounds-of-thing-at-point ',thing))
    884          (cons ',thing (cons
    885                         (buffer-substring (car bounds) (cdr bounds))
    886                         bounds))))))
    887 
    888 (embark-define-thingatpt-target defun)
    889 (embark-define-thingatpt-target sentence
    890   text-mode help-mode Info-mode man-common)
    891 (embark-define-thingatpt-target paragraph
    892   text-mode help-mode Info-mode man-common)
    893 
    894 (defmacro embark-define-regexp-target
    895     (name regexp &optional type target bounds limit)
    896   "Define a target finder for matches of REGEXP around point.
    897 The function defined is named embark-target-NAME-at-point and it
    898 uses (thing-at-point-looking-at REGEXP) to find its targets.
    899 
    900 The target finder returns target type NAME or optional symbol
    901 TYPE if given.
    902 
    903 The target finder returns the substring of the buffer matched by
    904 REGEXP as the target string or the result of evaluating the
    905 optional TARGET expression if given.  In the expression TARGET
    906 you can use `match-string' to recover the match of the REGEXP or
    907 of any sub-expressions it has.
    908 
    909 BOUNDS is an optional expression to compute the bounds of the
    910 target and defaults to (cons (match-beginning 0) (match-end 0)).
    911 
    912 The optional LIMIT is the number of characters before and after
    913 point to limit the search to.  If LIMIT is nil, search a little
    914 more than the current line (more precisely, the smallest interval
    915 centered at point that includes the current line)."
    916   `(defun ,(intern (format "embark-target-%s-at-point" name)) ()
    917      ,(format "Target %s at point." name)
    918      (save-match-data
    919        (when (thing-at-point-looking-at
    920               ,regexp
    921               ,(or limit '(max (- (pos-eol) (point)) (- (point) (pos-bol)))))
    922          (cons ',(or type name)
    923                (cons ,(or target '(match-string 0))
    924                      ,(or bounds
    925                           '(cons (match-beginning 0) (match-end 0)))))))))
    926 
    927 (defun embark--identifier-types (identifier)
    928   "Return list of target types appropriate for IDENTIFIER."
    929   (let ((symbol (intern-soft identifier)))
    930     (if (not
    931          (or (derived-mode-p 'emacs-lisp-mode 'inferior-emacs-lisp-mode)
    932              (and (not (derived-mode-p 'prog-mode))
    933                   symbol
    934                   (or (boundp symbol) (fboundp symbol) (symbol-plist symbol)))))
    935         '(identifier)
    936       (let* ((library (ffap-el-mode identifier))
    937              (types
    938               (append
    939                (and (commandp symbol) '(command))
    940                (and symbol (boundp symbol) (not (keywordp symbol)) '(variable))
    941                (and (fboundp symbol) (not (commandp symbol)) '(function))
    942                (and (facep symbol) '(face))
    943                (and library '(library))
    944                (and (featurep 'package) (embark--package-desc symbol)
    945                     '(package)))))
    946         (when (and library
    947                    (looking-back "\\(?:require\\|use-package\\).*"
    948                                  (line-beginning-position)))
    949           (setq types (embark--rotate types (cl-position 'library types))))
    950         (or types '(symbol))))))
    951 
    952 (defun embark-target-identifier-at-point ()
    953   "Target identifier at point.
    954 
    955 In Emacs Lisp and IELM buffers the identifier is promoted to a
    956 symbol, for which more actions are available.  Identifiers are
    957 also promoted to symbols if they are interned Emacs Lisp symbols
    958 and found in a buffer in a major mode that is not derived from
    959 `prog-mode' (this is intended for when you might be reading or
    960 writing about Emacs).
    961 
    962 As a convenience, in Org Mode an initial ' or surrounding == or
    963 ~~ are removed."
    964   (when-let (bounds (bounds-of-thing-at-point 'symbol))
    965     (let ((name (buffer-substring (car bounds) (cdr bounds))))
    966       (when (derived-mode-p 'org-mode)
    967         (cond ((string-prefix-p "'" name)
    968                (setq name (substring name 1))
    969                (cl-incf (car bounds)))
    970               ((string-match-p "^\\([=~]\\).*\\1$" name)
    971                (setq name (substring name 1 -1))
    972                (cl-incf (car bounds))
    973                (cl-decf (cdr bounds)))))
    974       (mapcar (lambda (type) `(,type ,name . ,bounds))
    975               (embark--identifier-types name)))))
    976 
    977 (defun embark-target-heading-at-point ()
    978   "Target the outline heading at point."
    979   (let ((beg (line-beginning-position))
    980         (end (line-end-position)))
    981     (when (save-excursion
    982             (goto-char beg)
    983             (and (bolp)
    984                  (looking-at
    985                   ;; default definition from outline.el
    986                   (or (bound-and-true-p outline-regexp) "[*\^L]+"))))
    987       (require 'outline) ;; Ensure that outline commands are available
    988       `(heading ,(buffer-substring beg end) ,beg . ,end))))
    989 
    990 (defun embark-target-text-heading-at-point ()
    991   "Target the outline heading at point in text modes."
    992   (when (derived-mode-p 'text-mode)
    993     (embark-target-heading-at-point)))
    994 
    995 (defun embark-target-prog-heading-at-point ()
    996   "Target the outline heading at point in programming modes."
    997   (when (derived-mode-p 'prog-mode)
    998     (embark-target-heading-at-point)))
    999 
   1000 (defun embark-target-top-minibuffer-candidate ()
   1001   "Target the top completion candidate in the minibuffer.
   1002 Return the category metadatum as the type of the target.
   1003 
   1004 This target finder is meant for the default completion UI and
   1005 completion UI highly compatible with it, like Icomplete.
   1006 Many completion UIs can still work with Embark but will need
   1007 their own target finder.  See for example
   1008 `embark--vertico-selected'."
   1009   (when (and (minibufferp) minibuffer-completion-table)
   1010     (pcase-let* ((`(,category . ,candidates) (embark-minibuffer-candidates))
   1011                  (contents (minibuffer-contents))
   1012                  (top (if (test-completion contents
   1013                                            minibuffer-completion-table
   1014                                            minibuffer-completion-predicate)
   1015                           contents
   1016                         (let ((completions (completion-all-sorted-completions)))
   1017                           (if (null completions)
   1018                               contents
   1019                             (concat
   1020                              (substring contents
   1021                                         0 (or (cdr (last completions)) 0))
   1022                              (car completions)))))))
   1023       (cons category (or (car (member top candidates)) top)))))
   1024 
   1025 (defun embark-target-collect-candidate ()
   1026   "Target the collect candidate at point."
   1027   (when (derived-mode-p 'embark-collect-mode)
   1028     (when-let ((button
   1029                 (pcase (get-text-property (point) 'tabulated-list-column-name)
   1030                   ("Candidate" (button-at (point)))
   1031                   ("Annotation" (previous-button (point)))))
   1032                (start (button-start button))
   1033                (end (button-end button))
   1034                (candidate (tabulated-list-get-id)))
   1035       `(,embark--type
   1036         ,(if (eq embark--type 'file)
   1037              (abbreviate-file-name (expand-file-name candidate))
   1038            candidate)
   1039         ,start . ,end))))
   1040 
   1041 (defun embark-target-completion-list-candidate ()
   1042   "Return the completion candidate at point in a completions buffer."
   1043   (when (derived-mode-p 'completion-list-mode)
   1044     (if (not (get-text-property (point) 'mouse-face))
   1045         (user-error "No completion here")
   1046       ;; this fairly delicate logic is taken from `choose-completion'
   1047       (let (beg end)
   1048         (cond
   1049          ((and (not (eobp)) (get-text-property (point) 'mouse-face))
   1050           (setq end (point) beg (1+ (point))))
   1051          ((and (not (bobp))
   1052                (get-text-property (1- (point)) 'mouse-face))
   1053           (setq end (1- (point)) beg (point)))
   1054          (t (user-error "No completion here")))
   1055         (setq beg (previous-single-property-change beg 'mouse-face))
   1056         (setq end (or (next-single-property-change end 'mouse-face)
   1057                       (point-max)))
   1058         (let ((raw (or (get-text-property beg 'completion--string)
   1059                        (buffer-substring beg end))))
   1060           `(,embark--type
   1061             ,(if (eq embark--type 'file)
   1062                  (abbreviate-file-name (expand-file-name raw))
   1063                raw)
   1064             ,beg . ,end))))))
   1065 
   1066 (defun embark--cycle-key ()
   1067   "Return the key to use for `embark-cycle'."
   1068   (if embark-cycle-key
   1069       (if (key-valid-p embark-cycle-key)
   1070           (key-parse embark-cycle-key)
   1071         (error "`embark-cycle-key' is invalid"))
   1072     (car (where-is-internal #'embark-act))))
   1073 
   1074 (defun embark--raw-action-keymap (type)
   1075   "Return raw action map for targets of given TYPE.
   1076 This does not take into account the default action, help key or
   1077 cycling bindings, just what's registered in
   1078 `embark-keymap-alist'."
   1079   (make-composed-keymap
   1080    (mapcar #'symbol-value
   1081            (let ((actions (or (alist-get type embark-keymap-alist)
   1082                               (alist-get t embark-keymap-alist))))
   1083              (ensure-list actions)))))
   1084 
   1085 (defun embark--action-keymap (type cycle)
   1086   "Return action keymap for targets of given TYPE.
   1087 If CYCLE is non-nil bind `embark-cycle'."
   1088   (make-composed-keymap
   1089    (let ((map (make-sparse-keymap))
   1090          (default-action (embark--default-action type)))
   1091      (define-key map [13] default-action)
   1092      (when-let ((cycle-key (and cycle (embark--cycle-key))))
   1093        (define-key map cycle-key #'embark-cycle))
   1094      (when embark-help-key
   1095        (keymap-set map embark-help-key #'embark-keymap-help))
   1096      map)
   1097    (embark--raw-action-keymap type)))
   1098 
   1099 (defun embark--truncate-target (target)
   1100   "Truncate TARGET string."
   1101   (unless (stringp target)
   1102     (setq target (format "%s" target)))
   1103   (if-let (pos (string-match-p "\n" target))
   1104       (concat (car (split-string target "\n" 'omit-nulls "\\s-*")) "…")
   1105     target))
   1106 
   1107 ;;;###autoload
   1108 (defun embark-eldoc-first-target (report &rest _)
   1109   "Eldoc function reporting the first Embark target at point.
   1110 This function uses the eldoc REPORT callback and is meant to be
   1111 added to `eldoc-documentation-functions'."
   1112   (when-let (((not (minibufferp)))
   1113              (target (car (embark--targets))))
   1114     (funcall report
   1115              (format "Embark on %s ‘%s’"
   1116                      (plist-get target :type)
   1117                      (embark--truncate-target (plist-get target :target))))))
   1118 
   1119 ;;;###autoload
   1120 (defun embark-eldoc-target-types (report &rest _)
   1121   "Eldoc function reporting the types of all Embark targets at point.
   1122 This function uses the eldoc REPORT callback and is meant to be
   1123 added to `eldoc-documentation-functions'."
   1124   (when-let (((not (minibufferp)))
   1125              (targets (embark--targets)))
   1126     (funcall report
   1127              (format "Embark target types: %s"
   1128                      (mapconcat
   1129                       (lambda (target) (symbol-name (plist-get target :type)))
   1130                       targets
   1131                       ", ")))))
   1132 
   1133 (defun embark--format-targets (target shadowed-targets rep)
   1134   "Return a formatted string indicating the TARGET of an action.
   1135 
   1136 This is used internally by the minimal indicator and for the
   1137 targets section of the verbose indicator.  The string will also
   1138 mention any SHADOWED-TARGETS.  A non-nil REP indicates we are in
   1139 a repeating sequence of actions."
   1140   (let ((act (propertize
   1141               (cond
   1142                ((plist-get target :multi) "∀ct")
   1143                (rep "Rep")
   1144                (t "Act"))
   1145               'face 'highlight)))
   1146     (cond
   1147      ((eq (plist-get target :type) 'embark-become)
   1148       (propertize "Become" 'face 'highlight))
   1149      ((and (minibufferp)
   1150            (not (eq 'embark-keybinding
   1151                     (completion-metadata-get
   1152                      (embark--metadata)
   1153                      'category))))
   1154       ;; we are in a minibuffer but not from the
   1155       ;; completing-read prompter, use just "Act"
   1156       act)
   1157      ((plist-get target :multi)
   1158       (format "%s on %s %ss"
   1159               act
   1160               (plist-get target :multi)
   1161               (plist-get target :type)))
   1162      (t (format
   1163          "%s on %s%s ‘%s’"
   1164          act
   1165          (plist-get target :type)
   1166          (if shadowed-targets
   1167              (format (propertize "(%s)" 'face 'shadow)
   1168                      (mapconcat
   1169                       (lambda (target) (symbol-name (plist-get target :type)))
   1170                       shadowed-targets
   1171                       ", "))
   1172            "")
   1173          (embark--truncate-target (plist-get target :target)))))))
   1174 
   1175 (defun embark-minimal-indicator ()
   1176   "Minimal indicator, appearing in the minibuffer prompt or echo area.
   1177 This indicator displays a message showing the types of all
   1178 targets, starting with the current target, and the value of the
   1179 current target.  The message is displayed in the echo area, or if
   1180 the minibuffer is open, the message is added to the prompt."
   1181   (lambda (&optional keymap targets _prefix)
   1182     (if (null keymap)
   1183         (when embark--minimal-indicator-overlay
   1184           (delete-overlay embark--minimal-indicator-overlay)
   1185           (setq-local embark--minimal-indicator-overlay nil))
   1186       (let ((indicator (embark--format-targets
   1187                         (car targets) (cdr targets)
   1188                         (eq (lookup-key keymap [13]) #'embark-done))))
   1189         (if (not (minibufferp))
   1190             (message "%s" indicator)
   1191           (unless embark--minimal-indicator-overlay
   1192             (setq-local embark--minimal-indicator-overlay
   1193                         (make-overlay (point-min) (point-min)
   1194                                       (current-buffer) t t)))
   1195           (overlay-put embark--minimal-indicator-overlay
   1196                        'before-string (concat indicator
   1197                                               (if (<= (length indicator)
   1198                                                       (* 0.4 (frame-width)))
   1199                                                   " "
   1200                                                 "\n"))))))))
   1201 
   1202 (defun embark--read-key-sequence (update)
   1203   "Read key sequence, call UPDATE function with prefix keys."
   1204   (let (timer prefix)
   1205     (unwind-protect
   1206         (progn
   1207           (when (functionp update)
   1208             (setq timer (run-at-time
   1209                          0.05 0.05
   1210                          (lambda ()
   1211                            (let ((new-prefix (this-single-command-keys)))
   1212                              (unless (equal prefix new-prefix)
   1213                                (setq prefix new-prefix)
   1214                                (when (/= (length prefix) 0)
   1215                                  (funcall update prefix))))))))
   1216           (read-key-sequence-vector nil nil nil t 'cmd-loop))
   1217       (when timer
   1218         (cancel-timer timer)))))
   1219 
   1220 (defvar embark-indicators) ; forward declaration
   1221 
   1222 (defun embark-keymap-prompter (keymap update)
   1223   "Let the user choose an action using the bindings in KEYMAP.
   1224 Besides the bindings in KEYMAP, the user is free to use all their
   1225 key bindings and even \\[execute-extended-command] to select a command.
   1226 UPDATE is the indicator update function."
   1227   (let* ((keys (let ((overriding-terminal-local-map keymap))
   1228                  (embark--read-key-sequence update)))
   1229          (cmd (let ((overriding-terminal-local-map keymap))
   1230                 (key-binding keys 'accept-default))))
   1231     ;; Set last-command-event as it would be from the command loop.
   1232     ;; Previously we only set it locally for digit-argument and for
   1233     ;; the mouse scroll commands handled in this function. But other
   1234     ;; commands can need it too! For example, electric-pair-mode users
   1235     ;; may wish to bind ( to self-insert-command in embark-region-map.
   1236     ;; Also, as described in issue #402, there are circumstances where
   1237     ;; you might run consult-narrow through the embark-keymap-prompter.
   1238     (setq last-command-event (aref keys (1- (length keys))))
   1239     (pcase cmd
   1240       ((or 'embark-keymap-help
   1241            (and 'nil            ; cmd is nil but last key is help-char
   1242                 (guard (eq help-char (aref keys (1- (length keys)))))))
   1243        (let ((embark-indicators
   1244               (cl-set-difference embark-indicators
   1245                                  '(embark-verbose-indicator
   1246                                    embark-mixed-indicator)))
   1247              (prefix-map
   1248               (if (eq cmd 'embark-keymap-help)
   1249                   keymap
   1250                 (let ((overriding-terminal-local-map keymap))
   1251                   (key-binding (seq-take keys (1- (length keys)))
   1252                                'accept-default))))
   1253              (prefix-arg prefix-arg)) ; preserve prefix arg
   1254          (when-let ((win (get-buffer-window embark--verbose-indicator-buffer
   1255                                             'visible)))
   1256            (quit-window 'kill-buffer win))
   1257          (embark-completing-read-prompter prefix-map update)))
   1258       ((or 'universal-argument 'universal-argument-more
   1259            'negative-argument 'digit-argument 'embark-toggle-quit)
   1260        ;; prevent `digit-argument' from modifying the overriding map
   1261        (let ((overriding-terminal-local-map overriding-terminal-local-map))
   1262          (command-execute cmd))
   1263        (embark-keymap-prompter
   1264         (make-composed-keymap universal-argument-map keymap)
   1265         update))
   1266       ((or 'minibuffer-keyboard-quit 'abort-recursive-edit 'abort-minibuffers)
   1267        nil)
   1268       ((guard (let ((def (lookup-key keymap keys))) ; if directly
   1269                                                     ; bound, then obey
   1270                 (and def (not (numberp def))))) ; number means "invalid prefix"
   1271        cmd)
   1272       ((and (pred symbolp)
   1273             (guard (string-suffix-p "self-insert-command" (symbol-name cmd))))
   1274        (minibuffer-message "Not an action")
   1275        (embark-keymap-prompter keymap update))
   1276       ((or 'scroll-other-window 'scroll-other-window-down)
   1277        (let ((minibuffer-scroll-window
   1278               ;; NOTE: Here we special case the verbose indicator!
   1279               (or (get-buffer-window embark--verbose-indicator-buffer 'visible)
   1280                   minibuffer-scroll-window)))
   1281          (ignore-errors (command-execute cmd)))
   1282        (embark-keymap-prompter keymap update))
   1283       ((or 'scroll-bar-toolkit-scroll 'mwheel-scroll
   1284            'mac-mwheel-scroll 'pixel-scroll-precision)
   1285        (funcall cmd last-command-event)
   1286        (embark-keymap-prompter keymap update))
   1287       ('execute-extended-command
   1288        (let ((prefix-arg prefix-arg)) ; preserve prefix arg
   1289          (intern-soft (read-extended-command))))
   1290       ((or 'keyboard-quit 'keyboard-escape-quit)
   1291        nil)
   1292       (_ cmd))))
   1293 
   1294 (defun embark--command-name (cmd)
   1295   "Return an appropriate name for CMD.
   1296 If CMD is a symbol, use its symbol name; for lambdas, use the
   1297 first line of the documentation string; for keyboard macros use
   1298 `key-description'; otherwise use the word \"unnamed\"."
   1299   (concat ; fresh copy, so we can freely add text properties
   1300    (cond
   1301     ((or (stringp cmd) (vectorp cmd)) (key-description cmd))
   1302     ((stringp (car-safe cmd)) (car cmd))
   1303     ((eq (car-safe cmd) 'menu-item) (eval (cadr cmd)))
   1304     ((keymapp cmd)
   1305      (propertize (if (symbolp cmd) (format "+%s" cmd) "<keymap>")
   1306                  'face 'embark-keymap))
   1307     ((symbolp cmd)
   1308      (let ((name (symbol-name cmd)))
   1309        (if (string-prefix-p "embark-action--" name) ; direct action mode
   1310            (format "(%s)" (string-remove-prefix "embark-action--" name))
   1311          name)))
   1312     ((when-let (doc (and (functionp cmd) (ignore-errors (documentation cmd))))
   1313        (save-match-data
   1314          (when (string-match "^\\(.*\\)$" doc)
   1315            (match-string 1 doc)))))
   1316     (t "<unnamed>"))))
   1317 
   1318 ;; Taken from Marginalia, needed by the verbose indicator.
   1319 ;; We cannot use the completion annotators in this case.
   1320 (defconst embark--advice-regexp
   1321   (rx bos
   1322       (1+ (seq (? "This function has ")
   1323                (or ":before" ":after" ":around" ":override"
   1324                    ":before-while" ":before-until" ":after-while"
   1325                    ":after-until" ":filter-args" ":filter-return")
   1326                " advice: " (0+ nonl) "\n"))
   1327       "\n")
   1328   "Regexp to match lines about advice in function documentation strings.")
   1329 
   1330 ;; Taken from Marginalia, needed by the verbose indicator.
   1331 ;; We cannot use the completion annotators in this case.
   1332 (defun embark--function-doc (sym)
   1333   "Documentation string of function SYM."
   1334   (let ((vstr (and (symbolp sym) (keymapp sym) (boundp sym)
   1335                    (eq (symbol-function sym) (symbol-value sym))
   1336                    (documentation-property sym 'variable-documentation))))
   1337     (when-let (str (or (ignore-errors (documentation sym)) vstr))
   1338       ;; Replace standard description with variable documentation
   1339       (when (and vstr (string-match-p "\\`Prefix command" str))
   1340         (setq str vstr))
   1341       (save-match-data
   1342         (if (string-match embark--advice-regexp str)
   1343             (substring str (match-end 0))
   1344           str)))))
   1345 
   1346 (defun embark--action-repeatable-p (action)
   1347   "Is ACTION repeatable?
   1348 When the return value is non-nil it will be the desired starting
   1349 point of the next target cycle or t to indicate the default,
   1350 namely that the target cycle for the next action should begin at
   1351 the type of the current target."
   1352   (or (cdr (assq action embark-repeat-actions))
   1353       (and (memq action embark-repeat-actions) t)))
   1354 
   1355 (defun embark--formatted-bindings (keymap &optional nested)
   1356   "Return the formatted keybinding of KEYMAP.
   1357 The keybindings are returned in their order of appearance.
   1358 If NESTED is non-nil subkeymaps are not flattened."
   1359   (let* ((commands
   1360           (cl-loop for (key . def) in (embark--all-bindings keymap nested)
   1361                    for name = (embark--command-name def)
   1362                    for cmd = (keymap--menu-item-binding def)
   1363                    unless (memq cmd '(nil embark-keymap-help
   1364                                       negative-argument digit-argument))
   1365                    collect (list name cmd key
   1366                                  (concat
   1367                                   (if (eq (car-safe def) 'menu-item)
   1368                                       "menu-item"
   1369                                     (key-description key))))))
   1370          (width (cl-loop for (_name _cmd _key desc) in commands
   1371                          maximize (length desc)))
   1372          (default)
   1373          (candidates
   1374           (cl-loop for item in commands
   1375                    for (name cmd key desc) = item
   1376                    for desc-rep =
   1377                    (concat
   1378                     (propertize desc 'face 'embark-keybinding)
   1379                     (and (embark--action-repeatable-p cmd)
   1380                          embark-keybinding-repeat))
   1381                    for formatted =
   1382                    (propertize
   1383                     (concat desc-rep
   1384                             (make-string (- width (length desc-rep) -1) ?\s)
   1385                             name)
   1386                     'embark-command cmd)
   1387                    when (equal key [13])
   1388                    do (setq default formatted)
   1389                    collect (cons formatted item))))
   1390     (cons candidates default)))
   1391 
   1392 (defun embark--with-category (category candidates)
   1393   "Return completion table for CANDIDATES of CATEGORY with sorting disabled."
   1394   (lambda (string predicate action)
   1395     (if (eq action 'metadata)
   1396         `(metadata (display-sort-function . identity)
   1397                    (cycle-sort-function . identity)
   1398                    (category . ,category))
   1399       (complete-with-action
   1400        action candidates string predicate))))
   1401 
   1402 (defun embark-completing-read-prompter (keymap update &optional no-default)
   1403   "Prompt via completion for a command bound in KEYMAP.
   1404 If NO-DEFAULT is t, no default value is passed to`completing-read'.
   1405 
   1406 UPDATE is the indicator update function.  It is not used directly
   1407 here, but if the user switches to `embark-keymap-prompter', the
   1408 UPDATE function is passed to it."
   1409   (let* ((candidates+def (embark--formatted-bindings keymap))
   1410          (candidates (car candidates+def))
   1411          (def (and (not no-default) (cdr candidates+def)))
   1412          (buf (current-buffer))
   1413          (choice
   1414           (catch 'choice
   1415             (minibuffer-with-setup-hook
   1416                 (lambda ()
   1417                   (let ((map (make-sparse-keymap)))
   1418                     (define-key map "\M-q"
   1419                                 (lambda ()
   1420                                   (interactive)
   1421                                   (with-current-buffer buf
   1422                                     (embark-toggle-quit))))
   1423                     (when-let (cycle (embark--cycle-key))
   1424                       ;; Rebind `embark-cycle' in order allow cycling
   1425                       ;; from the `completing-read' prompter. Additionally
   1426                       ;; `embark-cycle' can be selected via
   1427                       ;; `completing-read'. The downside is that this breaks
   1428                       ;; recursively acting on the candidates of type
   1429                       ;; embark-keybinding in the `completing-read' prompter.
   1430                       (define-key map cycle
   1431                         (cond
   1432                          ((eq (lookup-key keymap cycle) 'embark-cycle)
   1433                           (lambda ()
   1434                             (interactive)
   1435                             (throw 'choice 'embark-cycle)))
   1436                          ((null embark-cycle-key)
   1437                           (lambda ()
   1438                             (interactive)
   1439                             (minibuffer-message
   1440                              "No cycling possible; press `%s' again to act."
   1441                              (key-description cycle))
   1442                             (define-key map cycle #'embark-act))))))
   1443                     (when embark-keymap-prompter-key
   1444                       (keymap-set map embark-keymap-prompter-key
   1445                         (lambda ()
   1446                           (interactive)
   1447                           (message "Press key binding")
   1448                           (let ((cmd (embark-keymap-prompter keymap update)))
   1449                             (if (null cmd)
   1450                                 (user-error "Unknown key")
   1451                               (throw 'choice cmd))))))
   1452                     (use-local-map
   1453                      (make-composed-keymap map (current-local-map)))))
   1454               (completing-read
   1455                "Command: "
   1456                (embark--with-category 'embark-keybinding candidates)
   1457                nil nil nil 'embark--prompter-history def)))))
   1458     (pcase (assoc choice candidates)
   1459       (`(,_formatted ,_name ,cmd ,key ,_desc)
   1460        ;; Set last-command-event as it would be from the command loop.
   1461        (setq last-command-event (aref key (1- (length key))))
   1462        cmd)
   1463       ('nil (intern-soft choice)))))
   1464 
   1465 ;;; Verbose action indicator
   1466 
   1467 (defgroup embark-indicators nil
   1468   "Indicators display information about actions and targets."
   1469   :group 'embark)
   1470 
   1471 (defcustom embark-indicators
   1472   '(embark-mixed-indicator
   1473     embark-highlight-indicator
   1474     embark-isearch-highlight-indicator)
   1475   "Indicator functions to use when acting or becoming.
   1476 The indicator functions are called from both `embark-act' and
   1477 from `embark-become' and should display information about this to
   1478 the user, such as: which of those two commands is running; a
   1479 description of the key bindings that are available for actions or
   1480 commands to become; and, in the case of `embark-act', the type
   1481 and value of the targets, and whether other targets are available
   1482 via `embark-cycle'.  The indicator function is free to display as
   1483 much or as little of this information as desired and can use any
   1484 Emacs interface elements to do so.
   1485 
   1486 Embark comes with five such indicators:
   1487 
   1488 - `embark-minimal-indicator', which does not display any
   1489   information about keybindings, but does display types and
   1490   values of action targets in the echo area or minibuffer prompt,
   1491 
   1492 - `embark-verbose-indicator', which pops up a buffer containing
   1493   detailed information including key bindings and the first line
   1494   of the docstring of the commands they run, and
   1495 
   1496 - `embark-mixed-indicator', which combines the minimal and the
   1497   verbose indicator: the minimal indicator is shown first and the
   1498   verbose popup is shown after `embark-mixed-indicator-delay'
   1499   seconds.
   1500 
   1501 - `embark-highlight-indicator', which highlights the target
   1502   at point.
   1503 
   1504 - `embark-isearch-highlight-indicator', which when the target at
   1505   point is an identifier or symbol, lazily highlights all
   1506   occurrences of it.
   1507 
   1508 The protocol for indicator functions is as follows:
   1509 
   1510 When called from `embark-act', an indicator function is called
   1511 without arguments.  The indicator function should then return a
   1512 closure, which captures the indicator state.  The returned
   1513 closure must accept up to three optional arguments, the action
   1514 keymap, the targets (plists as returned by `embark--targets') and
   1515 the prefix keys typed by the user so far.  The keymap, targets
   1516 and prefix keys may be updated when cycling targets at point
   1517 resulting in multiple calls to the closure.  When called from
   1518 `embark-become', the indicator closure will be called with the
   1519 keymap of commands to become, a fake target list containing a
   1520 single target of type `embark-become' and whose value is the
   1521 minibuffer input, and the prefix set to nil.  Note, in
   1522 particular, that if an indicator function wishes to distinguish
   1523 between `embark-act' and `embark-become' it should check whether
   1524 the `car' of the first target is `embark-become'.
   1525 
   1526 After the action has been performed the indicator closure is
   1527 called without arguments, such that the indicator can perform the
   1528 necessary cleanup work.  For example, if the indicator adds
   1529 overlays, it should remove these overlays.  The indicator should
   1530 be written in a way that it is safe to call it for cleanup more
   1531 than once, in fact, it should be able to handle any sequence of
   1532 update and cleanup calls ending in a call for cleanup.
   1533 
   1534 NOTE: Experience shows that the indicator calling convention may
   1535 change again in order to support more action features.  The
   1536 calling convention should currently be considered unstable.
   1537 Please keep this in mind when writing a custom indicator
   1538 function, or when using the `which-key' indicator function from
   1539 the wiki."
   1540   :type '(repeat
   1541           (choice
   1542            (const :tag "Verbose indicator" embark-verbose-indicator)
   1543            (const :tag "Minimal indicator" embark-minimal-indicator)
   1544            (const :tag "Mixed indicator" embark-mixed-indicator)
   1545            (const :tag "Highlight target" embark-highlight-indicator)
   1546            (const :tag "Highlight all occurrences"
   1547                   embark-isearch-highlight-indicator)
   1548            (function :tag "Other"))))
   1549 
   1550 (defface embark-verbose-indicator-documentation
   1551   '((t :inherit completions-annotations))
   1552   "Face used by the verbose action indicator to display binding descriptions.
   1553 Used by `embark-verbose-indicator'.")
   1554 
   1555 (defface embark-verbose-indicator-title '((t :height 1.1 :weight bold))
   1556   "Face used by the verbose action indicator for the title.
   1557 Used by `embark-verbose-indicator'.")
   1558 
   1559 (defface embark-verbose-indicator-shadowed '((t :inherit shadow))
   1560   "Face used by the verbose action indicator for the shadowed targets.
   1561 Used by `embark-verbose-indicator'.")
   1562 
   1563 (defcustom embark-verbose-indicator-display-action
   1564   '(display-buffer-reuse-window)
   1565   "Parameters added to `display-buffer-alist' to show the actions buffer.
   1566 See the docstring of `display-buffer' for information on what
   1567 display actions and parameters are available."
   1568   :type `(choice
   1569           (const :tag "Reuse some window"
   1570                  (display-buffer-reuse-window))
   1571           (const :tag "Below target buffer"
   1572                  (display-buffer-below-selected
   1573                   (window-height . fit-window-to-buffer)))
   1574           (const :tag "Bottom of frame (fixed-size)"
   1575                  (display-buffer-at-bottom))
   1576           (const :tag "Bottom of frame (resizes during cycling)"
   1577                  (display-buffer-at-bottom
   1578                   (window-height . fit-window-to-buffer)))
   1579           (const :tag "Side window on the right"
   1580                  (display-buffer-in-side-window (side . right)))
   1581           (const :tag "Side window on the left"
   1582                  (display-buffer-in-side-window (side . left)))
   1583           (sexp :tag "Other")))
   1584 
   1585 (defcustom embark-verbose-indicator-excluded-actions nil
   1586   "Commands not displayed by `embark-verbose-indicator'.
   1587 This variable should be set to a list of symbols and regexps.
   1588 The verbose indicator will exclude from its listing any commands
   1589 matching an element of this list."
   1590   :type '(choice
   1591           (const :tag "Exclude nothing" nil)
   1592           (const :tag "Exclude Embark general actions"
   1593                  (embark-collect embark-live embark-export
   1594                   embark-cycle embark-act-all embark-keymap-help
   1595                   embark-become embark-isearch-forward
   1596                   embark-isearch-backward))
   1597           (repeat :tag "Other" (choice regexp symbol))))
   1598 
   1599 (defcustom embark-verbose-indicator-buffer-sections
   1600   `(target "\n" shadowed-targets " " cycle "\n" bindings)
   1601   "List of sections to display in the verbose indicator buffer, in order.
   1602 You can use either a symbol designating a concrete section (one
   1603 of the keywords below, but without the colon), a string literal
   1604 or a function returning a string or list of strings to insert and
   1605 that accepts the following keyword arguments:
   1606 
   1607 - `:target', the target as a cons of type and value,
   1608 - `:shadowed-targets', a list of conses for the other targets,
   1609 - `:bindings' a list returned by `embark--formatted-bindings', and
   1610 - `:cycle', a string describing the key binding of `embark-cycle'."
   1611   :type '(repeat
   1612           (choice (const :tag "Current target name" target)
   1613                   (const :tag "List of other shadowed targets" shadowed-targets)
   1614                   (const :tag "Key bindings" bindings)
   1615                   (const :tag "Cycle indicator" cycle)
   1616                   (string :tag "Literal string")
   1617                   (function :tag "Custom function"))))
   1618 
   1619 (defcustom embark-verbose-indicator-nested t
   1620   "Whether the verbose indicator should use nested keymap navigation.
   1621 When this variable is non-nil the actions buffer displayed by
   1622 `embark-verbose-indicator' will include any prefix keys found in
   1623 the keymap it is displaying, and will update to show what is
   1624 bound under the prefix if the prefix is pressed.  If this
   1625 variable is nil, then the actions buffer will contain a flat list
   1626 of all full key sequences bound in the keymap."
   1627   :type 'boolean)
   1628 
   1629 (defun embark--verbose-indicator-excluded-p (cmd)
   1630   "Return non-nil if CMD should be excluded from the verbose indicator."
   1631   (seq-find (lambda (x)
   1632               (if (symbolp x)
   1633                   (eq cmd x)
   1634                 (string-match-p x (symbol-name cmd))))
   1635             embark-verbose-indicator-excluded-actions))
   1636 
   1637 (cl-defun embark--verbose-indicator-section-target
   1638     (&key targets bindings &allow-other-keys)
   1639   "Format the TARGETS section for the indicator buffer.
   1640 BINDINGS is the formatted list of keybindings."
   1641   (let ((result (embark--format-targets
   1642                  (car targets)
   1643                  nil   ; the shadowed targets section deals with these
   1644                  (cl-find 'embark-done bindings :key #'caddr :test #'eq))))
   1645     (add-face-text-property 0 (length result)
   1646                             'embark-verbose-indicator-title
   1647                             'append
   1648                             result)
   1649     result))
   1650 
   1651 (cl-defun embark--verbose-indicator-section-cycle
   1652     (&key cycle shadowed-targets &allow-other-keys)
   1653   "Format the CYCLE key section for the indicator buffer.
   1654 SHADOWED-TARGETS is the list of other targets."
   1655   (concat
   1656    (and cycle (propertize (format "(%s to cycle)" cycle)
   1657                           'face 'embark-verbose-indicator-shadowed))
   1658    (and shadowed-targets "\n")))
   1659 
   1660 (cl-defun embark--verbose-indicator-section-shadowed-targets
   1661     (&key shadowed-targets &allow-other-keys)
   1662   "Format the SHADOWED-TARGETS section for the indicator buffer."
   1663   (when shadowed-targets
   1664     (propertize (format "Shadowed targets at point: %s"
   1665                         (string-join shadowed-targets ", "))
   1666                 'face 'embark-verbose-indicator-shadowed)))
   1667 
   1668 (cl-defun embark--verbose-indicator-section-bindings
   1669     (&key bindings &allow-other-keys)
   1670   "Format the BINDINGS section for the indicator buffer."
   1671   (let* ((max-width (apply #'max (cons 0 (mapcar (lambda (x)
   1672                                                   (string-width (car x)))
   1673                                                 bindings))))
   1674          (fmt (format "%%-%ds" (1+ max-width)))
   1675          (result nil))
   1676     (dolist (binding bindings (string-join (nreverse result)))
   1677       (let ((cmd (caddr binding)))
   1678         (unless (embark--verbose-indicator-excluded-p cmd)
   1679           (let ((keys (format fmt (car binding)))
   1680                 (doc (embark--function-doc cmd)))
   1681             (push (format "%s%s\n" keys
   1682                           (propertize
   1683                            (car (split-string (or doc "") "\n"))
   1684                            'face 'embark-verbose-indicator-documentation))
   1685                           result)))))))
   1686 
   1687 (defun embark--verbose-indicator-update (keymap targets)
   1688   "Update verbose indicator buffer.
   1689 The arguments are the new KEYMAP and TARGETS."
   1690   (with-current-buffer (get-buffer-create embark--verbose-indicator-buffer)
   1691     (let* ((inhibit-read-only t)
   1692            (bindings
   1693             (embark--formatted-bindings keymap embark-verbose-indicator-nested))
   1694            (bindings (car bindings))
   1695            (shadowed-targets (mapcar
   1696                               (lambda (x) (symbol-name (plist-get x :type)))
   1697                               (cdr targets)))
   1698            (cycle (let ((ck (where-is-internal #'embark-cycle keymap)))
   1699                     (and ck (key-description (car ck))))))
   1700       (setq-local cursor-type nil)
   1701       (setq-local truncate-lines t)
   1702       (setq-local buffer-read-only t)
   1703       (erase-buffer)
   1704       (dolist (section embark-verbose-indicator-buffer-sections)
   1705         (insert
   1706          (if (stringp section)
   1707              section
   1708            (or (funcall
   1709                 (let ((prefixed (intern (format
   1710                                          "embark--verbose-indicator-section-%s"
   1711                                          section))))
   1712                   (cond
   1713                    ((fboundp prefixed) prefixed)
   1714                    ((fboundp section) section)
   1715                    (t (error "Undefined verbose indicator section `%s'"
   1716                              section))))
   1717                 :targets targets :shadowed-targets shadowed-targets
   1718                 :bindings bindings :cycle cycle)
   1719                ""))))
   1720       (goto-char (point-min)))))
   1721 
   1722 (defun embark-verbose-indicator ()
   1723   "Indicator that displays a table of key bindings in a buffer.
   1724 The default display includes the type and value of the current
   1725 target, the list of other target types, and a table of key
   1726 bindings, actions and the first line of their docstrings.
   1727 
   1728 The order and formatting of these items is completely
   1729 configurable through the variable
   1730 `embark-verbose-indicator-buffer-sections'.
   1731 
   1732 If the keymap being shown contains prefix keys, the table of key
   1733 bindings can either show just the prefixes and update once the
   1734 prefix is pressed, or it can contain a flat list of all full key
   1735 sequences bound in the keymap.  This is controlled by the
   1736 variable `embark-verbose-indicator-nested'.
   1737 
   1738 To reduce clutter in the key binding table, one can set the
   1739 variable `embark-verbose-indicator-excluded-actions' to a list
   1740 of symbols and regexps matching commands to exclude from the
   1741 table.
   1742 
   1743 To configure how a window is chosen to display this buffer, see
   1744 the variable `embark-verbose-indicator-display-action'."
   1745   (lambda (&optional keymap targets prefix)
   1746     (if (not keymap)
   1747         (when-let ((win (get-buffer-window embark--verbose-indicator-buffer
   1748                                            'visible)))
   1749           (quit-window 'kill-buffer win))
   1750       (embark--verbose-indicator-update
   1751        (if (and prefix embark-verbose-indicator-nested)
   1752            ;; Lookup prefix keymap globally if not found in action keymap
   1753            (let ((overriding-terminal-local-map keymap))
   1754              (key-binding prefix 'accept-default))
   1755          keymap)
   1756        targets)
   1757       (let ((display-buffer-alist
   1758              `(,@display-buffer-alist
   1759                (,(regexp-quote embark--verbose-indicator-buffer)
   1760                 ,@embark-verbose-indicator-display-action))))
   1761         (display-buffer embark--verbose-indicator-buffer)))))
   1762 
   1763 (defcustom embark-mixed-indicator-delay 0.5
   1764   "Time in seconds after which the verbose indicator is shown.
   1765 The mixed indicator starts by showing the minimal indicator and
   1766 after this delay shows the verbose indicator."
   1767   :type '(choice (const :tag "No delay" 0)
   1768                  (number :tag "Delay in seconds")))
   1769 
   1770 (defcustom embark-mixed-indicator-both nil
   1771   "Show both indicators, even after the verbose indicator appeared."
   1772   :type 'boolean)
   1773 
   1774 (defun embark-mixed-indicator ()
   1775   "Mixed indicator showing keymap and targets.
   1776 The indicator shows the `embark-minimal-indicator' by default.
   1777 After `embark-mixed-indicator-delay' seconds, the
   1778 `embark-verbose-indicator' is shown.  This which-key-like approach
   1779 ensures that Embark stays out of the way for quick actions.  The
   1780 helpful keybinding reminder still pops up automatically without
   1781 further user intervention."
   1782   (let ((vindicator (embark-verbose-indicator))
   1783         (mindicator (embark-minimal-indicator))
   1784         vindicator-active
   1785         vtimer)
   1786     (lambda (&optional keymap targets prefix)
   1787       ;; Always cancel the timer.
   1788       ;; 1. When updating, cancel timer, since the user has pressed
   1789       ;;    a key before the timer elapsed.
   1790       ;; 2. For cleanup, the timer must also be canceled.
   1791       (when vtimer
   1792         (cancel-timer vtimer)
   1793         (setq vtimer nil))
   1794       (if (not keymap)
   1795           (progn
   1796             (funcall vindicator)
   1797             (when mindicator
   1798               (funcall mindicator)))
   1799         (when mindicator
   1800           (funcall mindicator keymap targets prefix))
   1801         (if vindicator-active
   1802             (funcall vindicator keymap targets prefix)
   1803           (setq vtimer
   1804                 (run-at-time
   1805                  embark-mixed-indicator-delay nil
   1806                  (lambda ()
   1807                    (when (and (not embark-mixed-indicator-both) mindicator)
   1808                      (funcall mindicator)
   1809                      (setq mindicator nil))
   1810                    (setq vindicator-active t)
   1811                    (funcall vindicator keymap targets prefix)))))))))
   1812 
   1813 ;;;###autoload
   1814 (defun embark-bindings-in-keymap (keymap)
   1815   "Explore command key bindings in KEYMAP with `completing-read'.
   1816 The selected command will be executed.  Interactively, prompt the
   1817 user for a KEYMAP variable."
   1818   (interactive
   1819    (list
   1820     (symbol-value
   1821      (intern-soft
   1822       (completing-read
   1823        "Keymap: "
   1824        (embark--with-category
   1825         'variable
   1826         (cl-loop for x being the symbols
   1827                  if (and (boundp x) (keymapp (symbol-value x)))
   1828                  collect (symbol-name x)))
   1829        nil t nil 'variable-name-history
   1830        (let ((major-mode-map
   1831               (concat (symbol-name major-mode) "-map")))
   1832          (when (intern-soft major-mode-map) major-mode-map)))))))
   1833   (when-let (command (embark-completing-read-prompter keymap nil 'no-default))
   1834     (call-interactively command)))
   1835 
   1836 ;;;###autoload
   1837 (defun embark-bindings (global)
   1838   "Explore current command key bindings with `completing-read'.
   1839 The selected command will be executed.
   1840 
   1841 This shows key bindings from minor mode maps and the local
   1842 map (usually set by the major mode), but also less common keymaps
   1843 such as those from a text property or overlay, or the overriding
   1844 maps: `overriding-terminal-local-map' and `overriding-local-map'.
   1845 
   1846 Additionally, if GLOBAL is non-nil (interactively, if called with
   1847 a prefix argument), this command includes global key bindings."
   1848   (interactive "P")
   1849   (embark-bindings-in-keymap
   1850    (make-composed-keymap
   1851     (let ((all-maps (current-active-maps t)))
   1852       (if global all-maps (remq global-map all-maps))))))
   1853 
   1854 ;;;###autoload
   1855 (defun embark-bindings-at-point ()
   1856   "Explore all key bindings at point with `completing-read'.
   1857 The selected command will be executed.
   1858 
   1859 This command lists key bindings found in keymaps specified by the
   1860 text properties `keymap' or `local-map', from either buffer text
   1861 or an overlay.  These are not widely used in Emacs, and when they
   1862 are used can be somewhat hard to discover.  Examples of locations
   1863 that have such a keymap are links and images in `eww' buffers,
   1864 attachment links in `gnus' article buffers, and the stash line
   1865 in a `vc-dir' buffer."
   1866   (interactive)
   1867   (if-let ((keymaps (delq nil (list (get-char-property (point) 'keymap)
   1868                                     (get-char-property (point) 'local-map)))))
   1869       (embark-bindings-in-keymap (make-composed-keymap keymaps))
   1870     (user-error "No key bindings found at point")))
   1871 
   1872 ;;;###autoload
   1873 (defun embark-prefix-help-command ()
   1874   "Prompt for and run a command bound in the prefix used for this command.
   1875 The prefix described consists of all but the last event of the
   1876 key sequence that ran this command.  This function is intended to
   1877 be used as a value for `prefix-help-command'.
   1878 
   1879 In addition to using completion to select a command, you can also
   1880 type @ and the key binding (without the prefix)."
   1881   (interactive)
   1882   (when-let ((keys (this-command-keys-vector))
   1883              (prefix (seq-take keys (1- (length keys))))
   1884              (keymap (key-binding prefix 'accept-default)))
   1885     (minibuffer-with-setup-hook
   1886         (lambda ()
   1887           (let ((pt (- (minibuffer-prompt-end) 2)))
   1888             (overlay-put (make-overlay pt pt) 'before-string
   1889                          (format " under %s" (key-description prefix)))))
   1890       (embark-bindings-in-keymap keymap))))
   1891 
   1892 (defun embark--prompt (indicators keymap targets)
   1893   "Call the prompter with KEYMAP and INDICATORS.
   1894 The TARGETS are displayed for actions outside the minibuffer."
   1895   (mapc (lambda (i) (funcall i keymap targets)) indicators)
   1896   (condition-case nil
   1897       (minibuffer-with-setup-hook
   1898           (lambda ()
   1899             ;; if the prompter opens its own minibuffer, show
   1900             ;; the indicator there too
   1901             (let ((inner-indicators (mapcar #'funcall embark-indicators)))
   1902               (mapc (lambda (i) (funcall i keymap targets)) inner-indicators)
   1903               (add-hook 'minibuffer-exit-hook
   1904                         (lambda () (mapc #'funcall inner-indicators))
   1905                         nil t)))
   1906         (let ((enable-recursive-minibuffers t))
   1907           (funcall embark-prompter keymap
   1908                    (lambda (prefix)
   1909                      (mapc (lambda (i) (funcall i keymap targets prefix))
   1910                            indicators)))))
   1911     (quit nil)))
   1912 
   1913 (defvar embark--run-after-command-functions nil
   1914   "Abnormal hook, used by `embark--run-after-command'.")
   1915 
   1916 (defun embark--run-after-command (fn &rest args)
   1917   "Call FN with ARGS after the current commands finishes.
   1918 If multiple functions are queued with this function during the
   1919 same command, they will be called in the order from the one
   1920 queued most recently to the one queued least recently."
   1921   ;; We don't simply add FN to `post-command-hook' because FN may recursively
   1922   ;; call this function.  In that case, FN would modify `post-command-hook'
   1923   ;; from within post-command-hook, which doesn't behave properly in our case.
   1924   ;; We use our own abnormal hook and run it from PCH in a way that it is OK to
   1925   ;; modify it from within its own functions.
   1926   (unless embark--run-after-command-functions
   1927     (let (pch timer has-run)
   1928       (setq pch
   1929             (lambda ()
   1930               (remove-hook 'post-command-hook pch)
   1931               (cancel-timer timer)
   1932               (unless has-run
   1933                 (setq has-run t)
   1934                 (while embark--run-after-command-functions
   1935                   ;; The following funcall may recursively call
   1936                   ;; `embark--run-after-command', modifying
   1937                   ;; `embark--run-after-command-functions'.  This is why this
   1938                   ;; loop has to be implemented carefully.  We have to pop the
   1939                   ;; function off the hook before calling it.  Using `dolist'
   1940                   ;; on the hook would also be incorrect, because it wouldn't
   1941                   ;; take modifications of this hook into account.
   1942                   (with-demoted-errors "embark PCH: %S"
   1943                     (condition-case nil
   1944                         (funcall (pop embark--run-after-command-functions))
   1945                       (quit (message "Quit"))))))))
   1946       (add-hook 'post-command-hook pch 'append)
   1947       ;; Generally we prefer `post-command-hook' because it plays well with
   1948       ;; keyboard macros.  In some cases, `post-command-hook' isn't run after
   1949       ;; exiting a recursive edit, so set up the following timer as a backup.
   1950       (setq timer (run-at-time 0 nil pch))))
   1951 
   1952   ;; Keep the default-directory alive, since this is often overwritten,
   1953   ;; for example by Consult commands.
   1954   ;; TODO it might be necessary to add more dynamically bound variables
   1955   ;; here. What we actually want are functions `capture-dynamic-scope'
   1956   ;; and `eval-in-dynamic-scope', but this does not exist?
   1957   (let ((dir default-directory))
   1958     (push (lambda ()
   1959             (let ((default-directory dir))
   1960               (apply fn args)))
   1961           embark--run-after-command-functions)))
   1962 
   1963 (defun embark--quit-and-run (fn &rest args)
   1964   "Quit the minibuffer and then call FN with ARGS.
   1965 If called outside the minibuffer, simply apply FN to ARGS."
   1966   (if (not (minibufferp))
   1967       (apply fn args)
   1968     (apply #'embark--run-after-command fn args)
   1969     (embark--run-after-command #'set 'ring-bell-function ring-bell-function)
   1970     (setq ring-bell-function #'ignore)
   1971     (minibuffer-quit-recursive-edit)))
   1972 
   1973 (defun embark--run-action-hooks (hooks action target quit)
   1974   "Run HOOKS for ACTION.
   1975 The HOOKS argument must be alist.  The keys t and :always are
   1976 treated specially.  The :always hooks are executed always and the
   1977 t hooks are the default hooks, for when there are no
   1978 command-specific hooks for ACTION.  The QUIT, ACTION and TARGET
   1979 arguments are passed to the hooks as keyword arguments."
   1980   (mapc (lambda (h) (apply h :action action :quit quit target))
   1981         (or (alist-get action hooks)
   1982             (alist-get t hooks)))
   1983   (mapc (lambda (h) (apply h :action action :quit quit target))
   1984         (alist-get :always hooks)))
   1985 
   1986 (defun embark--run-around-action-hooks
   1987     (action target quit &optional non-interactive)
   1988   "Run the `embark-around-action-hooks' for ACTION.
   1989 All the applicable around hooks are composed in the order they
   1990 are present in `embark-around-action-hooks'.  The keys t and
   1991 :always in `embark-around-action-hooks' are treated specially.
   1992 The :always hooks are executed always (outermost) and the t hooks
   1993 are the default hooks, for when there are no command-specific
   1994 hooks for ACTION.  The QUIT, ACTION and TARGET arguments are
   1995 passed to the hooks as keyword arguments.
   1996 
   1997 The optional argument NON-INTERACTIVE controls whether the action
   1998 is run with `command-execute' or with `funcall' passing the
   1999 target as argument."
   2000   (apply
   2001    (seq-reduce
   2002     (lambda (fn hook)
   2003       (lambda (&rest args) (apply hook (plist-put args :run fn))))
   2004     (let ((hooks embark-around-action-hooks))
   2005       (reverse
   2006        (append (or (alist-get action hooks) (alist-get t hooks))
   2007                (alist-get :always hooks))))
   2008     (if non-interactive
   2009         (lambda (&rest args)
   2010           (funcall (plist-get args :action)
   2011                    (or (plist-get args :candidates) (plist-get args :target))))
   2012       (lambda (&rest args)
   2013         (command-execute (plist-get args :action)))))
   2014    :action action :quit quit target))
   2015 
   2016 (defun embark--act (action target &optional quit)
   2017   "Perform ACTION injecting the TARGET.
   2018 If called from a minibuffer with non-nil QUIT, quit the
   2019 minibuffer before executing the action."
   2020   (if (memq action '(embark-become       ; these actions should run in
   2021                      embark-collect      ; the current buffer, not the
   2022                      embark-live         ; target buffer
   2023                      embark-export
   2024                      embark-select
   2025                      embark-act-all))
   2026       (progn
   2027         (embark--run-action-hooks embark-pre-action-hooks action target quit)
   2028         (unwind-protect (embark--run-around-action-hooks action target quit)
   2029           (embark--run-action-hooks embark-post-action-hooks
   2030                                     action target quit)))
   2031     (let* ((command embark--command)
   2032            (prefix prefix-arg)
   2033            (action-window (embark--target-window t))
   2034            (directory default-directory)
   2035            (inject
   2036             (lambda ()
   2037               (let ((contents (minibuffer-contents)))
   2038                 (delete-minibuffer-contents)
   2039                 (insert
   2040                  (propertize
   2041                   (substring-no-properties (plist-get target :target))
   2042                   'embark--initial-input contents)))
   2043               (if (memq 'ivy--queue-exhibit post-command-hook)
   2044                   ;; Ivy has special needs: (1) for file names
   2045                   ;; ivy-immediate-done is not equivalent to
   2046                   ;; exit-minibuffer, (2) it needs a chance to run
   2047                   ;; its post command hook first, so use depth 10
   2048                   (add-hook 'post-command-hook 'ivy-immediate-done 10 t)
   2049                 (add-hook 'post-command-hook #'exit-minibuffer nil t))
   2050               (embark--run-action-hooks embark-target-injection-hooks
   2051                                         action target quit)))
   2052            (dedicate (and (derived-mode-p 'embark-collect-mode)
   2053                           (not (window-dedicated-p))
   2054                           (selected-window)))
   2055            (multi (memq action embark-multitarget-actions))
   2056            (run-action
   2057             (if (and (commandp action) (not multi))
   2058                 (lambda ()
   2059                   (let (final-window)
   2060                     (when dedicate (set-window-dedicated-p dedicate t))
   2061                     (unwind-protect
   2062                         (with-selected-window action-window
   2063                           (let ((enable-recursive-minibuffers t)
   2064                                 (embark--command command)
   2065                                 (prefix-arg prefix)
   2066                                 ;; the next two avoid mouse dialogs
   2067                                 (use-dialog-box nil)
   2068                                 (last-nonmenu-event 13)
   2069                                 (default-directory directory))
   2070                             (embark--run-action-hooks embark-pre-action-hooks
   2071                                                       action target quit)
   2072                             (minibuffer-with-setup-hook inject
   2073                               ;; pacify commands that use (this-command-keys)
   2074                               (when (= (length (this-command-keys)) 0)
   2075                                 (set--this-command-keys
   2076                                  (if (characterp last-command-event)
   2077                                      (string last-command-event)
   2078                                   "\r")))
   2079                               (setq this-command action)
   2080                               (embark--run-around-action-hooks
   2081                                action target quit)))
   2082                           (setq final-window (selected-window)))
   2083                       (embark--run-action-hooks embark-post-action-hooks
   2084                                                 action target quit)
   2085                       (when dedicate (set-window-dedicated-p dedicate nil)))
   2086                     (unless (eq final-window action-window)
   2087                       (select-window final-window))))
   2088               (let ((target
   2089                      (if (and multi (null (plist-get target :candidates)))
   2090                          (plist-put
   2091                           target :candidates (list (plist-get target :target)))
   2092                        target)))
   2093                 (lambda ()
   2094                   (with-selected-window action-window
   2095                     (embark--run-action-hooks embark-pre-action-hooks
   2096                                               action target quit)
   2097                     (unwind-protect
   2098                         (let ((current-prefix-arg prefix)
   2099                               (default-directory directory))
   2100                           (embark--run-around-action-hooks
   2101                            action target quit :non-interactive))
   2102                       (embark--run-action-hooks embark-post-action-hooks
   2103                                                 action target quit))))))))
   2104       (setq prefix-arg nil)
   2105       (if quit (embark--quit-and-run run-action) (funcall run-action)))))
   2106 
   2107 (defun embark--refine-multi-category (_type target)
   2108   "Refine `multi-category' TARGET to its actual type."
   2109   (or (let ((mc (get-text-property 0 'multi-category target)))
   2110         (cond
   2111          ;; The `cdr' of the `multi-category' property can be a buffer object.
   2112          ((and (eq (car mc) 'buffer) (buffer-live-p (cdr mc)))
   2113           (cons 'buffer (buffer-name (cdr mc))))
   2114          ((stringp (cdr mc)) mc)))
   2115       (cons 'general target)))
   2116 
   2117 (defun embark--simplify-path (_type target)
   2118   "Simplify and '//' or '~/' in the TARGET file path."
   2119   (cons 'file (substitute-in-file-name target)))
   2120 
   2121 (defun embark--keybinding-command (_type target)
   2122   "Treat an `embark-keybinding' TARGET as a command."
   2123   (when-let ((cmd (get-text-property 0 'embark-command target)))
   2124     (cons 'command (format "%s" cmd))))
   2125 
   2126 (defun embark--lookup-lighter-minor-mode (_type target)
   2127   "If TARGET is a lighter, look up its minor mode.
   2128 
   2129 The `describe-minor-mode' command has as completion candidates
   2130 both minor-modes and their lighters.  This function replaces the
   2131 lighters by their minor modes, so actions expecting a function
   2132 work on them."
   2133   (cons 'minor-mode
   2134         (let ((symbol (intern-soft target)))
   2135           (if (and symbol (boundp symbol))
   2136               target
   2137             (symbol-name (lookup-minor-mode-from-indicator target))))))
   2138 
   2139 (declare-function project-current "project")
   2140 (declare-function project-root "project")
   2141 
   2142 (defun embark--project-file-full-path (_type target)
   2143   "Get full path of project file TARGET."
   2144   ;; TODO project-find-file can be called from outside all projects in
   2145   ;; which case it prompts for a project first; we don't support that
   2146   ;; case yet, since there is no current project.
   2147   (cons 'file
   2148         (if-let ((project (project-current))
   2149                  (root (project-root project)))
   2150             (expand-file-name target root)
   2151           target)))
   2152 
   2153 (defun embark--remove-package-version (_type target)
   2154   "Remove version number from a versioned package TARGET."
   2155   (cons 'package (replace-regexp-in-string "-[0-9.]+$" "" target)))
   2156 
   2157 (defun embark--targets ()
   2158   "Retrieve current targets.
   2159 
   2160 An initial guess at the current targets and their types is
   2161 determined by running the functions in `embark-target-finders'.
   2162 Each function should either return nil, a pair of a type symbol
   2163 and target string or a triple of a type symbol, target string and
   2164 target bounds.
   2165 
   2166 In the minibuffer only the first target finder returning non-nil
   2167 is taken into account.  When finding targets at point in other
   2168 buffers, all target finder functions are executed.
   2169 
   2170 For each target, the type is then looked up as a key in the
   2171 variable `embark-transformer-alist'.  If there is a transformer
   2172 for the type, it is called with the type and target, and must
   2173 return a `cons' of the transformed type and transformed target.
   2174 
   2175 The return value of `embark--targets' is a list of plists.  Each
   2176 plist concerns one target, and has keys `:type', `:target',
   2177 `:orig-type', `:orig-target' and `:bounds'."
   2178   (let (targets)
   2179     (run-hook-wrapped
   2180      'embark-target-finders
   2181      (lambda (fun)
   2182        (dolist (found (when-let (result (funcall fun))
   2183                         (if (consp (car result)) result (list result))))
   2184          (let* ((type (or (car found) 'general))
   2185                 (target+bounds (cdr found))
   2186                 (target (if (consp target+bounds)
   2187                             (car target+bounds)
   2188                           target+bounds))
   2189                 (bounds (and (consp target+bounds) (cdr target+bounds)))
   2190                 (full-target
   2191                  (append
   2192                   (list :orig-type type :orig-target target :bounds bounds)
   2193                   (if-let (transform (alist-get type embark-transformer-alist))
   2194                       (let ((trans (funcall transform type target)))
   2195                         (list :type (car trans) :target (cdr trans)))
   2196                     (list :type type :target target)))))
   2197            (push full-target targets)))
   2198        (and targets (minibufferp))))
   2199     (nreverse
   2200      (cl-delete-duplicates ; keeps last duplicate, but we reverse
   2201       targets
   2202       :test (lambda (t1 t2)
   2203               (and (equal (plist-get t1 :target) (plist-get t2 :target))
   2204                    (eq (plist-get t1 :type) (plist-get t2 :type))))))))
   2205 
   2206 (defun embark--default-action (type)
   2207   "Return default action for the given TYPE of target.
   2208 The most common case is that the target comes from minibuffer
   2209 completion, in which case the default action is the command that
   2210 opened the minibuffer in the first place.  This can be overridden
   2211 by `embark-default-action-overrides'.
   2212 
   2213 For targets that do not come from minibuffer completion
   2214 \(typically some thing at point in a regular buffer) and whose
   2215 type is not listed in `embark-default-action-overrides', the
   2216 default action is given by whatever binding RET has in the action
   2217 keymap for the given type."
   2218   (or (alist-get (cons type embark--command) embark-default-action-overrides
   2219                  nil nil #'equal)
   2220       (alist-get type embark-default-action-overrides)
   2221       (alist-get t embark-default-action-overrides)
   2222       embark--command
   2223       (lookup-key (embark--raw-action-keymap type) "\r")))
   2224 
   2225 (defun embark--rotate (list k)
   2226   "Rotate LIST by K elements and return the rotated list."
   2227   (setq k (mod k (length list)))
   2228   (append (seq-drop list k) (seq-take list k)))
   2229 
   2230 (defun embark--orig-target (target)
   2231   "Convert TARGET to original target."
   2232   (plist-put
   2233    (plist-put
   2234     (copy-sequence target)
   2235     :target (plist-get target :orig-target))
   2236    :type (plist-get target :orig-type)))
   2237 
   2238 (defun embark--quit-p (action)
   2239   "Determine whether to quit the minibuffer after ACTION.
   2240 This function consults `embark-quit-after-action' to decide
   2241 whether or not the user wishes to quit the minibuffer after
   2242 performing the ACTION, assuming this is done from a minibuffer."
   2243   (let* ((cfg embark-quit-after-action)
   2244          (quit (if (consp cfg) (alist-get action cfg (alist-get t cfg)) cfg)))
   2245     (when embark--toggle-quit (setq quit (not quit)))
   2246     (setq embark--toggle-quit nil)
   2247     quit))
   2248 
   2249 ;;;###autoload
   2250 (defun embark-act (&optional arg)
   2251   "Prompt the user for an action and perform it.
   2252 The targets of the action are chosen by `embark-target-finders'.
   2253 By default, if called from a minibuffer the target is the top
   2254 completion candidate.  When called from a non-minibuffer buffer
   2255 there can multiple targets and you can cycle among them by using
   2256 `embark-cycle' (which is bound by default to the same key
   2257 binding `embark-act' is, but see `embark-cycle-key').
   2258 
   2259 This command uses `embark-prompter' to ask the user to specify an
   2260 action, and calls it injecting the target at the first minibuffer
   2261 prompt.
   2262 
   2263 If you call this from the minibuffer, it can optionally quit the
   2264 minibuffer.  The variable `embark-quit-after-action' controls
   2265 whether calling `embark-act' with nil ARG quits the minibuffer,
   2266 and if ARG is non-nil it will do the opposite.  Interactively,
   2267 ARG is the prefix argument.
   2268 
   2269 If instead you call this from outside the minibuffer, the first
   2270 ARG targets are skipped over (if ARG is negative the skipping is
   2271 done by cycling backwards) and cycling starts from the following
   2272 target."
   2273   (interactive "P")
   2274   (let* ((targets (or (embark--targets) (user-error "No target found")))
   2275          (indicators (mapcar #'funcall embark-indicators))
   2276          (default-done nil))
   2277     (when arg
   2278       (if (minibufferp)
   2279           (embark-toggle-quit)
   2280         (setq targets (embark--rotate targets (prefix-numeric-value arg)))))
   2281     (unwind-protect
   2282         (while
   2283             (let* ((target (car targets))
   2284                    (action
   2285                     (or (embark--prompt
   2286                          indicators
   2287                          (let ((embark-default-action-overrides
   2288                                 (if default-done
   2289                                     `((t . ,default-done))
   2290                                   embark-default-action-overrides)))
   2291                            (embark--action-keymap (plist-get target :type)
   2292                                                   (cdr targets)))
   2293                          targets)
   2294                         (user-error "Canceled")))
   2295                    (default-action (or default-done
   2296                                        (embark--default-action
   2297                                         (plist-get target :type)))))
   2298               (cond
   2299                ;; When acting twice in the minibuffer, do not restart
   2300                ;; `embark-act'.  Otherwise the next `embark-act' will
   2301                ;; find a target in the original buffer.
   2302                ((eq action #'embark-act)
   2303                 (message "Press an action key"))
   2304                ((eq action #'embark-cycle)
   2305                 (setq targets (embark--rotate
   2306                                targets (prefix-numeric-value prefix-arg))))
   2307                (t
   2308                 ;; if the action is non-repeatable, cleanup indicator now
   2309                 (let ((repeat (embark--action-repeatable-p action)))
   2310                   (unless repeat (mapc #'funcall indicators))
   2311                   (condition-case err
   2312                       (embark--act
   2313                        action
   2314                        (if (and (eq action default-action)
   2315                                 (eq action embark--command)
   2316                                 (not (memq action embark-multitarget-actions)))
   2317                            (embark--orig-target target)
   2318                          target)
   2319                        (embark--quit-p action))
   2320                     (user-error
   2321                      (funcall (if repeat #'message #'user-error)
   2322                               "%s" (cadr err))))
   2323                   (when-let (new-targets (and repeat (embark--targets)))
   2324                     ;; Terminate repeated prompter on default action,
   2325                     ;; when repeating. Jump to the region type if the
   2326                     ;; region is active after the action, or else to the
   2327                     ;; current type again.
   2328                     (setq default-done #'embark-done
   2329                           targets
   2330                           (embark--rotate
   2331                            new-targets
   2332                            (or (cl-position-if
   2333                                 (let ((desired-type
   2334                                        (if (eq repeat t)
   2335                                            (plist-get (car targets) :type)
   2336                                          repeat)))
   2337                                   (lambda (x)
   2338                                     (eq (plist-get x :type) desired-type)))
   2339                                 new-targets)
   2340                                0)))))))))
   2341       (mapc #'funcall indicators))))
   2342 
   2343 (defun embark--maybe-transform-candidates ()
   2344   "Collect candidates and see if they all transform to the same type.
   2345 Return a plist with keys `:type', `:orig-type', `:candidates', and
   2346 `:orig-candidates'."
   2347   (pcase-let* ((`(,type . ,candidates)
   2348                 (run-hook-with-args-until-success 'embark-candidate-collectors))
   2349                (bounds (mapcar #'cdr-safe candidates)))
   2350     (setq candidates
   2351           (mapcar (lambda (x) (if (consp x) (car x) x)) candidates))
   2352     (when (eq type 'file)
   2353       (let ((dir (embark--default-directory)))
   2354         (setq candidates
   2355               (mapcar (lambda (cand)
   2356                         (abbreviate-file-name
   2357                          (expand-file-name (substitute-in-file-name cand) dir)))
   2358                       candidates))))
   2359     ;; TODO more systematic approach to applying substitute-in-file-name
   2360     (append
   2361      (list :orig-type type :orig-candidates candidates :bounds bounds)
   2362      (or (when candidates
   2363            (when-let ((transformer (alist-get type embark-transformer-alist)))
   2364              (pcase-let* ((`(,new-type . ,first-cand)
   2365                            (funcall transformer type (car candidates))))
   2366                (let ((new-candidates (list first-cand)))
   2367                  (when (cl-every
   2368                         (lambda (cand)
   2369                           (pcase-let ((`(,t-type . ,t-cand)
   2370                                        (funcall transformer type cand)))
   2371                             (when (eq t-type new-type)
   2372                               (push t-cand new-candidates)
   2373                               t)))
   2374                         (cdr candidates))
   2375                    (list :type new-type
   2376                          :candidates (nreverse new-candidates)))))))
   2377          (list :type type :candidates candidates)))))
   2378 
   2379 ;;;###autoload
   2380 (defun embark-act-all (&optional arg)
   2381   "Prompt the user for an action and perform it on each candidate.
   2382 The candidates are chosen by `embark-candidate-collectors'.  By
   2383 default, if `embark-select' has been used to select some
   2384 candidates, then `embark-act-all' will act on those candidates;
   2385 otherwise, if the selection is empty and `embark-act-all' is
   2386 called from a minibuffer, then the candidates are the completion
   2387 candidates.
   2388 
   2389 This command uses `embark-prompter' to ask the user to specify an
   2390 action, and calls it injecting the target at the first minibuffer
   2391 prompt.
   2392 
   2393 If you call this from the minibuffer, it can optionally quit the
   2394 minibuffer.  The variable `embark-quit-after-action' controls
   2395 whether calling `embark-act' with nil ARG quits the minibuffer,
   2396 and if ARG is non-nil it will do the opposite.  Interactively,
   2397 ARG is the prefix argument."
   2398   (interactive "P")
   2399   (let* ((transformed (embark--maybe-transform-candidates))
   2400          (type (plist-get transformed :type))
   2401          (orig-type (plist-get transformed :orig-type))
   2402          (candidates
   2403           (or (cl-mapcar
   2404                (lambda (cand orig-cand bounds)
   2405                  (list :type type :target cand
   2406                        :bounds (when bounds
   2407                                  (cons (copy-marker (car bounds))
   2408                                        (copy-marker (cdr bounds))))
   2409                        :orig-type orig-type :orig-target orig-cand))
   2410                (plist-get transformed :candidates)
   2411                (plist-get transformed :orig-candidates)
   2412                (plist-get transformed :bounds))
   2413               (user-error "No candidates to act on")))
   2414          (indicators (mapcar #'funcall embark-indicators)))
   2415     (when arg (embark-toggle-quit))
   2416     (unwind-protect
   2417         (let* ((action
   2418                 (or (embark--prompt
   2419                      indicators (embark--action-keymap type nil)
   2420                      (list (list :type type :multi (length candidates))))
   2421                     (user-error "Canceled")))
   2422                (prefix prefix-arg)
   2423                (act (lambda (candidate)
   2424                       (cl-letf (((symbol-function 'embark--restart) #'ignore)
   2425                                 ((symbol-function 'embark--confirm) #'ignore))
   2426                         (let ((prefix-arg prefix))
   2427                           (when-let ((bounds (plist-get candidate :bounds)))
   2428                             (goto-char (car bounds)))
   2429                           (embark--act action candidate)))))
   2430                (quit (embark--quit-p action)))
   2431           (when (and (eq action (embark--default-action type))
   2432                      (eq action embark--command))
   2433             (setq candidates (mapcar #'embark--orig-target candidates)))
   2434           (when (or (not (or embark-confirm-act-all
   2435                              (memq 'embark--confirm
   2436                                    (alist-get action embark-pre-action-hooks))))
   2437                     (y-or-n-p (format "Run %s on %d %ss? "
   2438                                       action (length candidates) type)))
   2439             (if (memq action embark-multitarget-actions)
   2440                 (let ((prefix-arg prefix))
   2441                   (embark--act action transformed quit))
   2442               (save-excursion
   2443                 (if quit
   2444                     (embark--quit-and-run #'mapc act candidates)
   2445                   (mapc act candidates))))
   2446             (when (and (not quit)
   2447                        (memq 'embark--restart
   2448                              (alist-get action embark-post-action-hooks)))
   2449               (embark--restart))))
   2450       (dolist (cand candidates)
   2451         (when-let ((bounds (plist-get cand :bounds)))
   2452           (set-marker (car bounds) nil) ; yay, manual memory management!
   2453           (set-marker (cdr bounds) nil)))
   2454       (setq prefix-arg nil)
   2455       (mapc #'funcall indicators))))
   2456 
   2457 (defun embark-highlight-indicator ()
   2458   "Action indicator highlighting the target at point."
   2459   (let (overlay)
   2460     (lambda (&optional keymap targets _prefix)
   2461       (let ((bounds (plist-get (car targets) :bounds)))
   2462         (when (and overlay (or (not keymap) (not bounds)))
   2463           (delete-overlay overlay)
   2464           (setq overlay nil))
   2465         (when bounds
   2466           (if overlay
   2467               (move-overlay overlay (car bounds) (cdr bounds))
   2468             (setq overlay (make-overlay (car bounds) (cdr bounds)))
   2469             (overlay-put overlay 'category 'embark-target-overlay))
   2470           (overlay-put overlay 'window (selected-window)))))))
   2471 
   2472 (defun embark-isearch-highlight-indicator ()
   2473   "Action indicator highlighting all occurrences of the identifier at point.
   2474 This indicator only does something for targets which are
   2475 identifiers or symbols.  For those it uses `isearch''s lazy
   2476 highlighting feature to highlight all occurrences of the target in
   2477 the buffer.  This indicator is best used in conjunction with
   2478 `embark-highlight-indicator': by using them both you get the
   2479 target and the other occurrences of it highlighted in different
   2480 colors."
   2481   (lambda (&optional _keymap targets _prefix)
   2482     (if (and (not (minibufferp))
   2483              (memq (plist-get (car targets) :orig-type) '(symbol identifier)))
   2484         (let ((isearch-string (plist-get (car targets) :target))
   2485               (isearch-regexp-function #'isearch-symbol-regexp))
   2486           (isearch-lazy-highlight-new-loop))
   2487       (setq isearch-lazy-highlight-last-string nil)
   2488       (lazy-highlight-cleanup t))))
   2489 
   2490 (defun embark-cycle (_arg)
   2491   "Cycle over the next ARG targets at point.
   2492 If ARG is negative, cycle backwards."
   2493   (interactive "p")
   2494   (user-error "Not meant to be called directly"))
   2495 
   2496 (defun embark-done ()
   2497   "Terminate sequence of repeated actions."
   2498   (interactive))
   2499 
   2500 ;;;###autoload
   2501 (defun embark-dwim (&optional arg)
   2502   "Run the default action on the current target.
   2503 The target of the action is chosen by `embark-target-finders'.
   2504 
   2505 If the target comes from minibuffer completion, then the default
   2506 action is the command that opened the minibuffer in the first
   2507 place, unless overridden by `embark-default-action-overrides'.
   2508 
   2509 For targets that do not come from minibuffer completion
   2510 \(typically some thing at point in a regular buffer) and whose
   2511 type is not listed in `embark-default-action-overrides', the
   2512 default action is given by whatever binding RET has in the action
   2513 keymap for the target's type.
   2514 
   2515 See `embark-act' for the meaning of the prefix ARG."
   2516   (interactive "P")
   2517   (if-let ((targets (embark--targets)))
   2518       (let* ((target
   2519               (or (nth
   2520                    (if (or (null arg) (minibufferp))
   2521                        0
   2522                      (mod (prefix-numeric-value arg) (length targets)))
   2523                    targets)))
   2524              (type (plist-get target :type))
   2525              (default-action (embark--default-action type))
   2526              (action (or (command-remapping default-action) default-action)))
   2527         (unless action
   2528           (user-error "No default action for %s targets" type))
   2529         (when (and arg (minibufferp)) (setq embark--toggle-quit t))
   2530         (embark--act action
   2531                      (if (and (eq default-action embark--command)
   2532                               (not (memq default-action
   2533                                          embark-multitarget-actions)))
   2534                          (embark--orig-target target)
   2535                        target)
   2536                      (embark--quit-p action)))
   2537     (user-error "No target found")))
   2538 
   2539 (defun embark--become-keymap ()
   2540   "Return keymap of commands to become for current command."
   2541   (let ((map (make-composed-keymap
   2542               (cl-loop for keymap-name in embark-become-keymaps
   2543                        for keymap = (symbol-value keymap-name)
   2544                        when (where-is-internal embark--command (list keymap))
   2545                        collect keymap))))
   2546     (when embark-help-key
   2547       (keymap-set map embark-help-key #'embark-keymap-help))
   2548     map))
   2549 
   2550 ;;;###autoload
   2551 (defun embark-become (&optional full)
   2552   "Make current command become a different command.
   2553 Take the current minibuffer input as initial input for new
   2554 command.  The new command can be run normally using key bindings or
   2555 \\[execute-extended-command], but if the current command is found in a keymap in
   2556 `embark-become-keymaps', that keymap is activated to provide
   2557 convenient access to the other commands in it.
   2558 
   2559 If FULL is non-nil (interactively, if called with a prefix
   2560 argument), the entire minibuffer contents are used as the initial
   2561 input of the new command.  By default only the part of the
   2562 minibuffer contents between the current completion boundaries is
   2563 taken.  What this means is fairly technical, but (1) usually
   2564 there is no difference: the completion boundaries include the
   2565 entire minibuffer contents, and (2) the most common case where
   2566 these notions differ is file completion, in which case the
   2567 completion boundaries single out the path component containing
   2568 point."
   2569   (interactive "P")
   2570   (unless (minibufferp)
   2571     (user-error "Not in a minibuffer"))
   2572   (let* ((target (embark--display-string ; remove invisible portions
   2573                   (if full
   2574                       (minibuffer-contents)
   2575                     (pcase-let ((`(,beg . ,end) (embark--boundaries)))
   2576                       (substring (minibuffer-contents) beg
   2577                                  (+ end (embark--minibuffer-point)))))))
   2578          (keymap (embark--become-keymap))
   2579          (targets `((:type embark-become :target ,target)))
   2580          (indicators (mapcar #'funcall embark-indicators))
   2581          (become (unwind-protect
   2582                      (embark--prompt indicators keymap targets)
   2583                    (mapc #'funcall indicators))))
   2584     (unless become
   2585       (user-error "Canceled"))
   2586     (embark--become-command become target)))
   2587 
   2588 (defun embark--become-command (command input)
   2589   "Quit current minibuffer and start COMMAND with INPUT."
   2590   (embark--quit-and-run
   2591    (lambda ()
   2592      (minibuffer-with-setup-hook
   2593          (lambda ()
   2594            (delete-minibuffer-contents)
   2595            (insert input))
   2596        (let ((use-dialog-box nil) ;; avoid mouse dialogs
   2597              (last-nonmenu-event 13))
   2598          (setq this-command command)
   2599          (command-execute command))))))
   2600 
   2601 ;;; Embark collect
   2602 
   2603 (defgroup embark-collect nil
   2604   "Buffers for acting on collected Embark targets."
   2605   :group 'embark)
   2606 
   2607 (defcustom embark-candidate-collectors
   2608   '(embark-selected-candidates
   2609     embark-minibuffer-candidates
   2610     embark-completion-list-candidates
   2611     embark-dired-candidates
   2612     embark-ibuffer-candidates
   2613     embark-embark-collect-candidates
   2614     embark-custom-candidates)
   2615   "List of functions that collect all candidates in a given context.
   2616 These are used to fill an Embark Collect buffer.  Each function
   2617 should return either nil (to indicate it found no candidates) or
   2618 a list whose first element is a symbol indicating the type of
   2619 candidates and whose `cdr' is the list of candidates, each of
   2620 which should be either a string or a dotted list of the
   2621 form (TARGET START . END), where START and END are the buffer
   2622 positions bounding the TARGET string."
   2623   :type 'hook)
   2624 
   2625 (defcustom embark-exporters-alist
   2626   '((buffer . embark-export-ibuffer)
   2627     (file . embark-export-dired)
   2628     (package . embark-export-list-packages)
   2629     (bookmark . embark-export-bookmarks)
   2630     (variable . embark-export-customize-variable)
   2631     (face . embark-export-customize-face)
   2632     (symbol . embark-export-apropos)
   2633     (minor-mode . embark-export-apropos)
   2634     (function . embark-export-apropos)
   2635     (command . embark-export-apropos)
   2636     (t . embark-collect))
   2637   "Alist associating completion types to export functions.
   2638 Each function should take a list of strings which are candidates
   2639 for actions and make a buffer appropriate to manage them.  For
   2640 example, the default is to make a Dired buffer for files, and an
   2641 ibuffer for buffers.
   2642 
   2643 The key t is also allowed in the alist, and the corresponding
   2644 value indicates the default function to use for other types.  The
   2645 default is `embark-collect'"
   2646   :type '(alist :key-type symbol :value-type function))
   2647 
   2648 (defcustom embark-after-export-hook nil
   2649   "Hook run after `embark-export' in the newly created buffer."
   2650   :type 'hook)
   2651 
   2652 (defface embark-collect-candidate '((t :inherit default))
   2653   "Face for candidates in Embark Collect buffers.")
   2654 
   2655 (defface embark-collect-group-title
   2656   '((t :inherit shadow :slant italic))
   2657   "Face for group titles in Embark Collect buffers.")
   2658 
   2659 (defface embark-collect-group-separator
   2660   '((t :inherit shadow :strike-through t :italic t))
   2661   "Face for group titles in Embark Collect buffers.")
   2662 
   2663 (defcustom embark-collect-group-format
   2664   (concat
   2665    (propertize "    " 'face 'embark-collect-group-separator)
   2666    (propertize " %s " 'face 'embark-collect-group-title)
   2667    (propertize " " 'face 'completions-group-separator
   2668                'display '(space :align-to right)))
   2669   "Format string used for the group title in Embark Collect buffers."
   2670   :type 'string)
   2671 
   2672 (defface embark-collect-annotation '((t :inherit completions-annotations))
   2673   "Face for annotations in Embark Collect.
   2674 This is only used for annotation that are not already fontified.")
   2675 
   2676 (defvar-local embark--rerun-function nil
   2677   "Function to rerun the collect or export that made the current buffer.")
   2678 
   2679 (autoload 'package-delete "package")
   2680 (declare-function package--from-builtin "package")
   2681 (declare-function package-desc-extras "package")
   2682 (declare-function package-desc-name "package")
   2683 (defvar package--builtins)
   2684 (defvar package-alist)
   2685 (defvar package-archive-contents)
   2686 (defvar package--initialized)
   2687 
   2688 (defun embark--package-desc (pkg)
   2689   "Return the description structure for package PKG."
   2690   (or ; found this in `describe-package-1'
   2691    (car (alist-get pkg package-alist))
   2692    (if-let ((built-in (assq pkg package--builtins)))
   2693            (package--from-builtin built-in)
   2694            (car (alist-get pkg package-archive-contents)))))
   2695 
   2696 (defun embark-minibuffer-candidates ()
   2697   "Return all current completion candidates from the minibuffer."
   2698   (when (minibufferp)
   2699     (let* ((all (completion-all-completions
   2700                  (minibuffer-contents)
   2701                  minibuffer-completion-table
   2702                  minibuffer-completion-predicate
   2703                  (embark--minibuffer-point)))
   2704            (last (last all)))
   2705       (when last (setcdr last nil))
   2706       (cons
   2707        (completion-metadata-get (embark--metadata) 'category)
   2708        all))))
   2709 
   2710 (defun embark-sorted-minibuffer-candidates ()
   2711   "Return a sorted list of current minibuffer completion candidates.
   2712 This using the same sort order that `icomplete' and
   2713 `minibuffer-force-complete' use.  The intended usage is that you
   2714 replace `embark-minibuffer-candidates' with this function in the
   2715 list `embark-candidate-collectors'."
   2716   (when (minibufferp)
   2717     (cons
   2718      (completion-metadata-get (embark--metadata) 'category)
   2719      (nconc (cl-copy-list (completion-all-sorted-completions)) nil))))
   2720 
   2721 (declare-function dired-get-marked-files "dired")
   2722 (declare-function dired-move-to-filename "dired")
   2723 (declare-function dired-move-to-end-of-filename "dired")
   2724 
   2725 (defun embark-dired-candidates ()
   2726   "Return marked or all files shown in Dired buffer.
   2727 If any buffer is marked, return marked buffers; otherwise, return
   2728 all buffers."
   2729   (when (derived-mode-p 'dired-mode)
   2730     (cons 'file
   2731           (or
   2732            ;; dired-get-marked-files returns the file on the current
   2733            ;; line if no marked files are found; and when the fourth
   2734            ;; argument is non-nil, the "no marked files" case is
   2735            ;; distinguished from the "single marked file" case by
   2736            ;; returning (list t marked-file) in the latter
   2737            (let ((marked (dired-get-marked-files t nil nil t)))
   2738              (and (cdr marked)
   2739                   (if (eq (car marked) t) (cdr marked) marked)))
   2740            (save-excursion
   2741              (goto-char (point-min))
   2742              (let (files)
   2743                (while (not (eobp))
   2744                  (when-let (file (dired-get-filename t t))
   2745                    (push `(,file
   2746                            ,(progn (dired-move-to-filename) (point))
   2747                            . ,(progn (dired-move-to-end-of-filename t) (point)))
   2748                          files))
   2749                  (forward-line))
   2750                (nreverse files)))))))
   2751 
   2752 (autoload 'ibuffer-marked-buffer-names "ibuffer")
   2753 (declare-function ibuffer-map-lines-nomodify "ibuffer")
   2754 
   2755 (defun embark-ibuffer-candidates ()
   2756   "Return marked or all buffers listed in ibuffer buffer.
   2757 If any buffer is marked, return marked buffers; otherwise, return
   2758 all buffers."
   2759   (when (derived-mode-p 'ibuffer-mode)
   2760     (cons 'buffer
   2761           (or (ibuffer-marked-buffer-names)
   2762               (let (buffers)
   2763                 (ibuffer-map-lines-nomodify
   2764                  (lambda (buffer _mark)
   2765                    (push (buffer-name buffer) buffers)))
   2766                 (nreverse buffers))))))
   2767 
   2768 (defun embark-embark-collect-candidates ()
   2769   "Return candidates in Embark Collect buffer.
   2770 This makes `embark-export' work in Embark Collect buffers."
   2771   (when (derived-mode-p 'embark-collect-mode)
   2772     (cons embark--type
   2773           (save-excursion
   2774             (goto-char (point-min))
   2775             (let (all)
   2776               (when-let ((cand (embark-target-collect-candidate)))
   2777                 (push (cdr cand) all))
   2778               (while (forward-button 1 nil nil t)
   2779                 (when-let ((cand (embark-target-collect-candidate)))
   2780                   (push (cdr cand) all)))
   2781               (nreverse all))))))
   2782 
   2783 (defun embark-completion-list-candidates ()
   2784   "Return all candidates in a completions buffer."
   2785   (when (derived-mode-p 'completion-list-mode)
   2786     (cons
   2787      embark--type
   2788      (save-excursion
   2789        (goto-char (point-min))
   2790        (next-completion 1)
   2791        (let (all)
   2792          (while (not (eobp))
   2793            (push (cdr (embark-target-completion-list-candidate)) all)
   2794            (next-completion 1))
   2795          (nreverse all))))))
   2796 
   2797 (defun embark-custom-candidates ()
   2798   "Return all variables and faces listed in this `Custom-mode' buffer."
   2799   (when (derived-mode-p 'Custom-mode)
   2800     (cons 'symbol ; gets refined to variable or face when acted upon
   2801           (save-excursion
   2802             (goto-char (point-min))
   2803             (let (symbols)
   2804               (while (not (eobp))
   2805                 (when-let (widget (widget-at (point)))
   2806                   (when (eq (car widget) 'custom-visibility)
   2807                     (push
   2808                      `(,(symbol-name
   2809                          (plist-get (cdr (plist-get (cdr widget) :parent))
   2810                                     :value))
   2811                        ,(point)
   2812                        . ,(progn
   2813                             (re-search-forward ":" (line-end-position) 'noerror)
   2814                             (point)))
   2815                      symbols)))
   2816                 (forward-line))
   2817               (nreverse symbols))))))
   2818 
   2819 
   2820 (defun embark-collect--target ()
   2821   "Return the Embark Collect candidate at point.
   2822 This takes into account `embark-transformer-alist'."
   2823   (let ((embark-target-finders '(embark-target-collect-candidate)))
   2824     (car (embark--targets))))
   2825 
   2826 (defun embark--action-command (action)
   2827   "Turn an ACTION into a command to perform the action.
   2828 Returns the name of the command."
   2829   (let ((name (intern (format "embark-action--%s"
   2830                               (embark--command-name action)))))
   2831     (fset name (lambda (arg)
   2832                  (interactive "P")
   2833                  (when-let (target (embark-collect--target))
   2834                    (let ((prefix-arg arg))
   2835                      (embark--act action target)))))
   2836     (when (fboundp action)
   2837       (put name 'function-documentation (documentation action)))
   2838     name))
   2839 
   2840 (defun embark--all-bindings (keymap &optional nested)
   2841   "Return an alist of all bindings in KEYMAP.
   2842 If NESTED is non-nil subkeymaps are not flattened."
   2843   (let (bindings maps)
   2844     (map-keymap
   2845      (lambda (key def)
   2846        (cond
   2847         ((keymapp def)
   2848          (if nested
   2849              (push (cons (vector key) def) maps)
   2850            (dolist (bind (embark--all-bindings def))
   2851              (push (cons (vconcat (vector key) (car bind)) (cdr bind))
   2852                    maps))))
   2853         (def (push (cons (vector key) def) bindings))))
   2854      (keymap-canonicalize keymap))
   2855     (nconc (nreverse bindings) (nreverse maps))))
   2856 
   2857 (defun embark-collect--direct-action-map (type)
   2858   "Return a direct action keymap for targets of given TYPE."
   2859   (let* ((actions (embark--action-keymap type nil))
   2860          (map (make-sparse-keymap)))
   2861     (set-keymap-parent map button-map)
   2862     (pcase-dolist (`(,key . ,cmd) (embark--all-bindings actions))
   2863       (unless (or (equal key [13])
   2864                   (memq cmd '(digit-argument negative-argument)))
   2865         (define-key map key (if (eq cmd 'embark-keymap-help)
   2866                                 #'embark-bindings-at-point
   2867                               (embark--action-command cmd)))))
   2868     map))
   2869 
   2870 (define-minor-mode embark-collect-direct-action-minor-mode
   2871   "Bind type-specific actions directly (without need for `embark-act')."
   2872   :init-value nil
   2873   :lighter " Act"
   2874   (unless (derived-mode-p 'embark-collect-mode)
   2875     (user-error "Not in an Embark Collect buffer"))
   2876   (save-excursion
   2877     (goto-char (point-min))
   2878     (let ((inhibit-read-only t) maps)
   2879       (while (progn
   2880                (when (tabulated-list-get-id)
   2881                  (put-text-property
   2882                   (point) (button-end (point)) 'keymap
   2883                   (if embark-collect-direct-action-minor-mode
   2884                       (when-let ((target (embark-collect--target))
   2885                                  (type (plist-get target :type)))
   2886                         (or (alist-get type maps)
   2887                             (setf (alist-get type maps)
   2888                                   (embark-collect--direct-action-map type)))))))
   2889                (forward-button 1 nil nil t))))))
   2890 
   2891 (define-button-type 'embark-collect-entry
   2892   'face 'embark-collect-candidate
   2893   'action 'embark-collect-choose)
   2894 
   2895 (declare-function outline-toggle-children "outline")
   2896 (define-button-type 'embark-collect-group
   2897   'face 'embark-collect-group-title
   2898   'action (lambda (_) (outline-toggle-children)))
   2899 
   2900 (defun embark--boundaries ()
   2901   "Get current minibuffer completion boundaries."
   2902   (let ((contents (minibuffer-contents))
   2903         (pt (embark--minibuffer-point)))
   2904     (completion-boundaries
   2905      (substring contents 0 pt)
   2906      minibuffer-completion-table
   2907      minibuffer-completion-predicate
   2908      (substring contents pt))))
   2909 
   2910 (defun embark-collect-choose (entry)
   2911   "Run default action on Embark Collect ENTRY."
   2912   (pcase-let ((`(,type ,text ,start . ,end)
   2913                (save-excursion
   2914                  (goto-char entry)
   2915                  (embark-target-collect-candidate))))
   2916     (embark--act (embark--default-action type)
   2917                  (list :target text
   2918                        :type type
   2919                        :bounds (cons start end)))))
   2920 
   2921 (defvar-keymap embark-collect-mode-map
   2922   :doc "Keymap for Embark collect mode."
   2923   :parent tabulated-list-mode-map
   2924   "a" #'embark-act
   2925   "A" #'embark-act-all
   2926   "M-a" #'embark-collect-direct-action-minor-mode
   2927   "E" #'embark-export
   2928   "s" #'isearch-forward
   2929   "n" #'forward-button
   2930   "p" #'backward-button
   2931   "}" 'outline-next-heading
   2932   "{" 'outline-previous-heading
   2933   "<remap> <forward-paragraph>" 'outline-next-heading
   2934   "<remap> <backward-paragraph>" 'outline-previous-heading
   2935   "<remap> <revert-buffer>" #'embark-rerun-collect-or-export)
   2936 
   2937 (defconst embark-collect--outline-string (string #x210000)
   2938   "Special string used for outline headings in Embark Collect buffers.
   2939 Chosen to be extremely unlikely to appear in a candidate.")
   2940 
   2941 (define-derived-mode embark-collect-mode tabulated-list-mode "Embark Collect"
   2942   "List of candidates to be acted on.
   2943 The command `embark-act' is bound `embark-collect-mode-map', but
   2944 you might prefer to change the key binding to match your other
   2945 key binding for it.  Or alternatively you might want to enable the
   2946 embark collect direct action minor mode by adding the function
   2947 `embark-collect-direct-action-minor-mode' to
   2948 `embark-collect-mode-hook'.
   2949 
   2950 Reverting an Embark Collect buffer has slightly unusual behavior
   2951 if the buffer was obtained by running `embark-collect' from
   2952 within a minibuffer completion session.  In that case reverting
   2953 just restarts the completion session, that is, the command that
   2954 opened the minibuffer is run again and the minibuffer contents
   2955 restored.  You can then interact normally with the command,
   2956 perhaps editing the minibuffer contents, and, if you wish, you
   2957 can rerun `embark-collect' to get an updated buffer."
   2958     :interactive nil :abbrev-table nil :syntax-table nil)
   2959 
   2960 (defun embark-collect--metadatum (type metadatum)
   2961   "Get METADATUM for current buffer's candidates.
   2962 For non-minibuffers, assume candidates are of given TYPE."
   2963   (if (minibufferp)
   2964       (or (completion-metadata-get (embark--metadata) metadatum)
   2965           (plist-get completion-extra-properties
   2966                      (intern (format ":%s" metadatum))))
   2967     ;; otherwise fake some metadata for Marginalia users's benefit
   2968     (completion-metadata-get `((category . ,type)) metadatum)))
   2969 
   2970 (defun embark-collect--affixator (type)
   2971   "Get affixation function for current buffer's candidates.
   2972 For non-minibuffers, assume candidates are of given TYPE."
   2973   (or (embark-collect--metadatum type 'affixation-function)
   2974       (let ((annotator
   2975              (or (embark-collect--metadatum type 'annotation-function)
   2976                  (lambda (_) ""))))
   2977         (lambda (candidates)
   2978           (mapcar (lambda (c)
   2979                     (if-let (a (funcall annotator c)) (list c "" a) c))
   2980                   candidates)))))
   2981 
   2982 (defun embark--display-string (str)
   2983   ;; Note: Keep in sync with vertico--display-string
   2984   "Return display STR without display and invisible properties."
   2985   (let ((end (length str)) (pos 0) chunks)
   2986     (while (< pos end)
   2987       (let ((nextd (next-single-property-change pos 'display str end))
   2988             (disp (get-text-property pos 'display str)))
   2989         (if (stringp disp)
   2990             (let ((face (get-text-property pos 'face str)))
   2991               (when face
   2992                 (add-face-text-property
   2993                  0 (length disp) face t (setq disp (concat disp))))
   2994               (setq pos nextd chunks (cons disp chunks)))
   2995           (while (< pos nextd)
   2996             (let ((nexti
   2997                    (next-single-property-change pos 'invisible str nextd)))
   2998               (unless (or (get-text-property pos 'invisible str)
   2999                           (and (= pos 0) (= nexti end))) ;; full=>no allocation
   3000                 (push (substring str pos nexti) chunks))
   3001               (setq pos nexti))))))
   3002     (if chunks (apply #'concat (nreverse chunks)) str)))
   3003 
   3004 (defconst embark--hline
   3005   (propertize
   3006    (concat "\n" (propertize
   3007                  " " 'display '(space :align-to right)
   3008                  'face '(:inherit completions-group-separator :height 0.01)
   3009                  'cursor-intangible t 'intangible t)))
   3010   "Horizontal line used to separate multiline collect entries.")
   3011 
   3012 (defun embark-collect--format-entries (candidates grouper)
   3013   "Format CANDIDATES for `tabulated-list-mode' grouped by GROUPER.
   3014 The GROUPER is either nil or a function like the `group-function'
   3015 completion metadatum, that is, a function of two arguments, the
   3016 first of which is a candidate and the second controls what is
   3017 computed: if nil, the title of the group the candidate belongs
   3018 to, and if non-nil, a rewriting of the candidate (useful to
   3019 simplify the candidate so it doesn't repeat the group title, for
   3020 example)."
   3021   (let ((max-width 0)
   3022         (transform
   3023          (if grouper (lambda (cand) (funcall grouper cand t)) #'identity)))
   3024     (setq
   3025      tabulated-list-entries
   3026      (mapcan
   3027       (lambda (group)
   3028         (let ((multiline (seq-some (lambda (x) (string-match-p "\n" (car x)))
   3029                                    candidates)))
   3030           (cons
   3031            `(nil [(,(concat (propertize embark-collect--outline-string
   3032                                         'invisible t)
   3033                             (format embark-collect-group-format (car group)))
   3034                    type embark-collect-group)
   3035                   ("" skip t)])
   3036            (mapcar
   3037             (pcase-lambda (`(,cand ,prefix ,annotation))
   3038               (let* ((display (embark--display-string (funcall transform cand)))
   3039                      (length (length annotation))
   3040                      (faces (text-property-not-all
   3041                              0 length 'face nil annotation)))
   3042                 (setq max-width (max max-width (+ (string-width prefix)
   3043                                                   (string-width display))))
   3044                 (when faces
   3045                   (add-face-text-property 0 length 'default t annotation))
   3046                 `(,cand
   3047                   [(,(propertize
   3048                       (if multiline (concat display embark--hline) display)
   3049                       'line-prefix prefix)
   3050                     type embark-collect-entry)
   3051                    (,annotation
   3052                     skip t
   3053                     ,@(unless faces
   3054                         '(face embark-collect-annotation)))])))
   3055             (cdr group)))))
   3056      (if grouper
   3057          (seq-group-by (lambda (item) (funcall grouper (car item) nil))
   3058                        candidates)
   3059        (list (cons "" candidates)))))
   3060   (if (null grouper)
   3061       (pop tabulated-list-entries)
   3062     (setq-local outline-regexp embark-collect--outline-string)
   3063     (outline-minor-mode))
   3064   (setq tabulated-list-format
   3065         `[("Candidate" ,max-width t) ("Annotation" 0 t)])))
   3066 
   3067 (defun embark-collect--update-candidates (buffer)
   3068   "Update candidates for Embark Collect BUFFER."
   3069   (let* ((transformed (embark--maybe-transform-candidates))
   3070          (type (plist-get transformed :orig-type)) ; we need the originals for
   3071          (candidates (plist-get transformed :orig-candidates)) ; default action
   3072          (bounds (plist-get transformed :bounds))
   3073          (affixator (embark-collect--affixator type))
   3074          (grouper (embark-collect--metadatum type 'group-function)))
   3075     (when (eq type 'file)
   3076       (let ((dir (buffer-local-value 'default-directory buffer)))
   3077         (setq candidates
   3078               (mapcar (lambda (cand)
   3079                         (let ((rel (file-relative-name cand dir)))
   3080                           (if (string-prefix-p "../" rel) cand rel)))
   3081                       candidates))))
   3082     (if (seq-some #'identity bounds)
   3083       (cl-loop for cand in candidates and (start . _end) in bounds
   3084                when start
   3085                do (add-text-properties
   3086                    0 1 `(embark--location ,(copy-marker start)) cand)))
   3087     (setq candidates (funcall affixator candidates))
   3088     (with-current-buffer buffer
   3089       (setq embark--type type)
   3090       (unless embark--command
   3091         (setq embark--command #'embark--goto))
   3092       (embark-collect--format-entries candidates grouper))
   3093     candidates))
   3094 
   3095 (defun embark--goto (target)
   3096   "Jump to the original location of TARGET.
   3097 This function is used as a default action in Embark Collect
   3098 buffers when the candidates were a selection from a regular
   3099 buffer."
   3100   ;; TODO: ensure the location jumped to is visible
   3101   ;; TODO: remove duplication with embark-org-goto-heading
   3102   (when-let ((marker (get-text-property 0 'embark--location target)))
   3103     (pop-to-buffer (marker-buffer marker))
   3104     (widen)
   3105     (goto-char marker)
   3106     (pulse-momentary-highlight-one-line)))
   3107 
   3108 (defun embark--collect (buffer-name)
   3109   "Create an Embark Collect buffer named BUFFER-NAME.
   3110 
   3111 The function `generate-new-buffer-name' is used to ensure the
   3112 buffer has a unique name."
   3113   (let ((buffer (generate-new-buffer buffer-name))
   3114         (rerun (embark--rerun-function #'embark-collect)))
   3115     (with-current-buffer buffer
   3116       ;; we'll run the mode hooks once the buffer is displayed, so
   3117       ;; the hooks can make use of the window
   3118       (delay-mode-hooks (embark-collect-mode)))
   3119 
   3120     (embark--cache-info buffer)
   3121     (unless (embark-collect--update-candidates buffer)
   3122       (user-error "No candidates to collect"))
   3123 
   3124     (with-current-buffer buffer
   3125       (setq tabulated-list-use-header-line nil ; default to no header
   3126             header-line-format nil
   3127             tabulated-list--header-string nil)
   3128       (setq embark--rerun-function rerun))
   3129 
   3130     (let ((window (display-buffer buffer)))
   3131       (with-selected-window window
   3132         (run-mode-hooks)
   3133         (tabulated-list-revert))
   3134       (set-window-dedicated-p window t)
   3135       buffer)))
   3136 
   3137 (defun embark--descriptive-buffer-name (type)
   3138   "Return a descriptive name for an Embark collect or export buffer.
   3139 TYPE should be either `collect' or `export'."
   3140   (format "*Embark %s: %s*"
   3141           (capitalize (symbol-name type))
   3142           (if (minibufferp)
   3143               (format "%s - %s" embark--command
   3144                       (minibuffer-contents-no-properties))
   3145             (buffer-name))))
   3146 
   3147 ;;;###autoload
   3148 (defun embark-collect ()
   3149   "Create an Embark Collect buffer.
   3150 
   3151 To control the display, add an entry to `display-buffer-alist'
   3152 with key \"Embark Collect\".
   3153 
   3154 In Embark Collect buffers `revert-buffer' is remapped to
   3155 `embark-rerun-collect-or-export', which has slightly unusual
   3156 behavior if the buffer was obtained by running `embark-collect'
   3157 from within a minibuffer completion session.  In that case
   3158 rerunning just restarts the completion session, that is, the
   3159 command that opened the minibuffer is run again and the
   3160 minibuffer contents restored.  You can then interact normally with
   3161 the command, perhaps editing the minibuffer contents, and, if you
   3162 wish, you can rerun `embark-collect' to get an updated buffer."
   3163   (interactive)
   3164   (let ((buffer (embark--collect (embark--descriptive-buffer-name 'collect))))
   3165     (when (minibufferp)
   3166       (embark--run-after-command #'pop-to-buffer buffer)
   3167       (embark--quit-and-run #'message nil))))
   3168 
   3169 ;;;###autoload
   3170 (defun embark-live ()
   3171   "Create a live-updating Embark Collect buffer.
   3172 
   3173 To control the display, add an entry to `display-buffer-alist'
   3174 with key \"Embark Live\"."
   3175   (interactive)
   3176   (let ((live-buffer (embark--collect
   3177                       (format "*Embark Live: %s*"
   3178                               (if (minibufferp)
   3179                                   (format "M-x %s" embark--command)
   3180                                 (buffer-name)))))
   3181         (run-collect (make-symbol "run-collect"))
   3182         (stop-collect (make-symbol "stop-collect"))
   3183         timer)
   3184     (setf (symbol-function stop-collect)
   3185           (lambda ()
   3186             (remove-hook 'change-major-mode-hook stop-collect t)
   3187             (remove-hook 'after-change-functions run-collect t)))
   3188     (setf (symbol-function run-collect)
   3189           (lambda (_1 _2 _3)
   3190             (unless timer
   3191               (setq timer
   3192                     (run-with-idle-timer
   3193                      0.05 nil
   3194                      (lambda ()
   3195                        (if (not (buffer-live-p live-buffer))
   3196                            (funcall stop-collect)
   3197                          (embark-collect--update-candidates live-buffer)
   3198                          (with-current-buffer live-buffer
   3199                            ;; TODO figure out why I can't restore point
   3200                            (tabulated-list-print t t))
   3201                          (setq timer nil))))))))
   3202     (add-hook 'after-change-functions run-collect nil t)
   3203     (when (minibufferp)
   3204       (add-hook 'change-major-mode-hook stop-collect nil t))))
   3205 
   3206 (defun embark--rerun-function (kind)
   3207   "Return a rerun function for an export or collect buffer in this context.
   3208 The parameter KIND should be either `embark-export' or `embark-collect'."
   3209   (let ((buffer (or embark--target-buffer (embark--target-buffer)))
   3210         (command embark--command))
   3211     (cl-flet ((rerunner (action)
   3212                 (lambda (&rest _)
   3213                   (quit-window 'kill-buffer)
   3214                   (with-current-buffer
   3215                       (if (buffer-live-p buffer) buffer (current-buffer))
   3216                     (let ((embark--command command))
   3217                       (funcall action))))))
   3218         (if (minibufferp)
   3219           (rerunner
   3220            (let ((input (minibuffer-contents-no-properties)))
   3221              (lambda ()
   3222                (minibuffer-with-setup-hook
   3223                    (lambda ()
   3224                      (delete-minibuffer-contents)
   3225                      (insert input))
   3226                  (setq this-command embark--command)
   3227                  (command-execute embark--command)))))
   3228           (rerunner kind)))))
   3229 
   3230 (defun embark-rerun-collect-or-export ()
   3231   "Rerun the `embark-collect' or `embark-export' that created this buffer."
   3232   (interactive)
   3233   (if embark--rerun-function
   3234       (funcall embark--rerun-function)
   3235     (user-error "No function to rerun collect or export found")))
   3236 
   3237 ;;;###autoload
   3238 (defun embark-export ()
   3239   "Create a type-specific buffer to manage current candidates.
   3240 The variable `embark-exporters-alist' controls how to make the
   3241 buffer for each type of completion.
   3242 
   3243 In Embark Export buffers `revert-buffer' is remapped to
   3244 `embark-rerun-collect-or-export', which has slightly unusual
   3245 behavior if the buffer was obtained by running `embark-export'
   3246 from within a minibuffer completion session.  In that case
   3247 reverting just restarts the completion session, that is, the
   3248 command that opened the minibuffer is run again and the
   3249 minibuffer contents restored.  You can then interact normally
   3250 with the command, perhaps editing the minibuffer contents, and,
   3251 if you wish, you can rerun `embark-export' to get an updated
   3252 buffer."
   3253   (interactive)
   3254   (let* ((transformed (embark--maybe-transform-candidates))
   3255          (candidates (or (plist-get transformed :candidates)
   3256                          (user-error "No candidates for export")))
   3257          (type (plist-get transformed :type)))
   3258     (let ((exporter (or (alist-get type embark-exporters-alist)
   3259                         (alist-get t embark-exporters-alist))))
   3260       (if (eq exporter 'embark-collect)
   3261           (embark-collect)
   3262         (let* ((after embark-after-export-hook)
   3263                (cmd embark--command)
   3264                (name (embark--descriptive-buffer-name 'export))
   3265                (rerun (embark--rerun-function #'embark-export))
   3266                (buffer (save-excursion
   3267                          (funcall exporter candidates)
   3268                          (rename-buffer name t)
   3269                          (current-buffer))))
   3270           (embark--quit-and-run
   3271            (lambda ()
   3272              (pop-to-buffer buffer)
   3273              (setq embark--rerun-function rerun)
   3274              (use-local-map
   3275               (make-composed-keymap
   3276                '(keymap
   3277                  (remap keymap
   3278                         (revert-buffer . embark-rerun-collect-or-export)))
   3279                (current-local-map)))
   3280              (let ((embark-after-export-hook after)
   3281                    (embark--command cmd))
   3282                (run-hooks 'embark-after-export-hook)))))))))
   3283 
   3284 (defmacro embark--export-rename (buffer title &rest body)
   3285   "Run BODY and rename BUFFER to Embark export buffer with TITLE."
   3286   (declare (indent 2))
   3287   (let ((saved (make-symbol "saved")))
   3288     `(let ((,saved (embark-rename-buffer
   3289                     ,buffer " *Embark Saved*" t)))
   3290        ,@body
   3291        (set-buffer (embark-rename-buffer
   3292                     ,buffer ,(format "*Embark Export %s*" title) t))
   3293        (when ,saved (embark-rename-buffer ,saved ,buffer)))))
   3294 
   3295 (defun embark--export-customize (items type pred)
   3296   "Create a customization buffer listing ITEMS.
   3297 TYPE is the items type.
   3298 PRED is a predicate function used to filter the items."
   3299   (custom-buffer-create
   3300    (cl-loop for item in items
   3301             for sym = (intern-soft item)
   3302             when (and sym (funcall pred sym)) collect `(,sym ,type))))
   3303 
   3304 (autoload 'apropos-parse-pattern "apropos")
   3305 (autoload 'apropos-symbols-internal "apropos")
   3306 (defun embark-export-apropos (symbols)
   3307   "Create apropos buffer listing SYMBOLS."
   3308   (embark--export-rename "*Apropos*" "Apropos"
   3309     (apropos-parse-pattern "") ;; Initialize apropos pattern
   3310     ;; HACK: Ensure that order of exported symbols is kept.
   3311     (cl-letf (((symbol-function #'sort) (lambda (list _pred) (nreverse list))))
   3312       (apropos-symbols-internal
   3313        (delq nil (mapcar #'intern-soft symbols))
   3314        (bound-and-true-p apropos-do-all)))))
   3315 
   3316 (defun embark-export-customize-face (faces)
   3317   "Create a customization buffer listing FACES."
   3318   (embark--export-customize faces 'custom-face #'facep))
   3319 
   3320 (defun embark-export-customize-variable (variables)
   3321   "Create a customization buffer listing VARIABLES."
   3322   ;; The widget library serializes/deserializes the values. We advise
   3323   ;; the serialization in order to avoid errors for nonserializable
   3324   ;; variables.
   3325   (cl-letf* ((ht (make-hash-table :test #'equal))
   3326              (orig-read (symbol-function #'read))
   3327              (orig-write (symbol-function 'widget-sexp-value-to-internal))
   3328              ((symbol-function #'read)
   3329               (lambda (&optional str)
   3330                 (condition-case nil
   3331                     (funcall orig-read str)
   3332                   (error (gethash str ht)))))
   3333              ((symbol-function 'widget-sexp-value-to-internal)
   3334               (lambda (widget val)
   3335                 (let ((str (funcall orig-write widget val)))
   3336                   (puthash str val ht)
   3337                   str))))
   3338     (embark--export-customize variables 'custom-variable #'boundp)))
   3339 
   3340 (defun embark-export-ibuffer (buffers)
   3341   "Create an ibuffer buffer listing BUFFERS."
   3342   (ibuffer t "*Embark Export Ibuffer*"
   3343            `((predicate . (member (buffer-name) ',buffers)))))
   3344 
   3345 (autoload 'dired-check-switches "dired")
   3346 (declare-function dired-unadvertise "dired")
   3347 (defvar dired-directory)
   3348 
   3349 (defun embark-export-dired (files)
   3350   "Create a Dired buffer listing FILES."
   3351   (setq files (mapcar #'directory-file-name
   3352                       (cl-remove-if-not #'file-exists-p files)))
   3353   (when (dired-check-switches dired-listing-switches "A" "almost-all")
   3354     (setq files (cl-remove-if
   3355                  (lambda (path)
   3356                    (let ((file (file-name-nondirectory path)))
   3357                      (or (string= file ".") (string= file ".."))))
   3358                  files)))
   3359   (cl-letf* ((dir (or (file-name-directory (try-completion "" files)) ""))
   3360              ;; Prevent reusing existing Dired buffer.
   3361              ((symbol-function 'dired-find-buffer-nocreate) #'ignore)
   3362              (buf (dired-noselect
   3363                    (cons (expand-file-name dir)
   3364                          (mapcar (lambda (file) (string-remove-prefix dir file))
   3365                                  files)))))
   3366     (with-current-buffer buf
   3367       ;; Unadvertise to prevent the new buffer from being reused.
   3368       (dired-unadvertise default-directory)
   3369       (rename-buffer (format "*Embark Export Dired %s*" default-directory)))
   3370     (pop-to-buffer buf)))
   3371 
   3372 (autoload 'package-menu-mode "package")
   3373 (autoload 'package-menu--generate "package")
   3374 
   3375 (defun embark-export-list-packages (packages)
   3376   "Create a package menu mode buffer listing PACKAGES."
   3377   (let ((buf (generate-new-buffer "*Embark Export Packages*")))
   3378     (with-current-buffer buf
   3379       (package-menu-mode)
   3380       (package-menu--generate nil (mapcar #'intern packages)))
   3381     (pop-to-buffer buf)))
   3382 
   3383 (defvar bookmark-alist)
   3384 
   3385 (defun embark-export-bookmarks (bookmarks)
   3386   "Create a `bookmark-bmenu-mode' buffer listing BOOKMARKS."
   3387   (embark--export-rename "*Bookmark List*" "Bookmarks"
   3388     (let ((bookmark-alist
   3389            (cl-remove-if-not
   3390             (lambda (bmark)
   3391               (member (car bmark) bookmarks))
   3392             bookmark-alist)))
   3393       (bookmark-bmenu-list))))
   3394 
   3395 ;;; Multiple target selection
   3396 
   3397 (defface embark-selected '((t (:inherit match)))
   3398   "Face for selected candidates.")
   3399 
   3400 (defcustom embark-selection-indicator
   3401   #("  Embark:%s " 1 12 (face (embark-selected bold)))
   3402   "Mode line indicator used for selected candidates."
   3403   :type '(choice string (const nil)))
   3404 
   3405 (defvar-local embark--selection nil
   3406   "Buffer local list of selected targets.
   3407 Add or remove elements to this list using the `embark-select'
   3408 action.")
   3409 
   3410 (defun embark--selection-indicator ()
   3411   "Mode line indicator showing number of selected items."
   3412   (when-let ((sel
   3413               (buffer-local-value
   3414                'embark--selection
   3415                (or (when-let ((win (active-minibuffer-window)))
   3416                      (window-buffer win))
   3417                    (current-buffer)))))
   3418     (format embark-selection-indicator (length sel))))
   3419 
   3420 (cl-defun embark--select
   3421     (&key orig-target orig-type bounds &allow-other-keys)
   3422   "Add or remove ORIG-TARGET of given ORIG-TYPE to the selection.
   3423 If BOUNDS are given, also highlight the target when selecting it."
   3424   (cl-flet ((multi-type (x) (car (get-text-property 0 'multi-category x))))
   3425     (if-let* ((existing (seq-find
   3426                          (pcase-lambda (`(,cand . ,ov))
   3427                            (and
   3428                             (equal cand orig-target)
   3429                             (if (and bounds ov)
   3430                                 (and (= (car bounds) (overlay-start ov))
   3431                                      (= (cdr bounds) (overlay-end ov)))
   3432                               (let ((cand-type (multi-type cand)))
   3433                                 (or (eq cand-type orig-type)
   3434                                     (eq cand-type (multi-type orig-target)))))))
   3435                          embark--selection)))
   3436         (progn
   3437           (when (cdr existing) (delete-overlay (cdr existing)))
   3438           (setq embark--selection (delq existing embark--selection)))
   3439       (let ((target (copy-sequence orig-target)) overlay)
   3440         (when bounds
   3441           (setq overlay (make-overlay (car bounds) (cdr bounds)))
   3442           (overlay-put overlay 'category 'embark-selected-overlay))
   3443         (add-text-properties 0 (length orig-target)
   3444                              `(multi-category ,(cons orig-type orig-target))
   3445                              target)
   3446         (push (cons target overlay) embark--selection))))
   3447   (when embark-selection-indicator
   3448     (add-to-list 'mode-line-misc-info '(:eval (embark--selection-indicator)))
   3449     (force-mode-line-update t)))
   3450 
   3451 ;;;###autoload
   3452 (defun embark-select ()
   3453   "Add or remove the target from the current buffer's selection.
   3454 You can act on all selected targets at once with `embark-act-all'.
   3455 When called from outside `embark-act' this command will select
   3456 the first target at point."
   3457   (interactive)
   3458   (if-let ((target (car (embark--targets))))
   3459       (apply #'embark--select target)
   3460     (user-error "No target to select")))
   3461 
   3462 (defun embark-selected-candidates ()
   3463   "Return currently selected candidates in the buffer."
   3464   (when embark--selection
   3465     (cl-flet ((unwrap (x) (get-text-property 0 'multi-category x)))
   3466       (let* ((first-type (car (unwrap (caar embark--selection))))
   3467              (same (cl-every (lambda (item)
   3468                                (eq (car (unwrap (car item))) first-type))
   3469                              embark--selection))
   3470              (extract (if same
   3471                           (pcase-lambda (`(,cand . ,overlay))
   3472                             (cons (cdr (unwrap cand)) overlay))
   3473                         #'identity)))
   3474         (cons
   3475          (if same first-type 'multi-category)
   3476          (nreverse
   3477           (mapcar
   3478            (lambda (item)
   3479              (pcase-let ((`(,cand . ,ov) (funcall extract item)))
   3480                (if ov `(,cand ,(overlay-start ov) . ,(overlay-end ov)) cand)))
   3481            embark--selection)))))))
   3482 
   3483 ;;; Integration with external packages, mostly completion UIs
   3484 
   3485 ;; marginalia
   3486 
   3487 ;; Ensure that the Marginalia cache is reset, such that
   3488 ;; `embark-toggle-variable-value' updates the display (See #540).
   3489 (with-eval-after-load 'marginalia
   3490   (push 'marginalia--cache-reset (alist-get :always embark-post-action-hooks)))
   3491 
   3492 ;; vertico
   3493 
   3494 (declare-function vertico--candidate "ext:vertico")
   3495 (declare-function vertico--update "ext:vertico")
   3496 (defvar vertico--input)
   3497 (defvar vertico--candidates)
   3498 (defvar vertico--base)
   3499 
   3500 (defun embark--vertico-selected ()
   3501   "Target the currently selected item in Vertico.
   3502 Return the category metadatum as the type of the target."
   3503   (when vertico--input
   3504     ;; Force candidate computation, if candidates are not yet available.
   3505     (vertico--update)
   3506     (cons (completion-metadata-get (embark--metadata) 'category)
   3507           (vertico--candidate))))
   3508 
   3509 (defun embark--vertico-candidates ()
   3510   "Collect the current Vertico candidates.
   3511 Return the category metadatum as the type of the candidates."
   3512   (when vertico--input
   3513     ;; Force candidate computation, if candidates are not yet available.
   3514     (vertico--update)
   3515     (cons (completion-metadata-get (embark--metadata) 'category)
   3516           vertico--candidates)))
   3517 
   3518 (defun embark--vertico-indicator ()
   3519   "Embark indicator highlighting the current Vertico candidate."
   3520   (let ((fr face-remapping-alist))
   3521     (lambda (&optional keymap _targets _prefix)
   3522       (when vertico--input
   3523         (setq-local face-remapping-alist
   3524                     (if keymap
   3525                         (cons '(vertico-current . embark-target) fr)
   3526                       fr))))))
   3527 
   3528 (with-eval-after-load 'vertico
   3529   (cl-defmethod vertico--format-candidate
   3530     :around (cand prefix suffix index start &context (embark--selection cons))
   3531     (when (cl-find (concat vertico--base (nth index vertico--candidates))
   3532                    embark--selection
   3533                    :test #'equal :key #'car)
   3534       (setq cand (copy-sequence cand))
   3535       (add-face-text-property 0 (length cand) 'embark-selected t cand))
   3536     (cl-call-next-method cand prefix suffix index start))
   3537   (add-hook 'embark-indicators #'embark--vertico-indicator)
   3538   (add-hook 'embark-target-finders #'embark--vertico-selected)
   3539   (add-hook 'embark-candidate-collectors #'embark--vertico-candidates)
   3540   (remove-hook 'embark-candidate-collectors #'embark-selected-candidates)
   3541   (add-hook 'embark-candidate-collectors #'embark-selected-candidates))
   3542 
   3543 ;; ivy
   3544 
   3545 (declare-function ivy--expand-file-name "ext:ivy")
   3546 (declare-function ivy-state-current "ext:ivy")
   3547 (defvar ivy-text)
   3548 (defvar ivy-last)
   3549 (defvar ivy--old-cands) ; this stores the current candidates :)
   3550 (defvar ivy--length)
   3551 
   3552 (defun embark--ivy-selected ()
   3553   "Target the currently selected item in Ivy.
   3554 Return the category metadatum as the type of the target."
   3555   ;; my favorite way of detecting Ivy
   3556   (when (memq 'ivy--queue-exhibit post-command-hook)
   3557     (cons
   3558      (completion-metadata-get (embark--metadata) 'category)
   3559      (ivy--expand-file-name
   3560       (if (and (> ivy--length 0)
   3561                (stringp (ivy-state-current ivy-last)))
   3562           (ivy-state-current ivy-last)
   3563         ivy-text)))))
   3564 
   3565 (defun embark--ivy-candidates ()
   3566   "Return all current Ivy candidates."
   3567   ;; my favorite way of detecting Ivy
   3568   (when (memq 'ivy--queue-exhibit post-command-hook)
   3569     (cons
   3570      ;; swiper-isearch uses swiper-isearch-function as a completion
   3571      ;; table, but it doesn't understand metadata queries
   3572      (ignore-errors
   3573        (completion-metadata-get (embark--metadata) 'category))
   3574      ivy--old-cands)))
   3575 
   3576 (with-eval-after-load 'ivy
   3577   (add-hook 'embark-target-finders #'embark--ivy-selected)
   3578   (add-hook 'embark-candidate-collectors #'embark--ivy-candidates)
   3579   (remove-hook 'embark-candidate-collectors #'embark-selected-candidates)
   3580   (add-hook 'embark-candidate-collectors #'embark-selected-candidates))
   3581 
   3582 ;;; Custom actions
   3583 
   3584 (defvar embark-separator-history nil
   3585   "Input history for the separators used by some embark commands.
   3586 The commands that prompt for a string separator are
   3587 `embark-insert' and `embark-copy-as-kill'.")
   3588 
   3589 (defun embark-keymap-help ()
   3590   "Prompt for an action to perform or command to become and run it."
   3591   (interactive)
   3592   (user-error "Not meant to be called directly"))
   3593 
   3594 (defun embark-toggle-quit ()
   3595   "Toggle whether the following action quits the minibuffer."
   3596   (interactive)
   3597   (when (minibufferp)
   3598     (setq embark--toggle-quit (not embark--toggle-quit))
   3599     (if (consp embark-quit-after-action)
   3600         (message "Will %sobey embark-quit-after-action."
   3601                  (if embark--toggle-quit "dis" ""))
   3602       (message
   3603        "Will %squit minibuffer after action"
   3604        (if (eq embark--toggle-quit embark-quit-after-action) "not " "")))))
   3605 
   3606 (defun embark--separator (strings)
   3607   "Return a separator to join the STRINGS together.
   3608 With a prefix argument, prompt the user (unless STRINGS has 0 or
   3609 1 elements, in which case a separator is not needed)."
   3610   (if (and current-prefix-arg (cdr strings))
   3611       (read-string "Separator: " nil 'embark-separator-history)
   3612     "\n"))
   3613 
   3614 (defun embark-copy-as-kill (strings)
   3615   "Join STRINGS and save on the `kill-ring'.
   3616 With a prefix argument, prompt for the separator to join the
   3617 STRINGS, which defaults to a newline."
   3618   (kill-new (string-join strings (embark--separator strings))))
   3619 
   3620 (defun embark-insert (strings)
   3621   "Join STRINGS and insert the result at point.
   3622 With a prefix argument, prompt for the separator to join the
   3623 STRINGS, which defaults to a newline.
   3624 
   3625 Some whitespace is also inserted if necessary to avoid having the
   3626 inserted string blend into the existing buffer text.  More
   3627 precisely:
   3628 
   3629 1. If the inserted string does not contain newlines, a space may
   3630 be added before or after it as needed to avoid inserting a word
   3631 constituent character next to an existing word constituent.
   3632 
   3633 2. For a multiline inserted string, newlines may be added before
   3634 or after as needed to ensure the inserted string is on lines of
   3635 its own."
   3636   (let* ((separator (embark--separator strings))
   3637          (multiline
   3638           (or (and (cdr strings) (string-match-p "\n" separator))
   3639               (and (null (cdr strings))
   3640                    (equal (buffer-substring (line-beginning-position)
   3641                                             (line-end-position))
   3642                           (car strings)))
   3643               (seq-some (lambda (s) (string-match-p "\n" s)) strings))))
   3644     (cl-labels ((maybe-space ()
   3645                   (and (looking-at "\\w") (looking-back "\\w" 1)
   3646                        (insert " ")))
   3647                 (maybe-newline ()
   3648                   (or (looking-back "^[ \t]*" 40) (looking-at "\n")
   3649                       (newline-and-indent)))
   3650                 (maybe-whitespace ()
   3651                   (if multiline (maybe-newline) (maybe-space)))
   3652                 (ins-string ()
   3653                   (let ((start (point)))
   3654                     (insert
   3655                      (mapconcat #'substring-no-properties strings separator))
   3656                     (save-excursion (goto-char start) (maybe-whitespace))
   3657                     (when (looking-back "\n" 1) (delete-char -1))
   3658                     (save-excursion (maybe-whitespace)))))
   3659       (if buffer-read-only
   3660           (with-selected-window (other-window-for-scrolling)
   3661             (ins-string))
   3662         (ins-string)))))
   3663 
   3664 (defun embark-dired-jump (file &optional other-window)
   3665   "Open Dired buffer in directory containing FILE and move to its line.
   3666 When called with a prefix argument OTHER-WINDOW, open Dired in other window."
   3667   (interactive "fJump to Dired file: \nP")
   3668   (dired-jump other-window file))
   3669 
   3670 (defun embark--read-from-history (prompt candidates &optional category)
   3671   "Read with completion from list of history CANDIDATES of CATEGORY.
   3672 Sorting and history are disabled.  PROMPT is the prompt message."
   3673   (completing-read prompt
   3674                    (embark--with-category category candidates)
   3675                    nil t nil t))
   3676 
   3677 (defun embark-kill-ring-remove (text)
   3678   "Remove TEXT from `kill-ring'."
   3679   (interactive (list (embark--read-from-history
   3680                       "Remove from kill-ring: " kill-ring 'kill-ring)))
   3681   (embark-history-remove text)
   3682   (setq kill-ring (delete text kill-ring)))
   3683 
   3684 (defvar recentf-list)
   3685 (defun embark-recentf-remove (file)
   3686   "Remove FILE from the list of recent files."
   3687   (interactive (list (embark--read-from-history
   3688                       "Remove recent file: " recentf-list 'file)))
   3689   (embark-history-remove (expand-file-name file))
   3690   (embark-history-remove (abbreviate-file-name file))
   3691   (when (and (boundp 'recentf-list) (fboundp 'recentf-expand-file-name))
   3692     (setq recentf-list (delete (recentf-expand-file-name file) recentf-list))))
   3693 
   3694 (defun embark-history-remove (str)
   3695   "Remove STR from `minibuffer-history-variable'.
   3696 Many completion UIs sort by history position.  This command can be used
   3697 to remove entries from the history, such that they are not sorted closer
   3698 to the top."
   3699   (interactive (list (embark--read-from-history
   3700                       "Remove history item: "
   3701                       (if (eq minibuffer-history-variable t)
   3702                           (user-error "No minibuffer history")
   3703                         (symbol-value minibuffer-history-variable)))))
   3704   (unless (eq minibuffer-history-variable t)
   3705     (set minibuffer-history-variable
   3706          (delete str (symbol-value minibuffer-history-variable)))))
   3707 
   3708 (defvar xref-backend-functions)
   3709 
   3710 (defun embark-find-definition (symbol)
   3711   "Find definition of Emacs Lisp SYMBOL."
   3712   (interactive "sSymbol: ")
   3713   (let ((xref-backend-functions (lambda () 'elisp)))
   3714     (xref-find-definitions symbol)))
   3715 
   3716 (defun embark-info-lookup-symbol (symbol)
   3717   "Display the definition of SYMBOL, from the Elisp manual."
   3718   (interactive "SSymbol: ")
   3719   (info-lookup-symbol symbol 'emacs-lisp-mode))
   3720 
   3721 (defun embark-rename-buffer (buffer newname &optional unique)
   3722   "Rename BUFFER to NEWNAME, optionally making it UNIQUE.
   3723 Interactively, you can set UNIQUE with a prefix argument.
   3724 Returns the new name actually used."
   3725   (interactive "bBuffer: \nBRename %s to: \nP")
   3726   (when-let ((buf (get-buffer buffer)))
   3727     (with-current-buffer buf
   3728       (rename-buffer newname unique))))
   3729 
   3730 (defun embark--package-url (pkg)
   3731   "Return homepage for package PKG."
   3732   (when-let (desc (embark--package-desc pkg))
   3733     (alist-get :url (package-desc-extras desc))))
   3734 
   3735 (defun embark--prompt-for-package ()
   3736   "Prompt user for a package name."
   3737   ;; this code is taken from the interactive spec of describe-package
   3738   (unless package--initialized
   3739     (package-initialize t))
   3740   (intern
   3741    (completing-read "Package: "
   3742                     (append (mapcar #'car package-alist)
   3743                             (mapcar #'car package-archive-contents)
   3744                             (mapcar #'car package--builtins)))))
   3745 
   3746 (defun embark-browse-package-url (pkg)
   3747   "Open homepage for package PKG with `browse-url'."
   3748   (interactive (list (embark--prompt-for-package)))
   3749   (if-let ((url (embark--package-url pkg)))
   3750       (browse-url url)
   3751     (user-error "No homepage found for `%s'" pkg)))
   3752 
   3753 (defun embark-save-package-url (pkg)
   3754   "Save URL of homepage for package PKG on the `kill-ring'."
   3755   (interactive (list (embark--prompt-for-package)))
   3756   (if-let ((url (embark--package-url pkg)))
   3757       (kill-new url)
   3758     (user-error "No homepage found for `%s'" pkg)))
   3759 
   3760 (defun embark-save-variable-value (var)
   3761   "Save value of VAR in the `kill-ring'."
   3762   (interactive "SVariable: ")
   3763   (kill-new (string-trim (pp-to-string (symbol-value var)))))
   3764 
   3765 (defun embark-insert-variable-value (var)
   3766   "Insert value of VAR."
   3767   (interactive "SVariable: ")
   3768   (embark-insert (list (string-trim (pp-to-string (symbol-value var))))))
   3769 
   3770 (defun embark-toggle-variable (var &optional local)
   3771   "Toggle value of boolean variable VAR.
   3772 If prefix LOCAL is non-nil make variable local."
   3773   (interactive "SVariable: \nP")
   3774   (let ((val (symbol-value var)))
   3775     (unless (memq val '(nil t))
   3776       (user-error "Not a boolean variable"))
   3777     (when local
   3778       (make-local-variable var))
   3779     (funcall (or (get var 'custom-set) 'set) var (not val))))
   3780 
   3781 (defun embark-insert-relative-path (file)
   3782   "Insert relative path to FILE.
   3783 The insert path is relative to `default-directory'."
   3784   (interactive "FFile: ")
   3785   (embark-insert (list (file-relative-name (substitute-in-file-name file)))))
   3786 
   3787 (defun embark-save-relative-path (file)
   3788   "Save the relative path to FILE in the kill ring.
   3789 The insert path is relative to `default-directory'."
   3790   (interactive "FFile: ")
   3791   (kill-new (file-relative-name (substitute-in-file-name file))))
   3792 
   3793 (defun embark-shell-command-on-buffer (buffer command &optional replace)
   3794   "Run shell COMMAND on contents of BUFFER.
   3795 Called with \\[universal-argument], replace contents of buffer
   3796 with command output.  For replacement behavior see
   3797 `shell-command-dont-erase-buffer' setting."
   3798   (interactive
   3799    (list
   3800     (read-buffer "Buffer: " nil t)
   3801     (read-shell-command "Shell command: ")
   3802     current-prefix-arg))
   3803   (with-current-buffer buffer
   3804     (shell-command-on-region (point-min) (point-max)
   3805                              command
   3806                              (and replace (current-buffer)))))
   3807 
   3808 (defun embark-open-externally (file)
   3809   "Open FILE or url using system's default application."
   3810   (interactive "sOpen externally: ")
   3811   (unless (string-match-p "\\`[a-z]+://" file)
   3812     (setq file (expand-file-name file)))
   3813   (message "Opening `%s' externally..." file)
   3814   (if (and (eq system-type 'windows-nt)
   3815            (fboundp 'w32-shell-execute))
   3816       (w32-shell-execute "open" file)
   3817     (call-process (pcase system-type
   3818                     ('darwin "open")
   3819                     ('cygwin "cygstart")
   3820                     (_ "xdg-open"))
   3821                   nil 0 nil file)))
   3822 
   3823 (declare-function bookmark-prop-get "bookmark")
   3824 (declare-function bookmark-completing-read "bookmark")
   3825 
   3826 (defun embark-bookmark-open-externally (bookmark)
   3827   "Open BOOKMARK in external application."
   3828   (interactive (list (bookmark-completing-read "Open externally: ")))
   3829   (embark-open-externally
   3830    (or (bookmark-prop-get bookmark 'location)
   3831        (bookmark-prop-get bookmark 'filename)
   3832        (user-error "Bookmark `%s' does not have a location" bookmark))))
   3833 
   3834 (defun embark-bury-buffer (buf)
   3835   "Bury buffer BUF."
   3836   (interactive "bBuffer: ")
   3837   (if-let (win (get-buffer-window buf))
   3838       (with-selected-window win
   3839         (bury-buffer))
   3840     (bury-buffer)))
   3841 
   3842 (defun embark-kill-buffer-and-window (buf)
   3843   "Kill buffer BUF and delete its window."
   3844   (interactive "bBuffer: ")
   3845   (when-let (buf (get-buffer buf))
   3846     (if-let (win (get-buffer-window buf))
   3847         (with-selected-window win
   3848           (kill-buffer-and-window))
   3849       (kill-buffer buf))))
   3850 
   3851 (defun embark-save-unicode-character (char)
   3852   "Save Unicode character CHAR to kill ring."
   3853   (interactive
   3854    (list (read-char-by-name "Insert character  (Unicode name or hex): ")))
   3855   (kill-new (format "%c" char)))
   3856 
   3857 (defun embark-isearch-forward ()
   3858   "Prompt for string in the minibuffer and start isearch forwards.
   3859 Unlike isearch, this command reads the string from the
   3860 minibuffer, which means it can be used as an Embark action."
   3861   (interactive)
   3862   (isearch-mode t)
   3863   (isearch-edit-string))
   3864 
   3865 (defun embark-isearch-backward ()
   3866   "Prompt for string in the minibuffer and start isearch backwards.
   3867 Unlike isearch, this command reads the string from the
   3868 minibuffer, which means it can be used as an Embark action."
   3869   (interactive)
   3870   (isearch-mode nil)
   3871   (isearch-edit-string))
   3872 
   3873 (defun embark-toggle-highlight ()
   3874   "Toggle symbol highlighting using `highlight-symbol-at-point'."
   3875   (interactive)
   3876   (let ((regexp (find-tag-default-as-symbol-regexp))
   3877         (highlighted (cl-find-if #'boundp
   3878                                  '(hi-lock-interactive-lighters
   3879                                    hi-lock-interactive-patterns))))
   3880     (if (and highlighted (assoc regexp (symbol-value highlighted)))
   3881         (unhighlight-regexp regexp)
   3882       (highlight-symbol-at-point))))
   3883 
   3884 (defun embark-next-symbol ()
   3885   "Jump to next occurrence of symbol at point.
   3886 The search respects symbol boundaries."
   3887   (interactive)
   3888   (if-let ((symbol (thing-at-point 'symbol)))
   3889       (let ((regexp (format "\\_<%s\\_>" (regexp-quote symbol))))
   3890         (when (looking-at regexp)
   3891           (forward-symbol 1))
   3892         (unless (re-search-forward regexp nil t)
   3893           (user-error "Symbol `%s' not found" symbol)))
   3894     (user-error "No symbol at point")))
   3895 
   3896 (defun embark-previous-symbol ()
   3897   "Jump to previous occurrence of symbol at point.
   3898 The search respects symbol boundaries."
   3899   (interactive)
   3900   (if-let ((symbol (thing-at-point 'symbol)))
   3901       (let ((regexp (format "\\_<%s\\_>" (regexp-quote symbol))))
   3902         (when (looking-back regexp (- (point) (length symbol)))
   3903           (forward-symbol -1))
   3904         (unless (re-search-backward regexp nil t)
   3905           (user-error "Symbol `%s' not found" symbol)))
   3906     (user-error "No symbol at point")))
   3907 
   3908 (defun embark-compose-mail (address)
   3909   "Compose email to ADDRESS."
   3910   ;; The only reason we cannot use compose-mail directly is its
   3911   ;; interactive specification, which just supplies nil for the
   3912   ;; address (and several other arguments).
   3913   (interactive "sTo: ")
   3914   (compose-mail address))
   3915 
   3916 (autoload 'pp-display-expression "pp")
   3917 
   3918 (defun embark-pp-eval-defun (edebug)
   3919   "Run `eval-defun' and pretty print the result.
   3920 With a prefix argument EDEBUG, instrument the code for debugging."
   3921   (interactive "P")
   3922   (cl-letf (((symbol-function #'eval-expression-print-format)
   3923              (lambda (result)
   3924                (pp-display-expression result "*Pp Eval Output*"))))
   3925     (eval-defun edebug)))
   3926 
   3927 (defun embark-eval-replace (noquote)
   3928   "Evaluate region and replace with evaluated result.
   3929 If NOQUOTE is non-nil (interactively, if called with a prefix
   3930 argument), no quoting is used for strings."
   3931   (interactive "P")
   3932   (let ((beg (region-beginning))
   3933         (end (region-end)))
   3934     (save-excursion
   3935       (goto-char end)
   3936       (insert (format (if noquote "%s" "%S")
   3937                (eval (read (buffer-substring beg end)) lexical-binding)))
   3938       (delete-region beg end))))
   3939 
   3940 (static-if (< emacs-major-version 29)
   3941   (defun embark-elp-restore-package (prefix)
   3942     "Remove instrumentation from functions with names starting with PREFIX."
   3943     (interactive "SPrefix: ")
   3944     (when (fboundp 'elp-restore-list)
   3945       (elp-restore-list
   3946        (mapcar #'intern
   3947                (all-completions (symbol-name prefix)
   3948                                 obarray 'elp-profilable-p))))))
   3949 
   3950 (defmacro embark--define-hash (algorithm)
   3951   "Define command which computes hash from a string.
   3952 ALGORITHM is the hash algorithm symbol understood by `secure-hash'."
   3953   `(defun ,(intern (format "embark-hash-%s" algorithm)) (str)
   3954      ,(format "Compute %s hash of STR and store it in the kill ring." algorithm)
   3955      (interactive "sString: ")
   3956      (let ((hash (secure-hash ',algorithm str)))
   3957        (kill-new hash)
   3958        (message "%s: %s" ',algorithm hash))))
   3959 
   3960 (embark--define-hash md5)
   3961 (embark--define-hash sha1)
   3962 (embark--define-hash sha224)
   3963 (embark--define-hash sha256)
   3964 (embark--define-hash sha384)
   3965 (embark--define-hash sha512)
   3966 
   3967 (defun embark-encode-url (start end)
   3968   "Properly URI-encode the region between START and END in current buffer."
   3969   (interactive "r")
   3970   (let ((encoded (url-encode-url (buffer-substring-no-properties start end))))
   3971     (delete-region start end)
   3972     (insert encoded)))
   3973 
   3974 (defun embark-decode-url (start end)
   3975   "Decode the URI-encoded region between START and END in current buffer.
   3976 It assumes the URL was encoded in UTF-8."
   3977   (interactive "r")
   3978   (let ((decoded (decode-coding-string
   3979                   (url-unhex-string
   3980                    (buffer-substring-no-properties start end))
   3981                   'utf-8)))
   3982     (delete-region start end)
   3983     (insert decoded)))
   3984 
   3985 (defvar epa-replace-original-text)
   3986 (defun embark-epa-decrypt-region (start end)
   3987   "Decrypt region between START and END."
   3988   (interactive "r")
   3989   (let ((epa-replace-original-text t))
   3990     (epa-decrypt-region start end)))
   3991 
   3992 (defvar eww-download-directory)
   3993 (autoload 'eww-download-callback "eww")
   3994 
   3995 (defun embark-download-url (url)
   3996   "Download URL to `eww-download-directory'."
   3997   (interactive "sDownload URL: ")
   3998   (let ((dir eww-download-directory))
   3999     (when (functionp dir) (setq dir (funcall dir)))
   4000     (access-file dir "Download failed")
   4001     (url-retrieve url #'eww-download-callback (list url dir))))
   4002 
   4003 ;;; Setup and pre-action hooks
   4004 
   4005 (defun embark--restart (&rest _)
   4006   "Restart current command with current input.
   4007 Use this to refresh the list of candidates for commands that do
   4008 not handle that themselves."
   4009   (when (minibufferp)
   4010     (embark--become-command embark--command (minibuffer-contents))))
   4011 
   4012 (defun embark--shell-prep (&rest _)
   4013   "Prepare target for use as argument for a shell command.
   4014 This quotes the spaces, inserts an extra space at the beginning
   4015 and leaves the point to the left of it."
   4016   (let ((contents (minibuffer-contents)))
   4017     (delete-minibuffer-contents)
   4018     (insert " " (shell-quote-wildcard-pattern contents))
   4019     (goto-char (minibuffer-prompt-end))))
   4020 
   4021 (defun embark--force-complete (&rest _)
   4022   "Select first minibuffer completion candidate matching target."
   4023   (minibuffer-force-complete))
   4024 
   4025 (cl-defun embark--eval-prep (&key type &allow-other-keys)
   4026   "If target's TYPE is variable, skip edit; if function, wrap in ()."
   4027   (when (memq type '(command function))
   4028     (embark--allow-edit)
   4029     (goto-char (minibuffer-prompt-end))
   4030     (insert "(")
   4031     (goto-char (point-max))
   4032     (insert ")")
   4033     (backward-char)))
   4034 
   4035 (cl-defun embark--beginning-of-target (&key bounds &allow-other-keys)
   4036   "Go to beginning of the target BOUNDS."
   4037   (when (number-or-marker-p (car bounds))
   4038     (goto-char (car bounds))))
   4039 
   4040 (cl-defun embark--end-of-target (&key bounds &allow-other-keys)
   4041   "Go to end of the target BOUNDS."
   4042   (when (number-or-marker-p (cdr bounds))
   4043     (goto-char (cdr bounds))))
   4044 
   4045 (cl-defun embark--mark-target (&rest rest &key run bounds &allow-other-keys)
   4046   "Mark the target if its BOUNDS are known.
   4047 After marking the target, call RUN with the REST of its arguments."
   4048   (cond
   4049    ((and bounds run)
   4050     (save-mark-and-excursion
   4051       (set-mark (cdr bounds))
   4052       (goto-char (car bounds))
   4053       (apply run :bounds bounds rest)))
   4054    (bounds ;; used as pre- or post-action hook
   4055     (set-mark (cdr bounds))
   4056     (goto-char (car bounds)))
   4057    (run (apply run rest))))
   4058 
   4059 (cl-defun embark--unmark-target (&rest _)
   4060   "Deactivate the region target."
   4061   (deactivate-mark t))
   4062 
   4063 (cl-defun embark--narrow-to-target
   4064     (&rest rest &key run bounds &allow-other-keys)
   4065   "Narrow buffer to target if its BOUNDS are known.
   4066 Intended for use as an Embark around-action hook.  This function
   4067 runs RUN with the buffer narrowed to given BOUNDS passing along
   4068 the REST of the arguments."
   4069   (if bounds
   4070     (save-excursion
   4071       (save-restriction
   4072         (narrow-to-region (car bounds) (cdr bounds))
   4073         (goto-char (car bounds))
   4074         (apply run :bounds bounds rest)))
   4075     (apply run rest)))
   4076 
   4077 (defun embark--allow-edit (&rest _)
   4078   "Allow editing the target."
   4079   (remove-hook 'post-command-hook #'exit-minibuffer t)
   4080   (remove-hook 'post-command-hook 'ivy-immediate-done t))
   4081 
   4082 (defun embark--ignore-target (&rest _)
   4083   "Ignore the target."
   4084   (let ((contents
   4085          (get-text-property (minibuffer-prompt-end) 'embark--initial-input)))
   4086     (delete-minibuffer-contents)
   4087     (when contents (insert contents)))
   4088   (embark--allow-edit))
   4089 
   4090 (autoload 'xref-push-marker-stack "xref")
   4091 (defun embark--xref-push-marker (&rest _)
   4092   "Push a marker onto the xref marker stack."
   4093   (xref-push-marker-stack))
   4094 
   4095 (cl-defun embark--confirm (&key action target &allow-other-keys)
   4096   "Ask for confirmation before running the ACTION on the TARGET."
   4097   (unless (y-or-n-p (format "Run %s on %s? " action target))
   4098     (user-error "Canceled")))
   4099 
   4100 (defconst embark--associated-file-fn-alist
   4101   `((file . identity)
   4102     (buffer . ,(lambda (target)
   4103                  (let ((buffer (get-buffer target)))
   4104                    (or (buffer-file-name buffer)
   4105                        (buffer-local-value 'default-directory buffer)))))
   4106     (bookmark . bookmark-location)
   4107     (library . locate-library))
   4108   "Alist of functions that extract a file path from targets of a given type.")
   4109 
   4110 (defun embark--associated-directory (target type)
   4111   "Return directory associated to TARGET of given TYPE.
   4112 The supported values of TYPE are file, buffer, bookmark and
   4113 library, which have an obvious notion of associated directory."
   4114   (when-let ((file-fn (alist-get type embark--associated-file-fn-alist))
   4115              (file (funcall file-fn target)))
   4116     (if (file-directory-p file)
   4117         (file-name-as-directory file)
   4118       (file-name-directory file))))
   4119 
   4120 (cl-defun embark--cd (&rest rest &key run target type &allow-other-keys)
   4121   "Run action with `default-directory' set to the directory of TARGET.
   4122 The supported values of TYPE are file, buffer, bookmark and
   4123 library, which have an obvious notion of associated directory.
   4124 The REST of the arguments are also passed to RUN."
   4125   (let ((default-directory
   4126           (or (embark--associated-directory target type) default-directory)))
   4127     (apply run :target target :type type rest)))
   4128 
   4129 (cl-defun embark--save-excursion (&rest rest &key run &allow-other-keys)
   4130   "Run action without moving point.
   4131 This simply calls RUN with the REST of its arguments inside
   4132 `save-excursion'."
   4133   (save-excursion (apply run rest)))
   4134 
   4135 (defun embark--universal-argument (&rest _)
   4136   "Run action with a universal prefix argument."
   4137   (setq prefix-arg '(4)))
   4138 
   4139 ;;; keymaps
   4140 
   4141 (defvar-keymap embark-meta-map
   4142   :doc "Keymap for non-action Embark functions."
   4143   "-" #'negative-argument
   4144   "0" #'digit-argument
   4145   "1" #'digit-argument
   4146   "2" #'digit-argument
   4147   "3" #'digit-argument
   4148   "4" #'digit-argument
   4149   "5" #'digit-argument
   4150   "6" #'digit-argument
   4151   "7" #'digit-argument
   4152   "8" #'digit-argument
   4153   "9" #'digit-argument)
   4154 
   4155 (defvar-keymap embark-general-map
   4156   :doc "Keymap for Embark general actions."
   4157   :parent embark-meta-map
   4158   "i" #'embark-insert
   4159   "w" #'embark-copy-as-kill
   4160   "q" #'embark-toggle-quit
   4161   "E" #'embark-export
   4162   "S" #'embark-collect
   4163   "L" #'embark-live
   4164   "B" #'embark-become
   4165   "A" #'embark-act-all
   4166   "C-s" #'embark-isearch-forward
   4167   "C-r" #'embark-isearch-backward
   4168   "C-SPC" #'mark
   4169   "DEL" #'delete-region
   4170   "SPC" #'embark-select)
   4171 
   4172 (defvar-keymap embark-encode-map
   4173   :doc "Keymap for Embark region encoding actions."
   4174   "r" #'rot13-region
   4175   "." #'morse-region
   4176   "-" #'unmorse-region
   4177   "s" #'studlify-region
   4178   "m" #'embark-hash-md5
   4179   "1" #'embark-hash-sha1
   4180   "2" #'embark-hash-sha256
   4181   "3" #'embark-hash-sha384
   4182   "4" #'embark-hash-sha224
   4183   "5" #'embark-hash-sha512
   4184   "f" #'format-encode-region
   4185   "F" #'format-decode-region
   4186   "b" #'base64-encode-region
   4187   "B" #'base64-decode-region
   4188   "u" #'embark-encode-url
   4189   "U" #'embark-decode-url
   4190   "c" #'epa-encrypt-region
   4191   "C" #'embark-epa-decrypt-region)
   4192 
   4193 (fset 'embark-encode-map embark-encode-map)
   4194 
   4195 (defvar-keymap embark-sort-map
   4196   :doc "Keymap for Embark actions that sort the region"
   4197   "l" #'sort-lines
   4198   "P" #'sort-pages
   4199   "f" #'sort-fields
   4200   "c" #'sort-columns
   4201   "p" #'sort-paragraphs
   4202   "r" #'sort-regexp-fields
   4203   "n" #'sort-numeric-fields)
   4204 
   4205 (fset 'embark-sort-map embark-sort-map)
   4206 
   4207 ;; this has had an autoload cookie since at least Emacs 26
   4208 ;; but that autoload doesn't seem to work for me
   4209 (autoload 'org-table-convert-region "org-table" nil t)
   4210 
   4211 (defvar-keymap embark-region-map
   4212   :doc "Keymap for Embark actions on the active region."
   4213   :parent embark-general-map
   4214   "u" #'upcase-region
   4215   "l" #'downcase-region
   4216   "c" #'capitalize-region
   4217   "|" #'shell-command-on-region
   4218   "e" #'eval-region
   4219   "<" #'embark-eval-replace
   4220   "a" #'align
   4221   "A" #'align-regexp
   4222   "<left>" #'indent-rigidly
   4223   "<right>" #'indent-rigidly
   4224   "TAB" #'indent-region
   4225   "f" #'fill-region
   4226   "p" #'fill-region-as-paragraph
   4227   "$" #'ispell-region
   4228   "=" #'count-words-region
   4229   "F" #'whitespace-cleanup-region
   4230   "t" #'transpose-regions
   4231   "o" #'org-table-convert-region
   4232   ";" #'comment-or-uncomment-region
   4233   "W" #'write-region
   4234   "+" #'append-to-file
   4235   "m" #'apply-macro-to-region-lines
   4236   "n" #'narrow-to-region
   4237   "*" #'calc-grab-region
   4238   ":" #'calc-grab-sum-down
   4239   "_" #'calc-grab-sum-across
   4240   "r" #'reverse-region
   4241   "d" #'delete-duplicate-lines
   4242   "b" #'browse-url-of-region
   4243   "h" #'shr-render-region
   4244   "'" #'expand-region-abbrevs
   4245   "v" #'vc-region-history
   4246   "R" #'repunctuate-sentences
   4247   "s" 'embark-sort-map
   4248   ">" 'embark-encode-map)
   4249 
   4250 (defvar-keymap embark-vc-file-map
   4251   :doc "Keymap for Embark VC file actions."
   4252   "d" #'vc-delete-file
   4253   "r" #'vc-rename-file
   4254   "i" #'vc-ignore)
   4255 
   4256 (fset 'embark-vc-file-map embark-vc-file-map)
   4257 
   4258 (defvar-keymap embark-file-map
   4259   :doc "Keymap for Embark file actions."
   4260   :parent embark-general-map
   4261   "RET" #'find-file
   4262   "f" #'find-file
   4263   "F" #'find-file-literally
   4264   "o" #'find-file-other-window
   4265   "d" #'delete-file
   4266   "D" #'delete-directory
   4267   "r" #'rename-file
   4268   "c" #'copy-file
   4269   "s" #'make-symbolic-link
   4270   "j" #'embark-dired-jump
   4271   "!" #'shell-command
   4272   "&" #'async-shell-command
   4273   "$" #'eshell
   4274   "<" #'insert-file
   4275   "m" #'chmod
   4276   "=" #'ediff-files
   4277   "+" #'make-directory
   4278   "\\" #'embark-recentf-remove
   4279   "I" #'embark-insert-relative-path
   4280   "W" #'embark-save-relative-path
   4281   "x" #'embark-open-externally
   4282   "e" #'eww-open-file
   4283   "l" #'load-file
   4284   "b" #'byte-compile-file
   4285   "R" #'byte-recompile-directory
   4286   "v" 'embark-vc-file-map)
   4287 
   4288 (defvar-keymap embark-kill-ring-map
   4289   :doc "Keymap for `kill-ring' commands."
   4290   :parent embark-general-map
   4291   "\\" #'embark-kill-ring-remove)
   4292 
   4293 (defvar-keymap embark-url-map
   4294   :doc "Keymap for Embark url actions."
   4295   :parent embark-general-map
   4296   "RET" #'browse-url
   4297   "b" #'browse-url
   4298   "d" #'embark-download-url
   4299   "x" #'embark-open-externally
   4300   "e" #'eww)
   4301 
   4302 (defvar-keymap embark-email-map
   4303   :doc "Keymap for Embark email actions."
   4304   :parent embark-general-map
   4305   "RET" #'embark-compose-mail
   4306   "c" #'embark-compose-mail)
   4307 
   4308 (defvar-keymap embark-library-map
   4309   :doc "Keymap for operations on Emacs Lisp libraries."
   4310   :parent embark-general-map
   4311   "RET" #'find-library
   4312   "l" #'load-library
   4313   "f" #'find-library
   4314   "h" #'finder-commentary
   4315   "a" #'apropos-library
   4316   "L" #'locate-library
   4317   "m" #'info-display-manual
   4318   "$" #'eshell)
   4319 
   4320 (defvar-keymap embark-buffer-map
   4321   :doc "Keymap for Embark buffer actions."
   4322   :parent embark-general-map
   4323   "RET" #'switch-to-buffer
   4324   "k" #'kill-buffer
   4325   "b" #'switch-to-buffer
   4326   "o" #'switch-to-buffer-other-window
   4327   "z" #'embark-bury-buffer
   4328   "K" #'embark-kill-buffer-and-window
   4329   "r" #'embark-rename-buffer
   4330   "=" #'ediff-buffers
   4331   "|" #'embark-shell-command-on-buffer
   4332   "<" #'insert-buffer
   4333   "$" #'eshell)
   4334 
   4335 (defvar-keymap embark-tab-map
   4336   :doc "Keymap for actions for tab-bar tabs."
   4337   :parent embark-general-map
   4338   "RET" #'tab-bar-select-tab-by-name
   4339   "s" #'tab-bar-select-tab-by-name
   4340   "r" #'tab-bar-rename-tab-by-name
   4341   "k" #'tab-bar-close-tab-by-name)
   4342 
   4343 (defvar-keymap embark-identifier-map
   4344   :doc "Keymap for Embark identifier actions."
   4345   :parent embark-general-map
   4346   "RET" #'xref-find-definitions
   4347   "h" #'display-local-help
   4348   "H" #'embark-toggle-highlight
   4349   "d" #'xref-find-definitions
   4350   "r" #'xref-find-references
   4351   "a" #'xref-find-apropos
   4352   "s" #'info-lookup-symbol
   4353   "n" #'embark-next-symbol
   4354   "p" #'embark-previous-symbol
   4355   "'" #'expand-abbrev
   4356   "$" #'ispell-word
   4357   "o" #'occur)
   4358 
   4359 (defvar-keymap embark-expression-map
   4360   :doc "Keymap for Embark expression actions."
   4361   :parent embark-general-map
   4362   "RET" #'pp-eval-expression
   4363   "e" #'pp-eval-expression
   4364   "<" #'embark-eval-replace
   4365   "m" #'pp-macroexpand-expression
   4366   "TAB" #'indent-region
   4367   "r" #'raise-sexp
   4368   ";" #'comment-dwim
   4369   "t" #'transpose-sexps
   4370   "k" #'kill-region
   4371   "u" #'backward-up-list
   4372   "n" #'forward-list
   4373   "p" #'backward-list)
   4374 
   4375 (defvar-keymap embark-defun-map
   4376   :doc "Keymap for Embark defun actions."
   4377   :parent embark-expression-map
   4378   "RET" #'embark-pp-eval-defun
   4379   "e" #'embark-pp-eval-defun
   4380   "c" #'compile-defun
   4381   "D" #'edebug-defun
   4382   "o" #'checkdoc-defun
   4383   "N" #'narrow-to-defun)
   4384 
   4385 ;; Use quoted symbols to avoid byte-compiler warnings.
   4386 (defvar-keymap embark-heading-map
   4387   :doc "Keymap for Embark heading actions."
   4388   :parent embark-general-map
   4389   "RET" 'outline-show-subtree
   4390   "TAB" 'outline-cycle
   4391   "C-SPC" 'outline-mark-subtree
   4392   "n" 'outline-next-visible-heading
   4393   "p" 'outline-previous-visible-heading
   4394   "f" 'outline-forward-same-level
   4395   "b" 'outline-backward-same-level
   4396   "^" 'outline-move-subtree-up
   4397   "v" 'outline-move-subtree-down
   4398   "u" 'outline-up-heading
   4399   "+" 'outline-show-subtree
   4400   "-" 'outline-hide-subtree
   4401   ">" 'outline-demote
   4402   "<" 'outline-promote)
   4403 
   4404 (defvar-keymap embark-symbol-map
   4405   :doc "Keymap for Embark symbol actions."
   4406   :parent embark-identifier-map
   4407   "RET" #'embark-find-definition
   4408   "h" #'describe-symbol
   4409   "s" #'embark-info-lookup-symbol
   4410   "d" #'embark-find-definition
   4411   "e" #'pp-eval-expression
   4412   "a" #'apropos
   4413   "\\" #'embark-history-remove)
   4414 
   4415 (defvar-keymap embark-face-map
   4416   :doc "Keymap for Embark face actions."
   4417   :parent embark-symbol-map
   4418   "h" #'describe-face
   4419   "c" #'customize-face
   4420   "+" #'make-face-bold
   4421   "-" #'make-face-unbold
   4422   "/" #'make-face-italic
   4423   "|" #'make-face-unitalic
   4424   "!" #'invert-face
   4425   "f" #'set-face-foreground
   4426   "b" #'set-face-background)
   4427 
   4428 (defvar-keymap embark-variable-map
   4429   :doc "Keymap for Embark variable actions."
   4430   :parent embark-symbol-map
   4431   "=" #'set-variable
   4432   "c" #'customize-set-variable
   4433   "u" #'customize-variable
   4434   "v" #'embark-save-variable-value
   4435   "<" #'embark-insert-variable-value
   4436   "t" #'embark-toggle-variable)
   4437 
   4438 (defvar-keymap embark-function-map
   4439   :doc "Keymap for Embark function actions."
   4440   :parent embark-symbol-map
   4441   "m" #'elp-instrument-function ;; m=measure
   4442   "M" 'elp-restore-function ;; quoted, not autoloaded
   4443   "k" #'debug-on-entry ;; breaKpoint (running out of letters, really)
   4444   "K" #'cancel-debug-on-entry
   4445   "t" #'trace-function
   4446   "T" 'untrace-function) ;; quoted, not autoloaded
   4447 
   4448 (defvar-keymap embark-command-map
   4449   :doc "Keymap for Embark command actions."
   4450   :parent embark-function-map
   4451   "x" #'execute-extended-command
   4452   "I" #'Info-goto-emacs-command-node
   4453   "b" #'where-is
   4454   "g" #'global-set-key
   4455   "l" #'local-set-key)
   4456 
   4457 (defvar-keymap embark-package-map
   4458   :doc "Keymap for Embark package actions."
   4459   :parent embark-general-map
   4460   "RET" #'describe-package
   4461   "h" #'describe-package
   4462   "i" #'package-install
   4463   "I" #'embark-insert
   4464   "d" #'package-delete
   4465   "r" #'package-reinstall
   4466   "u" #'embark-browse-package-url
   4467   "W" #'embark-save-package-url
   4468   "a" #'package-autoremove
   4469   "g" #'package-refresh-contents
   4470   "m" #'elp-instrument-package ;; m=measure
   4471   "M" (if (fboundp 'embark-elp-restore-package)
   4472         'embark-elp-restore-package
   4473         'elp-restore-package))
   4474 
   4475 (defvar-keymap embark-bookmark-map
   4476   :doc "Keymap for Embark bookmark actions."
   4477   :parent embark-general-map
   4478   "RET" #'bookmark-jump
   4479   "s" #'bookmark-set
   4480   "d" #'bookmark-delete
   4481   "r" #'bookmark-rename
   4482   "R" #'bookmark-relocate
   4483   "l" #'bookmark-locate
   4484   "<" #'bookmark-insert
   4485   "j" #'bookmark-jump
   4486   "o" #'bookmark-jump-other-window
   4487   "f" #'bookmark-jump-other-frame
   4488   "a" 'bookmark-show-annotation
   4489   "e" 'bookmark-edit-annotation
   4490   "x" #'embark-bookmark-open-externally
   4491   "$" #'eshell)
   4492 
   4493 (defvar-keymap embark-unicode-name-map
   4494   :doc "Keymap for Embark Unicode name actions."
   4495   :parent embark-general-map
   4496   "RET" #'insert-char
   4497   "I" #'insert-char
   4498   "W" #'embark-save-unicode-character)
   4499 
   4500 (defvar-keymap embark-prose-map
   4501   :doc "Keymap for Embark actions for dealing with prose."
   4502   :parent embark-general-map
   4503   "$" #'ispell-region
   4504   "f" #'fill-region
   4505   "u" #'upcase-region
   4506   "l" #'downcase-region
   4507   "c" #'capitalize-region
   4508   "F" #'whitespace-cleanup-region
   4509   "=" #'count-words-region)
   4510 
   4511 (defvar-keymap embark-sentence-map
   4512   :doc "Keymap for Embark actions for dealing with sentences."
   4513   :parent embark-prose-map
   4514   "t" #'transpose-sentences
   4515   "n" #'forward-sentence
   4516   "p" #'backward-sentence)
   4517 
   4518 (defvar-keymap embark-paragraph-map
   4519   :doc "Keymap for Embark actions for dealing with paragraphs."
   4520   :parent embark-prose-map
   4521   "t" #'transpose-paragraphs
   4522   "n" #'forward-paragraph
   4523   "p" #'backward-paragraph
   4524   "R" #'repunctuate-sentences)
   4525 
   4526 (defvar-keymap embark-flymake-map
   4527   :doc "Keymap for Embark actions on Flymake diagnostics."
   4528   :parent embark-general-map
   4529   "RET" 'flymake-show-buffer-diagnostics
   4530   "n" 'flymake-goto-next-error
   4531   "p" 'flymake-goto-prev-error)
   4532 
   4533 (defvar-keymap embark-become-help-map
   4534   :doc "Keymap for Embark help actions."
   4535   :parent embark-meta-map
   4536   "V" #'apropos-variable
   4537   "U" #'apropos-user-option
   4538   "C" #'apropos-command
   4539   "v" #'describe-variable
   4540   "f" #'describe-function
   4541   "s" #'describe-symbol
   4542   "F" #'describe-face
   4543   "p" #'describe-package
   4544   "i" #'describe-input-method)
   4545 
   4546 (autoload 'recentf-open-files "recentf" nil t)
   4547 
   4548 (defvar-keymap embark-become-file+buffer-map
   4549   :doc "Embark become keymap for files and buffers."
   4550   :parent embark-meta-map
   4551   "f" #'find-file
   4552   "4 f" #'find-file-other-window
   4553   "." #'find-file-at-point
   4554   "p" #'project-find-file
   4555   "r" #'recentf-open-files
   4556   "b" #'switch-to-buffer
   4557   "4 b" #'switch-to-buffer-other-window
   4558   "l" #'locate
   4559   "L" #'find-library
   4560   "v" #'vc-dir)
   4561 
   4562 (defvar-keymap embark-become-shell-command-map
   4563   :doc "Embark become keymap for shell commands."
   4564   :parent embark-meta-map
   4565   "!" #'shell-command
   4566   "&" #'async-shell-command
   4567   "c" #'comint-run
   4568   "t" #'term)
   4569 
   4570 (defvar-keymap embark-become-match-map
   4571   :doc "Embark become keymap for search."
   4572   :parent embark-meta-map
   4573   "o" #'occur
   4574   "k" #'keep-lines
   4575   "f" #'flush-lines
   4576   "c" #'count-matches)
   4577 
   4578 (provide 'embark)
   4579 
   4580 ;; Check that embark-consult is installed. If Embark is used in
   4581 ;; combination with Consult, you should install the integration package,
   4582 ;; such that features like embark-export from consult-grep work as
   4583 ;; expected.
   4584 
   4585 (with-eval-after-load 'consult
   4586   (unless (require 'embark-consult nil 'noerror)
   4587     (warn "The package embark-consult should be installed if you use both Embark and Consult")))
   4588 
   4589 (with-eval-after-load 'org
   4590   (require 'embark-org))
   4591 
   4592 ;;; embark.el ends here