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

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

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