ADD function to store links directly in metablox buffer

This commit is contained in:
Nathan Dwarshuis 2021-12-12 18:37:03 -05:00
parent 27a359a01f
commit 55593c3520
2 changed files with 77 additions and 1 deletions

View File

@ -2545,7 +2545,7 @@ NOTE: Capitalized entries store a link to the capture along with writing to the
"#+END_QUOTE") "#+END_QUOTE")
:immediate-finish t) :immediate-finish t)
("M" "metablock" entry (file+olp+datetree "~/Org/metablocks.org") ("M" "metablock" entry (file+olp+datetree ,org-x-metablox-file)
,(concat "* %^{Metablock Title}\n" ,(concat "* %^{Metablock Title}\n"
"%^t\n" "%^t\n"
"%^{Effort}p" "%^{Effort}p"

View File

@ -235,6 +235,10 @@
org-x-iterator-active-future-offset org-x-iterator-active-future-offset
"Periodicals must have at least one heading this far in the future to be active.") "Periodicals must have at least one heading this far in the future to be active.")
(defconst org-x-metablox-file
(f-join org-directory "metablox.org")
"The file to which metablocks will be written.")
;;; INTERNAL CONSTANTS ;;; INTERNAL CONSTANTS
;; TODO ;unscheduled should trump all ;; TODO ;unscheduled should trump all
@ -305,6 +309,24 @@ the current time."
(org-ml-to-string)))) (org-ml-to-string))))
(org-ml-headline-set-node-property org-x-prop-created ts headline))) (org-ml-headline-set-node-property org-x-prop-created ts headline)))
(defmacro org-x-with-file (path &rest body)
"Open PATH and execute BODY."
(declare (indent 1))
`(with-current-buffer (find-file-noselect ,path)
,@body))
(defun org-x-parse-file-subtrees (path which)
"Return a list of headlines from file at PATH.
WHICH is passed to the one argument of `org-ml-parse-subtrees'."
(org-x-with-file path
(org-ml-parse-subtrees which)))
(defun org-x-parse-file-headlines (path which)
"Return a list of headlines from file at PATH.
WHICH is passed to the one argument of `org-ml-parse-headlines'."
(org-x-with-file path
(org-ml-parse-headlines which)))
;;; STATEFUL BUFFER HEADLINE FUNCTIONS ;;; STATEFUL BUFFER HEADLINE FUNCTIONS
;; All of these functions operate on the current headline ;; All of these functions operate on the current headline
@ -1233,6 +1255,60 @@ ARG and INTERACTIVE are passed to `org-store-link'."
(org-id-store-link) (org-id-store-link)
(org-store-link arg interactive)) (org-store-link arg interactive))
;; metablox
(defun org-x-metablock-get-timestamp (node)
"Return the first timestamp of NODE or nil if not found."
(car (org-ml-match '(:first section paragraph timestamp) node)))
(defun org-x-get-future-metablox ()
"Return a list of headline nodes representing metablocks in the future."
(cl-flet
((is-future
(node)
(-some->> (org-x-metablock-get-timestamp node)
(org-ml-timestamp-get-start-time)
(org-ml-time-to-unixtime)
(< (float-time)))))
(->> (org-x-parse-file-headlines org-x-metablox-file 'all)
(--filter (null (org-ml-headline-get-subheadlines it)))
(-filter #'is-future)
(-map #'org-ml-remove-parents))))
;; TODO mark lines in the completion buffer that already have a link with the
;; ID we are inserting
(defun org-x-id-store-link-metablock ()
"Make and ID for the current headline and store it in the org link ring.
ARG and INTERACTIVE are passed to `org-store-link'."
(interactive)
(cl-flet
((to-menu-line
(node)
(let ((ts (->> (org-x-metablock-get-timestamp node)
(org-ml-get-property :raw-value)))
(title (org-ml-get-property :raw-value node)))
(format "%s | %s" ts title))))
(-if-let (path (org-id-store-link))
(-if-let (desc (-some->> (org-ml-parse-this-headline)
(org-ml-get-property :raw-value)))
(-if-let (hls (org-x-get-future-metablox))
(let* ((lines (-map #'to-menu-line hls))
(col (-zip-pair lines hls))
(sel (completing-read "Metablock: " col nil t))
(target (alist-get sel col nil nil #'equal))
(link (org-ml-build-link path desc))
;; ASSUME there will be one paragraph at the end holding
;; the timestamp
(para (car (org-ml-match '(:last section paragraph) target))))
(org-x-with-file org-x-metablox-file
(org-ml~update* nil
(org-ml-map-children* (-snoc it link) it)
para))
(message "Successfully added '%s' to block '%s'" desc sel))
(message "No metablocks available"))
(message "Could not get link description (not on headline?)"))
(message "Could not get link to store"))))
;; meeting agenda ;; meeting agenda
(defun org-x--get-meetings-from-buffer () (defun org-x--get-meetings-from-buffer ()