config

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

embark-org.el (26769B)


      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)
    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 (unless (memq 'embark-org-target-element-context embark-target-finders)
    123   (if-let ((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