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