embark-org.el (18061B)
1 ;;; embark-org.el --- Embark targets and actions for Org Mode -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2022 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 for even if there aren't any specific actions, if it's 38 ;; import to be able to kill, delete or duplicate (embark-insert) them 39 ;; conveniently. I'll start conservatively and we can add more later 40 41 (defconst embark-org--types 42 '( 43 babel-call 44 ;; bold 45 ;; center-block 46 ;; citation 47 ;; citation-reference 48 ;; clock 49 ;; code 50 ;; comment 51 ;; comment-block 52 ;; diary-sexp 53 ;; drawer 54 ;; dynamic-block 55 ;; entity 56 ;; example-block 57 ;; export-block 58 ;; export-snippet 59 ;; fixed-width 60 footnote-definition 61 footnote-reference 62 ;; headline ; the bounds include the entire subtree! 63 ;; horizontal-rule 64 ;; inline-babel-call 65 ;; inline-src-block 66 ;; inlinetask 67 ;; italic 68 item 69 ;; keyword 70 ;; latex-environment 71 ;; latex-fragment 72 ;; line-break 73 link 74 ;; macro 75 ;; node-property 76 ;; paragraph ; the existing general support seems fine 77 plain-list 78 ;; planning 79 ;; property-drawer 80 ;; quote-block 81 ;; radio-target 82 ;; section 83 ;; special-block 84 src-block 85 ;; statistics-cookie 86 ;; strike-through 87 ;; subscript 88 ;; superscript 89 table ; supported via a specific target finder 90 table-cell 91 ;; table-row ; we'll put row & column actions in the cell map 92 ;; target ; I think there are no useful actions for radio targets 93 timestamp 94 ;; underline 95 ;; verbatim 96 ;; verse-block 97 ) 98 "Supported Org object and element types.") 99 100 (defun embark-org-target-element-context () 101 "Target all Org elements or objects around point." 102 (when (derived-mode-p 'org-mode 'org-agenda-mode) 103 (cl-loop 104 for elt = (org-element-lineage (org-element-context) embark-org--types t) 105 then (org-element-lineage elt embark-org--types) 106 while elt 107 ;; clip bounds to narrowed portion of buffer 108 for begin = (max (org-element-property :begin elt) (point-min)) 109 for end = (min (org-element-property :end elt) (point-max)) 110 for target = (buffer-substring begin end) 111 ;; Adjust table-cell to exclude final |. (Why is that there?) 112 ;; Note: We are not doing this is an embark transformer because we 113 ;; want to adjust the bounds too. 114 ;; TODO? If more adjustments like this become necessary, add a 115 ;; nice mechanism for doing them. 116 when (and (eq (car elt) 'table-cell) (string-suffix-p "|" target)) 117 do (setq target (string-trim (string-remove-suffix "|" target)) 118 end (1- end)) 119 collect `(,(intern (format "org-%s" (car elt))) ,target ,begin . ,end)))) 120 121 (if-let (((not (memq 'embark-org-target-element-context embark-target-finders))) 122 (tail (memq 'embark-target-active-region embark-target-finders))) 123 (push 'embark-org-target-element-context (cdr tail)) 124 (push 'embark-org-target-element-context embark-target-finders)) 125 126 ;;; Custom Org actions 127 128 (defvar org-export-with-toc) 129 130 (defun embark-org-copy-as-markdown (start end) 131 "Export the region from START to END to markdown and save on the `kill-ring'." 132 (interactive "r") 133 (require 'ox) 134 (kill-new 135 (let (org-export-with-toc) 136 (string-trim 137 (org-export-string-as (buffer-substring-no-properties start end) 'md t)))) 138 (deactivate-mark)) 139 140 (add-to-list 'embark-pre-action-hooks 141 '(embark-org-copy-as-markdown embark--mark-target)) 142 143 (keymap-set embark-region-map "M" #'embark-org-copy-as-markdown) ; good idea? 144 145 ;;; Tables 146 147 (dolist (motion '(org-table-move-cell-up org-table-move-cell-down 148 org-table-move-cell-left org-table-move-cell-right)) 149 (add-to-list 'embark-repeat-actions motion)) 150 151 (push 'embark--ignore-target 152 (alist-get 'org-table-edit-field embark-target-injection-hooks)) 153 154 (defvar-keymap embark-org-table-cell-map 155 :doc "Keymap for actions the current cells, column or row of an Org table." 156 :parent embark-general-map 157 ;; TODO: default action? 158 "<up>" #'org-table-move-cell-up 159 "<down>" #'org-table-move-cell-down 160 "<left>" #'org-table-move-cell-left 161 "<right>" #'org-table-move-cell-right 162 "=" #'org-table-eval-formula 163 "e" #'org-table-edit-field 164 "g" #'org-table-recalculate) 165 166 (defvar-keymap embark-org-table-map 167 :doc "Keymap for actions on entire Org table." 168 :parent embark-general-map 169 ;; TODO: default action? 170 "=" #'org-table-edit-formulas 171 "s" #'org-table-sort-lines 172 "t" #'org-table-transpose-table-at-point 173 "c" #'org-table-convert 174 "f" #'org-table-follow-field-mode 175 "y" #'org-table-paste-rectangle 176 "d" #'org-table-toggle-formula-debugger 177 "i" #'org-table-iterate 178 "e" #'org-table-export) 179 180 (push 'embark--ignore-target ; prompts for file name 181 (alist-get 'org-table-export embark-target-injection-hooks)) 182 183 (add-to-list 'embark-keymap-alist '(org-table . embark-org-table-map)) 184 185 (add-to-list 'embark-keymap-alist '(org-table-cell . embark-org-table-cell-map)) 186 187 ;;; Links 188 189 ;; The link support has a slightly complicated design in order to 190 ;; achieve the following goals: 191 192 ;; 1. RET should simply be org-open-at-point 193 194 ;; 2. When the link is to a file, URL, email address or elisp 195 ;; expression or command, we want to offer the user actions for 196 ;; that underlying type. 197 198 ;; 3. Even in those cases, we still want some actions to apply to the 199 ;; entire link including description: actions to copy the link as 200 ;; markdown, or just the link description or target. 201 202 ;; So the strategy is as follows (illustrated with file links): 203 204 ;; - The target will be just the file, without the description and 205 ;; also without the "file:" prefix nor the "::line-number or search" 206 ;; suffix. That way, file actions will correctly apply to it. 207 208 ;; - The type will not be 'file, but 'org-file-link that way we can 209 ;; register a keymap for 'org-file-link that inherits from both 210 ;; embark-org-link-map (with RET bound to org-open-at-point and a 211 ;; few other generic link actions) and embark-file-map. 212 213 ;; - The commands to copy the link at point in some format will be 214 ;; written as commands that act on the Org link at point. This way 215 ;; they are independently (plausibly) useful, and we circumvent the 216 ;; problem that the whole Org link is not actually the target (just 217 ;; the inner file is!). 218 219 ;; Alternative design I considered: separate each target into two, a 220 ;; whole link target which includes the description and brackets and 221 ;; what not; and an "inner target" which is just the file or URL or 222 ;; whatever. Cons of this approach: much target cycling is required! 223 ;; First of all, an unadorned embark-dwim definitely should be 224 ;; org-open-at-point, which means the whole link target would need 225 ;; priority. That means that any file, URL, etc. actions would require 226 ;; you to cycle first. This sounds very inconvenient, the above 227 ;; slightly more complex design allows both whole-link and inner 228 ;; target actions to work without cycling. 229 230 (autoload 'org-attach-dir "org-attach") 231 232 (defun embark-org--refine-link-type (_type target) 233 "Refine type of link TARGET if we have more specific actions available." 234 (when (string-match org-link-any-re target) 235 (let ((target (or (match-string-no-properties 2 target) 236 (match-string-no-properties 0 target)))) 237 (cond 238 ((string-prefix-p "http" target) 239 (cons 'org-url-link target)) 240 ((string-prefix-p "mailto:" target) 241 (cons 'org-email-link (string-remove-prefix "mailto:" target))) 242 ((string-prefix-p "file:" target) 243 (cons 'org-file-link 244 (replace-regexp-in-string 245 "::.*" "" (string-remove-prefix "file:" target)))) 246 ((string-prefix-p "attachment:" target) 247 (cons 'org-file-link 248 (expand-file-name 249 (replace-regexp-in-string 250 "::.*" "" (string-remove-prefix "attachment:" target)) 251 (org-attach-dir)))) 252 ((string-match-p "^[./]" target) 253 (cons 'org-file-link (abbreviate-file-name (expand-file-name target)))) 254 ((string-prefix-p "elisp:(" target) 255 (cons 'org-expression-link (string-remove-prefix "elisp:" target))) 256 ((string-prefix-p "elisp:" target) 257 (cons 'command (string-remove-prefix "elisp:" target))) 258 (t (cons 'org-link target)))))) 259 260 (add-to-list 'embark-transformer-alist 261 '(org-link . embark-org--refine-link-type)) 262 263 (defmacro embark-org-define-link-copier (name formula description) 264 "Define a command that copies the Org link at point according to FORMULA. 265 The command's name is formed by appending NAME to 266 embark-org-copy-link. The docstring includes the DESCRIPTION of 267 what part or in what format the link is copied." 268 `(defun ,(intern (format "embark-org-copy-link-%s" name)) () 269 ,(format "Copy to the kill-ring the Org link at point%s." description) 270 (interactive) 271 (when (org-in-regexp org-link-any-re) 272 (let* ((full (match-string-no-properties 0)) 273 (target (or (match-string-no-properties 2) 274 (match-string-no-properties 0))) 275 (description (match-string-no-properties 3)) 276 (kill ,formula)) 277 (ignore full target description) 278 (when kill 279 (message "Saved '%s'" kill) 280 (kill-new kill)))))) 281 282 (embark-org-define-link-copier in-full full " in full") 283 (embark-org-define-link-copier description description "'s description") 284 (embark-org-define-link-copier target target "'s target") 285 286 (defalias 'embark-org-copy-link-inner-target #'kill-new 287 "Copy inner part of the Org link at point's target. 288 For mailto and elisp links, the inner part is the portion of the 289 target after `mailto:' or `elisp:'. 290 291 For file links the inner part is the file name, without the 292 `file:' prefix and without `::' suffix (used for line numbers, 293 IDs or search terms). 294 295 For URLs the inner part is the whole target including the `http:' 296 or `https:' prefix. For any other type of link the inner part is 297 also the whole target.") 298 299 (defvar-keymap embark-org-link-copy-map 300 :doc "Keymap for different ways to copy Org links to the kill-ring. 301 302 You should bind w in this map to your most frequently used link 303 copying function. The default is for w to copy the \"inner 304 target\" (see `embark-org-copy-link-inner-target'); which is also 305 bound to i." 306 :parent nil 307 "w" #'embark-org-copy-link-inner-target 308 "f" #'embark-org-copy-link-in-full 309 "d" #'embark-org-copy-link-description 310 "t" #'embark-org-copy-link-target 311 "i" #'embark-org-copy-link-inner-target 312 "m" #'embark-org-copy-as-markdown) 313 314 (fset 'embark-org-link-copy-map embark-org-link-copy-map) 315 316 (defvar-keymap embark-org-link-map 317 :doc "Keymap for actions on Org links." 318 :parent embark-general-map 319 "RET" #'org-open-at-point 320 "'" #'org-insert-link 321 "w" #'embark-org-link-copy-map) 322 323 ;; The reason for this is left as an exercise to the reader. 324 ;; Solution: Na ryvfc gnetrg znl cebzcg gur hfre sbe fbzrguvat! 325 (cl-pushnew 'embark--ignore-target 326 (alist-get 'org-open-at-point embark-target-injection-hooks)) 327 (cl-pushnew 'embark--ignore-target 328 (alist-get 'org-insert-link embark-target-injection-hooks)) 329 330 (add-to-list 'embark-keymap-alist 331 '(org-link embark-org-link-map)) 332 (add-to-list 'embark-keymap-alist 333 '(org-url-link embark-org-link-map embark-url-map)) 334 (add-to-list 'embark-keymap-alist 335 '(org-email-link embark-org-link-map embark-email-map)) 336 (add-to-list 'embark-keymap-alist 337 '(org-file-link embark-org-link-map embark-file-map)) 338 (add-to-list 'embark-keymap-alist 339 '(org-expression-link embark-org-link-map embark-expression-map)) 340 341 ;;; Org headings 342 343 (defun embark-org--refine-heading (type target) 344 "Refine TYPE of heading TARGET in Org buffers." 345 (cons 346 (if (derived-mode-p 'org-mode) 'org-heading type) 347 target)) 348 349 (add-to-list 'embark-transformer-alist '(heading . embark-org--refine-heading)) 350 351 (defvar-keymap embark-org-heading-map 352 :doc "Keymap for actions on Org headings." 353 :parent embark-heading-map 354 "RET" #'org-todo 355 "t" #'org-todo 356 "," #'org-priority 357 ":" #'org-set-tags-command 358 "k" #'org-cut-subtree 359 "N" #'org-narrow-to-subtree 360 "l" #'org-metaleft 361 "r" #'org-metaright 362 "S" #'org-sort 363 "R" #'org-refile 364 "a" #'org-archive-subtree-default-with-confirmation 365 "h" #'org-insert-heading-respect-content 366 "H" #'org-insert-todo-heading-respect-content 367 "L" #'org-store-link) 368 369 (dolist (cmd '(org-todo org-metaright org-metaleft org-metaup org-metadown 370 org-shiftmetaleft org-shiftmetaright org-cycle org-shifttab)) 371 (cl-pushnew cmd embark-repeat-actions)) 372 373 (cl-pushnew 'embark--ignore-target 374 (alist-get 'org-set-tags-command embark-target-injection-hooks)) 375 376 (cl-pushnew '(org-heading . embark-org-heading-map) embark-keymap-alist) 377 378 ;;; Source blocks and babel calls 379 380 (defun embark-org-copy-block-contents () 381 "Save contents of source block at point to the `kill-ring'." 382 (interactive) 383 (when (org-in-src-block-p) 384 (let ((contents (nth 2 (org-src--contents-area (org-element-at-point))))) 385 (with-temp-buffer 386 (insert contents) 387 (org-do-remove-indentation) 388 (kill-new (buffer-substring (point-min) (point-max))))))) 389 390 (defvar-keymap embark-org-src-block-map 391 :doc "Keymap for actions on Org source blocks." 392 :parent embark-general-map 393 "RET" #'org-babel-execute-src-block 394 "SPC" #'org-babel-mark-block 395 "TAB" #'org-indent-block 396 "c" #'embark-org-copy-block-contents 397 "h" #'org-babel-check-src-block 398 "k" #'org-babel-remove-result-one-or-many 399 "p" #'org-babel-previous-src-block 400 "n" #'org-babel-next-src-block 401 "t" #'org-babel-tangle 402 "s" #'org-babel-switch-to-session 403 "l" #'org-babel-load-in-session 404 "'" #'org-edit-special 405 "/" #'org-babel-demarcate-block 406 "N" #'org-narrow-to-block) 407 408 (cl-defun embark-org--at-block-head (&rest rest &key run &allow-other-keys) 409 "Save excursion and RUN the action at the head of the current block. 410 Applies RUN to the REST of the arguments." 411 (save-excursion 412 (org-babel-goto-src-block-head) 413 (apply run rest))) 414 415 (cl-pushnew #'embark-org--at-block-head 416 (alist-get 'org-indent-block embark-around-action-hooks)) 417 418 (dolist (motion '(org-babel-next-src-block org-babel-previous-src-block)) 419 (add-to-list 'embark-repeat-actions motion)) 420 421 (add-to-list 'embark-keymap-alist '(org-src-block . embark-org-src-block-map)) 422 423 ;;; List items 424 425 (defvar-keymap embark-org-item-map 426 :doc "Keymap for actions on Org list items." 427 :parent embark-general-map 428 "RET" #'org-toggle-checkbox 429 "c" #'org-toggle-checkbox 430 "t" #'org-toggle-item 431 "n" #'org-next-item 432 "p" #'org-previous-item 433 "<left>" #'org-outdent-item 434 "<right>" #'org-indent-item 435 "<up>" #'org-move-item-up 436 "<down>" #'org-move-item-down 437 ">" #'org-indent-item-tree 438 "<" #'org-outdent-item-tree) 439 440 (dolist (cmd '(org-toggle-checkbox 441 org-toggle-item 442 org-next-item 443 org-previous-item 444 org-outdent-item 445 org-indent-item 446 org-move-item-up 447 org-move-item-down 448 org-indent-item-tree 449 org-outdent-item-tree)) 450 (add-to-list 'embark-repeat-actions cmd)) 451 452 (add-to-list 'embark-keymap-alist '(org-item . embark-org-item-map)) 453 454 ;;; Org plain lists 455 456 (defvar-keymap embark-org-plain-list-map 457 :doc "Keymap for actions on plain Org lists." 458 :parent embark-general-map 459 "RET" #'org-list-repair 460 "r" #'org-list-repair 461 "s" #'org-sort-list 462 "b" #'org-cycle-list-bullet 463 "t" #'org-list-make-subtree 464 "c" #'org-toggle-checkbox) 465 466 (add-to-list 'embark-repeat-actions 'org-cycle-list-bullet) 467 468 (add-to-list 'embark-keymap-alist '(org-plain-list . embark-org-plain-list-map)) 469 470 (cl-defun embark-org--toggle-checkboxes 471 (&rest rest &key run type &allow-other-keys) 472 "Around action hook for `org-toggle-checkbox'. 473 See `embark-around-action-hooks' for the keyword arguments RUN and TYPE. 474 REST are the remaining arguments." 475 (apply (if (eq type 'org-plain-list) #'embark--mark-target run) 476 :type type 477 rest)) 478 479 (cl-pushnew #'embark-org--toggle-checkboxes 480 (alist-get 'org-toggle-checkbox embark-around-action-hooks)) 481 482 ;;; "Encode" region using Org export in place 483 484 (defvar-keymap embark-org-export-in-place-map 485 :doc "Keymap for actions which replace the region by an exported version." 486 :parent embark-general-map 487 "m" #'org-md-convert-region-to-md 488 "h" #'org-html-convert-region-to-html 489 "a" #'org-ascii-convert-region-to-ascii 490 "l" #'org-latex-convert-region-to-latex) 491 492 (fset 'embark-org-export-in-place-map embark-org-export-in-place-map) 493 494 (keymap-set embark-encode-map "o" 'embark-org-export-in-place-map) 495 496 (provide 'embark-org) 497 ;;; embark-org.el ends here