ndwarshuis
/
emacs-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

REF pull out the archive-context function from the logbook archiver

This commit is contained in:
Nathan Dwarshuis 2021-04-24 18:58:39 -04:00
parent c8cec3f27a
commit 936040e59a
1 changed files with 41 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
local/lib/org-x/org-x.el
View File

@ -1232,6 +1232,22 @@ ARG, ask for a range in minutes in place of the second date."
(cons new-clock it))) (cons new-clock it)))
it))))))) it)))))))
(defun org-x--headline-add-archive-context (afile apath acat atags headline)
"Add archive context properties to HEADLINE.
AFILE is the source file. APATH is the headline path in the
original buffer. ACAT is the category. ATAGS is a list of tags,
including those that are inherited."
(let ((atodo (org-ml-get-property :todo-keyword headline))
(atime (-> (substring (cdr org-time-stamp-formats) 1 -1)
(format-time-string))))
(->> (org-ml-clone-node headline)
(org-ml-headline-set-node-property "ARCHIVE_TIME" atime)
(org-ml-headline-set-node-property "ARCHIVE_FILE" afile)
(org-ml-headline-set-node-property "ARCHIVE_OLPATH" apath)
(org-ml-headline-set-node-property "ARCHIVE_CATEGORY" acat)
(org-ml-headline-set-node-property "ARCHIVE_TODO" atodo)
(org-ml-headline-set-node-property "ARCHIVE_ITAGS" atags))))
(defun org-x-refile-logbook () (defun org-x-refile-logbook ()
"Refile the current headline with it's logbook. "Refile the current headline with it's logbook.
The original target headline is left in place but without the The original target headline is left in place but without the
@ -1239,48 +1255,41 @@ logbook. Intended use is for habits and repeating tasks that
build up massive logbook entries that will make my org files huge build up massive logbook entries that will make my org files huge
and slow." and slow."
(interactive) (interactive)
(let ((acat (org-get-category)) (let* ((acat (org-get-category))
(atime (format-time-string (substring (cdr org-time-stamp-formats) 1 -1))) (afile (abbreviate-file-name
(afile (abbreviate-file-name (or (buffer-file-name (buffer-base-buffer))
(or (buffer-file-name (buffer-base-buffer)) (error "No file associated to buffer"))))
(error "No file associated to buffer")))) (apath (s-join "/" (org-get-outline-path)))
(apath (s-join "/" (org-get-outline-path))) (atags (->> (org-get-tags)
(atags (->> (org-get-tags) (--filter (get-text-property 0 'inherited it))
(--filter (get-text-property 0 'inherited it)) (s-join " ")))
(s-join " "))) (add-context (-partial #'org-x--headline-add-archive-context
(config (org-x-logbook-config))) afile apath acat atags))
;; TODO this is basically a function version of org-archive and could (target (format "%s_archive" afile)))
;; be refactored/reused as a separate function
(cl-flet (cl-flet
((archive ((archive
(atime afile _apath acat atodo atags target headline) (target headline)
(let* ((level-shift (-some-> (org-ml-get-property :level headline) (let* ((level-shift (-some-> (org-ml-get-property :level headline)
(1-) (1-)
(-))) (-)))
(headline* (headline*
(->> (org-ml-clone-node headline) (->> (add-context headline)
(org-ml-set-property :todo-keyword org-x-kw-done) ;; close the headline (assume it isn't already)
(org-ml-headline-map-planning* (org-ml-set-property :todo-keyword org-x-kw-done)
(let ((time (->> (float-time) (org-ml-headline-map-planning*
(org-ml-unixtime-to-time-long)))) (let ((time (org-ml-unixtime-to-time-long (float-time))))
(org-ml-planning-set-timestamp! :closed time it))) (org-ml-planning-set-timestamp! :closed time it)))
(org-ml-headline-set-node-property "ARCHIVE_TIME" atime) ;; shift it to the top level
(org-ml-headline-set-node-property "ARCHIVE_FILE" afile) (org-ml-shift-property :level level-shift)
(org-ml-headline-set-node-property "ARCHIVE_OLPATH" afile) (org-ml-match-map* '(:any * headline)
(org-ml-headline-set-node-property "ARCHIVE_CATEGORY" acat) (org-ml-shift-property :level level-shift it)))))
(org-ml-headline-set-node-property "ARCHIVE_TODO" atodo)
(org-ml-headline-set-node-property "ARCHIVE_ITAGS" atags)
(org-ml-shift-property :level level-shift)
(org-ml-match-map* '(:any * headline)
(org-ml-shift-property :level level-shift it)))))
;; TODO this currently does not refile under specific headlines ;; TODO this currently does not refile under specific headlines
(with-current-buffer (find-file-noselect target) (with-current-buffer (find-file-noselect target)
(org-ml-insert (point-max) headline*))))) (org-ml-insert (point-max) headline*)))))
(org-ml-update-this-subtree* (org-ml-update-this-subtree*
(let ((atodo (org-ml-get-property :todo-keyword it)) (progn
(target (format "%s_archive" afile))) (archive target it)
(archive atime afile apath acat atodo atags target it) (org-ml-headline-map-supercontents* (org-x-logbook-config)
(org-ml-headline-map-supercontents* config
(org-ml-supercontents-set-logbook nil it) (org-ml-supercontents-set-logbook nil it)
it)))))) it))))))