embark-org.el (26788B)
1 ;;; embark-org.el --- Embark targets and actions for Org Mode -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2022-2023 Free Software Foundation, Inc. 4 5 ;; This program is free software; you can redistribute it and/or modify 6 ;; it under the terms of the GNU General Public License as published by 7 ;; the Free Software Foundation, either version 3 of the License, or 8 ;; (at your option) any later version. 9 10 ;; This program is distributed in the hope that it will be useful, 11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 ;; GNU General Public License for more details. 14 15 ;; You should have received a copy of the GNU General Public License 16 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 17 18 ;;; Commentary: 19 20 ;; This package configures the Embark package for use in Org Mode 21 ;; buffers. It teaches Embark a number of Org related targets and 22 ;; appropriate actions. Currently it has table cells, whole tables, 23 ;; source blocks and links. Targets to add: headings (Embark already 24 ;; has generic support for outlines, so we just nee to add Org 25 ;; specific actions), timestamps, etc. 26 27 ;;; Code: 28 29 (require 'embark) 30 (require 'org) 31 (require 'org-element) 32 33 ;;; Basic target finder for Org 34 35 ;; There are very many org element and objects types, we'll only 36 ;; recognize those for which there are specific actions we can put in 37 ;; a keymap, or even if there aren't any specific actions, if it's 38 ;; important to be able to kill, delete or duplicate (embark-insert) 39 ;; them conveniently. I'll start conservatively and we can add more 40 ;; later 41 42 (defconst embark-org--types 43 '( 44 babel-call 45 ;; bold 46 ;; center-block 47 ;; citation 48 ;; citation-reference 49 ;; clock 50 ;; code 51 ;; comment 52 ;; comment-block 53 ;; diary-sexp 54 ;; drawer 55 ;; dynamic-block 56 ;; entity 57 ;; example-block 58 ;; export-block 59 ;; export-snippet 60 ;; fixed-width 61 footnote-definition 62 footnote-reference 63 ;; headline ; the bounds include the entire subtree! 64 ;; horizontal-rule 65 ;; inline-babel-call 66 inline-src-block 67 ;; inlinetask 68 ;; italic 69 item 70 ;; keyword 71 ;; latex-environment 72 ;; latex-fragment 73 ;; line-break 74 link 75 ;; macro 76 ;; node-property 77 ;; paragraph ; the existing general support seems fine 78 plain-list 79 ;; planning 80 ;; property-drawer 81 ;; quote-block 82 ;; radio-target 83 ;; section 84 ;; special-block 85 src-block 86 ;; statistics-cookie 87 ;; strike-through 88 ;; subscript 89 ;; superscript 90 table ; supported via a specific target finder 91 table-cell 92 ;; table-row ; we'll put row & column actions in the cell map 93 ;; target ; I think there are no useful actions for radio targets 94 timestamp 95 ;; underline 96 ;; verbatim 97 ;; verse-block 98 ) 99 "Supported Org object and element types.") 100 101 (defun embark-org-target-element-context () 102 "Target all Org elements or objects around point." 103 (when (derived-mode-p 'org-mode 'org-agenda-mode) 104 (cl-loop 105 for elt = (org-element-lineage (org-element-context) embark-org--types t) 106 then (org-element-lineage elt embark-org--types) 107 while elt 108 ;; clip bounds to narrowed portion of buffer 109 for begin = (max (org-element-property :begin elt) (point-min)) 110 for end = (min (org-element-property :end elt) (point-max)) 111 for target = (buffer-substring begin end) 112 ;; Adjust table-cell to exclude final |. (Why is that there?) 113 ;; Note: We are not doing this as an embark transformer because we 114 ;; want to adjust the bounds too. 115 ;; TODO? If more adjustments like this become necessary, add a 116 ;; nice mechanism for doing them. 117 when (and (eq (car elt) 'table-cell) (string-suffix-p "|" target)) 118 do (setq target (string-trim (string-remove-suffix "|" target)) 119 end (1- end)) 120 collect `(,(intern (format "org-%s" (car elt))) ,target ,begin . ,end)))) 121 122 (if-let (((not (memq 'embark-org-target-element-context embark-target-finders))) 123 (tail (memq 'embark-target-active-region embark-target-finders))) 124 (push 'embark-org-target-element-context (cdr tail)) 125 (push 'embark-org-target-element-context embark-target-finders)) 126 127 ;;; Custom Org actions 128 129 (defvar org-export-with-toc) 130 131 (defun embark-org-copy-as-markdown (start end) 132 "Export the region from START to END to markdown and save on the `kill-ring'." 133 (interactive "r") 134 (require 'ox) 135 (kill-new 136 (let (org-export-with-toc) 137 (string-trim 138 (org-export-string-as (buffer-substring-no-properties start end) 'md t)))) 139 (deactivate-mark)) 140 141 (add-to-list 'embark-pre-action-hooks 142 '(embark-org-copy-as-markdown embark--mark-target)) 143 144 (keymap-set embark-region-map "M" #'embark-org-copy-as-markdown) ; good idea? 145 146 ;;; Tables 147 148 (dolist (motion '(org-table-move-cell-up org-table-move-cell-down 149 org-table-move-cell-left org-table-move-cell-right 150 org-table-move-row org-table-move-column 151 org-table-move-row-up org-table-move-row-down 152 org-table-move-column-left org-table-move-column-right)) 153 (add-to-list 'embark-repeat-actions motion)) 154 155 (dolist (cmd '(org-table-eval-formula org-table-edit-field)) 156 (push 'embark--ignore-target (alist-get cmd embark-target-injection-hooks))) 157 158 (defvar-keymap embark-org-table-cell-map 159 :doc "Keymap for actions the current cells, column or row of an Org table." 160 :parent embark-general-map 161 "RET" #'org-table-align ; harmless default 162 "<up>" #'org-table-move-cell-up 163 "<down>" #'org-table-move-cell-down 164 "<left>" #'org-table-move-cell-left 165 "<right>" #'org-table-move-cell-right 166 "d" #'org-table-kill-row 167 "c" #'org-table-copy-down 168 "D" #'org-table-delete-column ; capital = column 169 "^" #'org-table-move-row-up 170 "v" #'org-table-move-row-down 171 "<" #'org-table-move-column-left 172 ">" #'org-table-move-column-right 173 "o" #'org-table-insert-row 174 "O" #'org-table-insert-column ; capital = column 175 "h" #'org-table-insert-hline 176 "=" #'org-table-eval-formula 177 "e" #'org-table-edit-field 178 "g" #'org-table-recalculate) 179 180 (defvar-keymap embark-org-table-map 181 :doc "Keymap for actions on entire Org table." 182 :parent embark-general-map 183 "RET" #'org-table-align ; harmless default 184 "=" #'org-table-edit-formulas 185 "s" #'org-table-sort-lines 186 "t" #'org-table-transpose-table-at-point 187 "c" #'org-table-convert 188 "f" #'org-table-follow-field-mode 189 "y" #'org-table-paste-rectangle 190 "d" #'org-table-toggle-formula-debugger 191 "o" #'org-table-toggle-coordinate-overlays 192 "g" #'org-table-iterate 193 "e" #'org-table-export) 194 195 (push 'embark--ignore-target ; prompts for file name 196 (alist-get 'org-table-export embark-target-injection-hooks)) 197 198 (add-to-list 'embark-keymap-alist '(org-table embark-org-table-map)) 199 200 (add-to-list 'embark-keymap-alist '(org-table-cell embark-org-table-cell-map)) 201 202 ;;; Links 203 204 ;; The link support has a slightly complicated design in order to 205 ;; achieve the following goals: 206 207 ;; 1. RET should simply be org-open-at-point 208 209 ;; 2. When the link is to a file, URL, email address or elisp 210 ;; expression or command, we want to offer the user actions for 211 ;; that underlying type. 212 213 ;; 3. Even in those cases, we still want some actions to apply to the 214 ;; entire link including description: actions to copy the link as 215 ;; markdown, or just the link description or target. 216 217 ;; So the strategy is as follows (illustrated with file links): 218 219 ;; - The target will be just the file, without the description and 220 ;; also without the "file:" prefix nor the "::line-number or search" 221 ;; suffix. That way, file actions will correctly apply to it. 222 223 ;; - The type will not be 'file, but 'org-file-link; that way we can 224 ;; register a keymap for 'org-file-link that inherits from both 225 ;; embark-org-link-map (with RET bound to org-open-at-point and a 226 ;; few other generic link actions) and embark-file-map. 227 228 ;; - The commands to copy the link at point in some format will be 229 ;; written as commands that act on the Org link at point. This way 230 ;; they are independently (plausibly) useful, and we circumvent the 231 ;; problem that the whole Org link is not actually the target (just 232 ;; the inner file is!). 233 234 ;; Alternative design I considered: separate each target into two, a 235 ;; whole link target which includes the description and brackets and 236 ;; what not; and an "inner target" which is just the file or URL or 237 ;; whatever. Cons of this approach: much target cycling is required! 238 ;; First of all, an unadorned embark-dwim definitely should be 239 ;; org-open-at-point, which means the whole link target would need 240 ;; priority. That means that any file, URL, etc. actions would require 241 ;; you to cycle first. This sounds very inconvenient, the above 242 ;; slightly more complex design allows both whole-link and inner 243 ;; target actions to work without cycling. 244 245 (defun embark-org-target-link () 246 "Target Org link at point. 247 This targets Org links in any buffer, not just buffers in 248 `org-mode' or `org-agenda-mode'. Org links in any buffer can be 249 opened with `org-open-at-point-global', which is the default 250 Embark action for Org links." 251 (pcase (org-in-regexp org-link-any-re) 252 (`(,start . ,end) 253 ;; We won't recognize unadorned http(s) or mailto links, as those 254 ;; already have target finders (but if these links have either a 255 ;; description, double brackets or angle brackets, then we do 256 ;; recognize them as org links) 257 (unless (save-excursion (goto-char start) (looking-at "http\\|mailto")) 258 `(org-link ,(buffer-substring start end) ,start . ,end))))) 259 260 (let ((tail (memq 'embark-target-active-region embark-target-finders))) 261 (cl-pushnew 'embark-org-target-link (cdr tail))) 262 263 (autoload 'org-attach-dir "org-attach") 264 265 (defun embark-org--refine-link-type (_type target) 266 "Refine type of link TARGET if we have more specific actions available." 267 (when (string-match org-link-any-re target) 268 (let ((target (or (match-string-no-properties 2 target) 269 (match-string-no-properties 0 target)))) 270 (cond 271 ((string-prefix-p "http" target) 272 (cons 'org-url-link target)) 273 ((string-prefix-p "mailto:" target) 274 (cons 'org-email-link (string-remove-prefix "mailto:" target))) 275 ((string-prefix-p "file:" target) 276 (cons 'org-file-link 277 (replace-regexp-in-string 278 "::.*" "" (string-remove-prefix "file:" target)))) 279 ((string-prefix-p "attachment:" target) 280 (cons 'org-file-link 281 (expand-file-name 282 (replace-regexp-in-string 283 "::.*" "" (string-remove-prefix "attachment:" target)) 284 (org-attach-dir)))) 285 ((string-match-p "^[./]" target) 286 (cons 'org-file-link (abbreviate-file-name (expand-file-name target)))) 287 ((string-prefix-p "elisp:(" target) 288 (cons 'org-expression-link (string-remove-prefix "elisp:" target))) 289 ((string-prefix-p "elisp:" target) 290 (cons 'command (string-remove-prefix "elisp:" target))) 291 (t (cons 'org-link target)))))) 292 293 (add-to-list 'embark-transformer-alist 294 '(org-link . embark-org--refine-link-type)) 295 296 (defmacro embark-org-define-link-copier (name formula description) 297 "Define a command that copies the Org link at point according to FORMULA. 298 The command's name is formed by appending NAME to 299 embark-org-copy-link. The docstring includes the DESCRIPTION of 300 what part or in what format the link is copied." 301 `(defun ,(intern (format "embark-org-copy-link-%s" name)) () 302 ,(format "Copy to the kill-ring the Org link at point%s." description) 303 (interactive) 304 (when (org-in-regexp org-link-any-re) 305 (let* ((full (match-string-no-properties 0)) 306 (target (or (match-string-no-properties 2) 307 (match-string-no-properties 0))) 308 (description (match-string-no-properties 3)) 309 (kill ,formula)) 310 (ignore full target description) 311 (when kill 312 (message "Saved '%s'" kill) 313 (kill-new kill)))))) 314 315 (embark-org-define-link-copier in-full full " in full") 316 (embark-org-define-link-copier description description "'s description") 317 (embark-org-define-link-copier target target "'s target") 318 319 (defalias 'embark-org-copy-link-inner-target #'kill-new 320 "Copy inner part of the Org link at point's target. 321 For mailto and elisp links, the inner part is the portion of the 322 target after `mailto:' or `elisp:'. 323 324 For file links the inner part is the file name, without the 325 `file:' prefix and without `::' suffix (used for line numbers, 326 IDs or search terms). 327 328 For URLs the inner part is the whole target including the `http:' 329 or `https:' prefix. For any other type of link the inner part is 330 also the whole target.") 331 332 (defvar-keymap embark-org-link-copy-map 333 :doc "Keymap for different ways to copy Org links to the kill-ring. 334 335 You should bind w in this map to your most frequently used link 336 copying function. The default is for w to copy the \"inner 337 target\" (see `embark-org-copy-link-inner-target'); which is also 338 bound to i." 339 :parent nil 340 "w" #'embark-org-copy-link-inner-target 341 "f" #'embark-org-copy-link-in-full 342 "d" #'embark-org-copy-link-description 343 "t" #'embark-org-copy-link-target 344 "i" #'embark-org-copy-link-inner-target 345 "m" #'embark-org-copy-as-markdown) 346 347 (fset 'embark-org-link-copy-map embark-org-link-copy-map) 348 349 (defvar-keymap embark-org-link-map 350 :doc "Keymap for actions on Org links." 351 :parent embark-general-map 352 "RET" #'org-open-at-point-global 353 "'" #'org-insert-link 354 "n" #'org-next-link 355 "p" #'org-previous-link 356 "w" #'embark-org-link-copy-map) 357 358 (dolist (motion '(org-next-link org-previous-link)) 359 (cl-pushnew motion embark-repeat-actions)) 360 361 ;; The reason for this is left as an exercise to the reader. 362 ;; Solution: Na ryvfc gnetrg znl cebzcg gur hfre sbe fbzrguvat! 363 (cl-pushnew 'embark--ignore-target 364 (alist-get 'org-open-at-point embark-target-injection-hooks)) 365 (cl-pushnew 'embark--ignore-target 366 (alist-get 'org-insert-link embark-target-injection-hooks)) 367 368 (add-to-list 'embark-keymap-alist 369 '(org-link embark-org-link-map)) 370 (add-to-list 'embark-keymap-alist 371 '(org-url-link embark-org-link-map embark-url-map)) 372 (add-to-list 'embark-keymap-alist 373 '(org-email-link embark-org-link-map embark-email-map)) 374 (add-to-list 'embark-keymap-alist 375 '(org-file-link embark-org-link-map embark-file-map)) 376 (add-to-list 'embark-keymap-alist 377 '(org-expression-link embark-org-link-map embark-expression-map)) 378 379 ;;; Org headings 380 381 (defun embark-org--refine-heading (type target) 382 "Refine TYPE of heading TARGET in Org buffers." 383 (cons 384 (if (derived-mode-p 'org-mode) 'org-heading type) 385 target)) 386 387 (add-to-list 'embark-transformer-alist '(heading . embark-org--refine-heading)) 388 389 (defvar-keymap embark-org-heading-map 390 :doc "Keymap for actions on Org headings." 391 :parent embark-heading-map 392 "RET" #'org-todo 393 "TAB" #'org-cycle 394 "t" #'org-todo 395 "s" #'org-schedule 396 "d" #'org-deadline 397 "," #'org-priority 398 ":" #'org-set-tags-command 399 "P" #'org-set-property 400 "D" #'org-delete-property 401 "k" #'org-cut-subtree 402 "N" #'org-narrow-to-subtree 403 "T" #'org-tree-to-indirect-buffer 404 "<left>" #'org-do-promote 405 "<right>" #'org-do-demote 406 "o" #'org-sort 407 "r" #'org-refile 408 "R" #'embark-org-refile-here 409 "I" #'org-clock-in 410 "O" #'org-clock-out 411 "a" #'org-archive-subtree-default-with-confirmation 412 "h" #'org-insert-heading-respect-content 413 "H" #'org-insert-todo-heading-respect-content 414 "l" #'org-store-link 415 "j" #'embark-org-insert-link-to) 416 417 (dolist (cmd '(org-todo org-metaright org-metaleft org-metaup org-metadown 418 org-shiftmetaleft org-shiftmetaright org-cycle org-shifttab)) 419 (cl-pushnew cmd embark-repeat-actions)) 420 421 (dolist (cmd '(org-set-tags-command org-set-property 422 org-delete-property org-refile org-schedule)) 423 (cl-pushnew 'embark--ignore-target 424 (alist-get cmd embark-target-injection-hooks))) 425 426 (add-to-list 'embark-keymap-alist '(org-heading embark-org-heading-map)) 427 428 ;;; Source blocks 429 430 (defun embark-org-copy-block-contents () 431 "Save contents of source block at point to the `kill-ring'." 432 (interactive) 433 (when (org-in-src-block-p) 434 (let ((contents (nth 2 (org-src--contents-area (org-element-at-point))))) 435 (with-temp-buffer 436 (insert contents) 437 (org-do-remove-indentation) 438 (kill-new (buffer-substring (point-min) (point-max))))))) 439 440 (defvar-keymap embark-org-src-block-map 441 :doc "Keymap for actions on Org source blocks." 442 :parent embark-general-map 443 "RET" #'org-babel-execute-src-block 444 "C-SPC" #'org-babel-mark-block 445 "TAB" #'org-indent-block 446 "c" #'embark-org-copy-block-contents 447 "h" #'org-babel-check-src-block 448 "k" #'org-babel-remove-result-one-or-many 449 "p" #'org-babel-previous-src-block 450 "n" #'org-babel-next-src-block 451 "t" #'org-babel-tangle 452 "s" #'org-babel-switch-to-session 453 "l" #'org-babel-load-in-session 454 "'" #'org-edit-special 455 "/" #'org-babel-demarcate-block 456 "N" #'org-narrow-to-block) 457 458 (cl-defun embark-org--at-block-head 459 (&rest rest &key run bounds &allow-other-keys) 460 "Save excursion and RUN the action at the head of the current block. 461 If BOUNDS are given, use them to locate the block (useful for 462 when acting on a selection of blocks). Applies RUN to the REST 463 of the arguments." 464 (save-excursion 465 (when bounds (goto-char (car bounds))) 466 (org-babel-goto-src-block-head) 467 (apply run rest))) 468 469 (cl-pushnew #'embark-org--at-block-head 470 (alist-get 'org-indent-block embark-around-action-hooks)) 471 472 (dolist (motion '(org-babel-next-src-block org-babel-previous-src-block)) 473 (add-to-list 'embark-repeat-actions motion)) 474 475 (dolist (cmd '(org-babel-execute-maybe 476 org-babel-lob-execute-maybe 477 org-babel-execute-src-block 478 org-babel-execute-src-block-maybe 479 org-babel-execute-buffer 480 org-babel-execute-subtree)) 481 (cl-pushnew #'embark--ignore-target 482 (alist-get cmd embark-target-injection-hooks))) 483 484 (add-to-list 'embark-keymap-alist '(org-src-block embark-org-src-block-map)) 485 486 ;;; Inline source blocks 487 488 (defvar-keymap embark-org-inline-src-block-map 489 :doc "Keymap for actions on Org inline source blocks." 490 :parent embark-general-map 491 "RET" #'org-babel-execute-src-block 492 "'" #'org-edit-inline-src-code 493 "k" #'org-babel-remove-inline-result) 494 495 (add-to-list 'embark-keymap-alist 496 '(org-inline-src-block embark-org-inline-src-block-map)) 497 498 ;;; Babel calls 499 500 (defvar-keymap embark-org-babel-call-map 501 :doc "Keymap for actions on Org babel calls." 502 :parent embark-general-map 503 "RET" #'org-babel-lob-execute-maybe 504 "k" #'org-babel-remove-result) 505 506 (add-to-list 'embark-keymap-alist 507 '(org-babel-call embark-org-babel-call-map)) 508 509 ;;; List items 510 511 (defvar-keymap embark-org-item-map 512 :doc "Keymap for actions on Org list items." 513 :parent embark-general-map 514 "RET" #'org-toggle-checkbox 515 "c" #'org-toggle-checkbox 516 "t" #'org-toggle-item 517 "n" #'org-next-item 518 "p" #'org-previous-item 519 "<left>" #'org-outdent-item 520 "<right>" #'org-indent-item 521 "<up>" #'org-move-item-up 522 "<down>" #'org-move-item-down 523 ">" #'org-indent-item-tree 524 "<" #'org-outdent-item-tree) 525 526 (dolist (cmd '(org-toggle-checkbox 527 org-toggle-item 528 org-next-item 529 org-previous-item 530 org-outdent-item 531 org-indent-item 532 org-move-item-up 533 org-move-item-down 534 org-indent-item-tree 535 org-outdent-item-tree)) 536 (add-to-list 'embark-repeat-actions cmd)) 537 538 (add-to-list 'embark-keymap-alist '(org-item embark-org-item-map)) 539 540 ;;; Org plain lists 541 542 (defvar-keymap embark-org-plain-list-map 543 :doc "Keymap for actions on plain Org lists." 544 :parent embark-general-map 545 "RET" #'org-list-repair 546 "r" #'org-list-repair 547 "s" #'org-sort-list 548 "b" #'org-cycle-list-bullet 549 "t" #'org-list-make-subtree 550 "c" #'org-toggle-checkbox) 551 552 (add-to-list 'embark-repeat-actions 'org-cycle-list-bullet) 553 554 (add-to-list 'embark-keymap-alist '(org-plain-list embark-org-plain-list-map)) 555 556 (cl-defun embark-org--toggle-checkboxes 557 (&rest rest &key run type &allow-other-keys) 558 "Around action hook for `org-toggle-checkbox'. 559 See `embark-around-action-hooks' for the keyword arguments RUN and TYPE. 560 REST are the remaining arguments." 561 (apply (if (eq type 'org-plain-list) #'embark--mark-target run) 562 :type type 563 rest)) 564 565 (cl-pushnew #'embark-org--toggle-checkboxes 566 (alist-get 'org-toggle-checkbox embark-around-action-hooks)) 567 568 ;;; "Encode" region using Org export in place 569 570 (defvar-keymap embark-org-export-in-place-map 571 :doc "Keymap for actions which replace the region by an exported version." 572 :parent embark-general-map 573 "m" #'org-md-convert-region-to-md 574 "h" #'org-html-convert-region-to-html 575 "a" #'org-ascii-convert-region-to-ascii 576 "l" #'org-latex-convert-region-to-latex) 577 578 (fset 'embark-org-export-in-place-map embark-org-export-in-place-map) 579 580 (keymap-set embark-encode-map "o" 'embark-org-export-in-place-map) 581 582 ;;; References to Org headings, such as agenda items 583 584 ;; These are targets that represent an org heading but not in the 585 ;; current buffer, instead they have a text property named 586 ;; `org-marker' that points to the actual heading. 587 588 (defun embark-org-target-agenda-item () 589 "Target Org agenda item at point." 590 (when (and (derived-mode-p 'org-agenda-mode) 591 (get-text-property (line-beginning-position) 'org-marker)) 592 (let ((start (+ (line-beginning-position) (current-indentation))) 593 (end (line-end-position))) 594 `(org-heading ,(buffer-substring start end) ,start . ,end)))) 595 596 (let ((tail (memq 'embark-org-target-element-context embark-target-finders))) 597 (cl-pushnew 'embark-org-target-agenda-item (cdr tail))) 598 599 (cl-defun embark-org--at-heading 600 (&rest rest &key run target &allow-other-keys) 601 "RUN the action at the location of the heading TARGET refers to. 602 The location is given by the `org-marker' text property of 603 target. Applies RUN to the REST of the arguments." 604 (if-let ((marker (get-text-property 0 'org-marker target))) 605 (org-with-point-at marker 606 (apply run :target target rest)) 607 (apply run :target target rest))) 608 609 (cl-defun embark-org-goto-heading (&key target &allow-other-keys) 610 "Jump to the org heading TARGET refers to." 611 (when-let ((marker (get-text-property 0 'org-marker target))) 612 (pop-to-buffer (marker-buffer marker)) 613 (widen) 614 (goto-char marker) 615 (org-reveal) 616 (pulse-momentary-highlight-one-line))) 617 618 (defun embark-org-heading-default-action (target) 619 "Default action for Org headings. 620 There are two types of heading TARGETs: the heading at point in a 621 normal org buffer, and references to org headings in some other 622 buffer (for example, org agenda items). For references the 623 default action is to jump to the reference, and for the heading 624 at point, the default action is whatever is bound to RET in 625 `embark-org-heading-map', or `org-todo' if RET is unbound." 626 (if (get-text-property 0 'org-marker target) 627 (embark-org-goto-heading :target target) 628 (command-execute 629 (or (keymap-lookup embark-org-heading-map "RET") #'org-todo)))) 630 631 (defconst embark-org--invisible-jump-to-heading 632 '(org-tree-to-indirect-buffer 633 org-refile 634 org-clock-in 635 org-clock-out 636 org-archive-subtree-default-with-confirmation 637 org-store-link) 638 "Org heading actions which won't display the heading's buffer.") 639 640 (defconst embark-org--no-jump-to-heading 641 '(embark-org-insert-link-to embark-org-refile-here) 642 "Org heading actions which shouldn't be executed with point at the heading.") 643 644 (setf (alist-get 'org-heading embark-default-action-overrides) 645 #'embark-org-heading-default-action) 646 647 (map-keymap 648 (lambda (_key cmd) 649 (unless (or (where-is-internal cmd (list embark-general-map)) 650 (memq cmd embark-org--no-jump-to-heading) 651 (memq cmd embark-org--invisible-jump-to-heading)) 652 (cl-pushnew 'embark-org-goto-heading 653 (alist-get cmd embark-pre-action-hooks)))) 654 embark-org-heading-map) 655 656 (dolist (cmd embark-org--invisible-jump-to-heading) 657 (cl-pushnew 'embark-org--at-heading 658 (alist-get cmd embark-around-action-hooks))) 659 660 (defun embark-org--in-source-window (target function) 661 "Call FUNCTION, in the source window, on TARGET's `org-marker'. 662 663 If TARGET does not have an `org-marker' property a `user-error' 664 is signaled. In case the TARGET comes from an org agenda buffer 665 and the `other-window-for-scrolling' is an org mode buffer, then 666 the FUNCTION is called with that other window temporarily 667 selected; otherwise the FUNCTION is called in the selected 668 window." 669 (if-let ((marker (get-text-property 0 'org-marker target))) 670 (with-selected-window 671 (or (and (derived-mode-p 'org-agenda-mode) 672 (let ((window (ignore-errors (other-window-for-scrolling)))) 673 (with-current-buffer (window-buffer window) 674 (when (derived-mode-p 'org-mode) window)))) 675 (selected-window)) 676 (funcall function marker)) 677 (user-error "The target is an org heading rather than a reference to one"))) 678 679 (defun embark-org-refile-here (target) 680 "Refile the heading at point in the source window to TARGET. 681 682 If TARGET is an agenda item and `other-window-for-scrolling' is 683 displaying an org mode buffer, then that is the source window. 684 If TARGET is a minibuffer completion candidate, then the source 685 window is the window selected before the command that opened the 686 minibuffer ran." 687 (embark-org--in-source-window target 688 (lambda (marker) 689 (org-refile nil nil 690 ;; The RFLOC argument: 691 (list 692 ;; Name 693 (org-with-point-at marker 694 (nth 4 (org-heading-components))) 695 ;; File 696 (buffer-file-name (marker-buffer marker)) 697 ;; nil 698 nil 699 ;; Position 700 marker))))) 701 702 (defun embark-org-insert-link-to (target) 703 "Insert a link to the TARGET in the source window. 704 705 If TARGET is an agenda item and `other-window-for-scrolling' is 706 displaying an org mode buffer, then that is the source window. 707 If TARGET is a minibuffer completion candidate, then the source 708 window is the window selected before the command that opened the 709 minibuffer ran." 710 (embark-org--in-source-window target 711 (lambda (marker) 712 (org-with-point-at marker (org-store-link nil t)) 713 (org-insert-all-links 1 "" "")))) 714 715 (provide 'embark-org) 716 ;;; embark-org.el ends here