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