awesome-emacs/nursery
1
0
Fork 0
mirror of https://github.com/chrisbarrett/nursery synced 2025-09-16 15:56:48 -05:00
Code Issues Packages Projects Releases Wiki Activity

Improve robustness of extraction w.r.t. transclusions

Browse Source
This commit is contained in:
Chris Barrett
2022-09-13 15:56:30 +12:00
parent b69d1c40d1
commit fedd7b8f29
1 changed files with 67 additions and 55 deletions
Download Patch File Download Diff File Expand all files Collapse all files

62
lisp/org-roam-rewrite.el
View File

@@ -35,6 +35,8 @@
(require 'org)
(require 'org-roam)
(require 'org-transclusion nil t)
(defgroup org-roam-rewrite nil
"Commands for rewriting org-roam nodes and their links."
:group 'productivity
@@ -210,9 +212,10 @@ LINK-DESC is the description to use for the updated links."
(t
(user-error "Rewrite aborted")))))
(defun org-roam-rewrite--apply-when-transclusions-enabled (fname &rest args)
(when (bound-and-true-p org-transclusion-mode)
(apply fname args)))
(defmacro org-roam-rewrite--when-transclusions (&rest body)
(declare (indent 0))
`(when (bound-and-true-p org-transclusion-mode)
,@body))
;;;###autoload
(defun org-roam-rewrite-inline (src-node dest-node)
@@ -237,13 +240,15 @@ DEST-NODE is the node that will be added to."
(content
(with-current-buffer src-buffer
(org-with-wide-buffer
(org-roam-rewrite--apply-when-transclusions-enabled 'org-transclusion-remove-all)
(org-roam-rewrite--when-transclusions
(org-transclusion-remove-all))
(goto-char (point-min))
(org-roam-end-of-meta-data t)
(buffer-substring (point) (point-max))))))
(find-file (org-roam-node-file dest-node))
(org-with-wide-buffer
(org-roam-rewrite--apply-when-transclusions-enabled 'org-transclusion-remove-all)
(org-roam-rewrite--when-transclusions
(org-transclusion-remove-all))
(goto-char (point-max))
(delete-blank-lines)
(insert "\n\n")
@@ -255,11 +260,14 @@ DEST-NODE is the node that will be added to."
(org-map-entries 'org-do-demote)
(goto-char (point-min))
(while (search-forward-regexp (rx bol "#+transclude:") nil t)
(org-roam-rewrite--apply-when-transclusions-enabled 'org-transclusion-add)
(org-roam-rewrite--apply-when-transclusions-enabled 'org-transclusion-promote-subtree))))
(org-roam-rewrite--when-transclusions
(org-transclusion-add))
(org-roam-rewrite--when-transclusions
(org-transclusion-promote-subtree)))))
(delete-file (org-roam-node-file src-node))
(save-buffer)
(org-roam-rewrite--apply-when-transclusions-enabled 'org-transclusion-add-all)
(org-roam-rewrite--when-transclusions
(org-transclusion-add-all))
(when (buffer-live-p src-buffer)
(kill-buffer src-buffer)))
@@ -271,9 +279,8 @@ DEST-NODE is the node that will be added to."
(org-back-to-heading-or-point-min t)
(when (bobp) (user-error "Already a top-level node"))
(org-id-get-create)
(when (buffer-modified-p)
(save-buffer)
(org-roam-db-update-file))
(org-roam-db-update-file)
(org-roam-node-at-point t)))
(defun org-roam-rewrite--new-filename-from-capture-template (node)
@@ -316,21 +323,23 @@ but it handles file titles, tags and transclusions better."
org-roam-directory)))
(list node dest)))
(cl-assert (not (zerop (org-roam-node-level node))))
(cl-assert (org-roam-node-level node) t)
(cl-assert (not (zerop (org-roam-node-level node))) t)
;; Ensure the node's buffer is open
(let ((file (org-roam-node-file node)))
(unless (find-buffer-visiting file)
(find-file-noselect file)))
(with-current-buffer (find-file-noselect (org-roam-node-file node))
(org-roam-rewrite--when-transclusions
(org-transclusion-remove-all))
(org-with-point-at (org-roam-node-marker node)
;; Use underlying org-mode machinery to go to the ID in the buffer. We can't
;; use org-roam-node-marker because updates aren't reliable.
(org-with-point-at (org-id-find (org-roam-node-id node) t)
(let ((tags (org-get-tags))
(save-silently t)
(dest-buf (find-file-noselect dest))
extraction-succeeded-p)
(unwind-protect
(atomic-change-group
;; Extract from source buffer
(org-roam-rewrite--apply-when-transclusions-enabled 'org-transclusion-remove-all t)
(org-cut-subtree)
(save-buffer)
(org-roam-db-update-file)
@@ -338,7 +347,9 @@ but it handles file titles, tags and transclusions better."
(insert (org-link-make-string (format "id:%s" (org-roam-node-id node))
(org-link-display-format (org-roam-node-title node))))
(newline))
(org-roam-rewrite--apply-when-transclusions-enabled 'org-transclusion-add-all t)
(org-roam-rewrite--when-transclusions
(org-transclusion-add-all))
;; Insert into dest buffer
(with-current-buffer dest-buf
(org-paste-subtree)
@@ -348,23 +359,24 @@ but it handles file titles, tags and transclusions better."
(when-let* ((tags (-difference (-union (org-roam-rewrite--file-tags) tags)
org-roam-rewrite-extract-excluded-tags)))
(org-roam-rewrite--set-file-tags tags)
(org-roam-rewrite--apply-when-transclusions-enabled 'org-transclusion-add-all)))
(org-roam-rewrite--when-transclusions
(org-transclusion-add-all)))
(save-buffer))
(setq extraction-succeeded-p t))
(unless extraction-succeeded-p
(message "Extraction failed")
(with-current-buffer dest-buf
(if extraction-succeeded-p
(save-buffer)
;; Extraction failed--clean up
(let ((kill-buffer-query-functions))
(set-buffer-modified-p nil)
(kill-buffer dest-buf)
(kill-buffer dest-buf))
(when (file-exists-p dest)
(delete-file dest))))))
(delete-file dest)))))
(save-buffer)
(with-current-buffer dest-buf
(run-hooks 'org-roam-node-capture-new-node-hook 'org-roam-rewrite-node-extracted-hook)))))
(run-hooks 'org-roam-node-capture-new-node-hook 'org-roam-rewrite-node-extracted-hook))))))
(provide 'org-roam-rewrite)