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