From 936040e59a2400be7a36328032c6d447a84acabf Mon Sep 17 00:00:00 2001
From: ndwarshuis <ndwar@yavin4.ch>
Date: Sat, 24 Apr 2021 18:58:39 -0400
Subject: [PATCH] REF pull out the archive-context function from the logbook
 archiver

---
 local/lib/org-x/org-x.el | 73 ++++++++++++++++++++++------------------
 1 file changed, 41 insertions(+), 32 deletions(-)

diff --git a/local/lib/org-x/org-x.el b/local/lib/org-x/org-x.el
index 5cf13c4..72af87f 100644
--- a/local/lib/org-x/org-x.el
+++ b/local/lib/org-x/org-x.el
@@ -1232,6 +1232,22 @@ ARG, ask for a range in minutes in place of the second date."
                   (cons new-clock 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 ()
   "Refile the current headline with it's logbook.
 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
 and slow."
   (interactive)
-  (let ((acat (org-get-category))
-        (atime (format-time-string (substring (cdr org-time-stamp-formats) 1 -1)))
-        (afile (abbreviate-file-name
-                (or (buffer-file-name (buffer-base-buffer))
-                    (error "No file associated to buffer"))))
-        (apath (s-join "/" (org-get-outline-path)))
-        (atags (->> (org-get-tags)
-                    (--filter (get-text-property 0 'inherited it))
-                    (s-join " ")))
-        (config (org-x-logbook-config)))
-    ;; TODO this is basically a function version of org-archive and could
-    ;; be refactored/reused as a separate function
+  (let* ((acat (org-get-category))
+         (afile (abbreviate-file-name
+                 (or (buffer-file-name (buffer-base-buffer))
+                     (error "No file associated to buffer"))))
+         (apath (s-join "/" (org-get-outline-path)))
+         (atags (->> (org-get-tags)
+                  (--filter (get-text-property 0 'inherited it))
+                  (s-join " ")))
+         (add-context (-partial #'org-x--headline-add-archive-context
+                                afile apath acat atags))
+         (target (format "%s_archive" afile)))
     (cl-flet
         ((archive
-          (atime afile _apath acat atodo atags target headline)
+          (target headline)
           (let* ((level-shift (-some-> (org-ml-get-property :level headline)
                                 (1-)
                                 (-)))
                  (headline*
-                  (->> (org-ml-clone-node headline)
-                       (org-ml-set-property :todo-keyword org-x-kw-done)
-                       (org-ml-headline-map-planning*
-                         (let ((time (->> (float-time)
-                                          (org-ml-unixtime-to-time-long))))
-                           (org-ml-planning-set-timestamp! :closed time it)))
-                       (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" afile)
-                       (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)
-                       (org-ml-shift-property :level level-shift)
-                       (org-ml-match-map* '(:any * headline)
-                         (org-ml-shift-property :level level-shift it)))))
+                  (->> (add-context headline)
+                    ;; close the headline (assume it isn't already)
+                    (org-ml-set-property :todo-keyword org-x-kw-done)
+                    (org-ml-headline-map-planning*
+                      (let ((time (org-ml-unixtime-to-time-long (float-time))))
+                        (org-ml-planning-set-timestamp! :closed time it)))
+                    ;; shift it to the top level
+                    (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
             (with-current-buffer (find-file-noselect target)
               (org-ml-insert (point-max) headline*)))))
       (org-ml-update-this-subtree*
-        (let ((atodo (org-ml-get-property :todo-keyword it))
-              (target (format "%s_archive" afile)))
-          (archive atime afile apath acat atodo atags target it)
-          (org-ml-headline-map-supercontents* config
+        (progn
+          (archive target it)
+          (org-ml-headline-map-supercontents* (org-x-logbook-config)
             (org-ml-supercontents-set-logbook nil it)
             it))))))