ADD tests for timestamp shifter

etc/conf.org

@@ -3999,7 +3999,7 @@ These are for mode-specific bindings that can/should be outside of the evil maps
             (local-set-key (kbd "C-c C-x c") 'org-x-clone-subtree-with-time-shift)
 
             ;; add time shifter
-            (local-set-key (kbd "C-c C-x t") 'org-x-time-shift)
+            (local-set-key (kbd "C-c C-x t") 'org-x-subtree-shift-timestamps)
 
             ;; add clock in/out functions for tomato mode
             (local-set-key (kbd "C-x C-c C-x C-i") 'org-tomato-user-hl-clock-in)

local/lib/org-x/org-x.el

@@ -743,6 +743,9 @@ latter codes in the list trump earlier ones."
         ()
         (-some->> (org-ml-parse-this-headline)
           (org-ml-headline-get-contents (org-x-logbook-config))
+          ;; wrap in a section here because the matcher needs a single node
+          ;; and not a list
+          (apply #'org-ml-build-section)
           (org-ml-match '(:first :any * (:and timestamp
                                               (:or (:type 'active)
                                                    (:type 'active-range)))))
@@ -795,7 +798,33 @@ function will simply return the point of the next headline."
 
 ;;; INTERACTIVE FUNCTIONS
 
-;; cloning
+;; timestamp shifting
+
+(defun org-x--read-shift-from-minibuffer (&optional default)
+  "Read a timestamp shift from the minibuffer.
+
+If DEFAULT is a string, process this instead of reading a string
+from the minubuffer.
+
+Valid shifts are like +/-(DIGIT)(UNIT) (eg like '+1w') similar to
+`org-clone-subtree-with-time-shift'. If invalid throw an error.
+Else return a list like (OFFSET UNIT) where OFFSET is the numeric
+value of the shift (negative goes back in time) and UNIT is the
+unit of the shift. These are later consumed by
+`org-ml-timestamp-shift'"
+  (let* ((out (or default (read-from-minibuffer "Date shift (e.g. +1w): ")))
+         (match (s-match "\\`[ \t]*\\([\\+\\-]?[0-9]+\\)\\([MHdwmy]\\)[ \t]*\\'" out)))
+    (if (not match) (error "Invalid shift: %s" out)
+      (-let* (((_ mag unit) match)
+              ((mult unit*) (pcase unit
+                              ("M" '(1 minute))
+                              ("H" '(1 hour))
+                              ("d" '(1 day))
+                              ("w" '(7 day))
+                              ("m" '(1 month))
+                              ("y" '(1 year))
+                              (_ (error "Unsupported time unit")))))
+        (list (* mult (string-to-number mag)) unit*)))))
 
 (defun org-x--reset-subtree (headline)
   "Reset HEADLINE node to incomplete state.
@@ -832,21 +861,43 @@ This includes unchecking all checkboxes, marking keywords as
                           (org-ml-to-string))))
       (reset (org-x-logbook-config) created-ts headline))))
 
-(defun org-x--headline-shift-timestamps (offset unit headline)
+(defun org-x--subtree-shift-timestamps (offset unit subtree)
-  (->> headline
+  "Return SUBTREE with timestamps shifted OFFSET UNITs.
-    (org-ml-match-map* '(:any * timestamp)
+In the case of task headlines, only scheduled/deadlined
-      (org-ml-timestamp-shift offset unit it))
+timestamps will be shifted. Otherwise only the first active
-    (org-ml-match-map* '(:any * planning)
+timestamp in the contents of the headline will be shifted."
-      (->> it
+  (cl-labels
-        (org-ml-map-property* :scheduled
+      ((shift-timestamps
-          (when it (org-ml-timestamp-shift offset unit it)))
+        (offset unit subtree)
-        (org-ml-map-property* :deadline
+        (if (org-ml-get-property :todo-keyword subtree)
-          (when it (org-ml-timestamp-shift offset unit it)))))))
+            (org-ml-headline-map-planning*
+              (->> it
+                (org-ml-map-property* :scheduled
+                  (when it (org-ml-timestamp-shift offset unit it)))
+                (org-ml-map-property* :deadline
+                  (when it (org-ml-timestamp-shift offset unit it))))
+              subtree)
+          (org-ml-headline-map-contents* (org-x-logbook-config)
+            ;; wrap in a section here because the matcher needs a single node
+            ;; and not a list
+            (->> (apply #'org-ml-build-section it)
+              (org-ml-match-map* '(:first :any * (:and timestamp
+                                                       (:or (:type 'active)
+                                                            (:type 'active-range))))
+                (org-ml-timestamp-shift offset unit it))
+              (org-ml-get-children))
+            subtree)))
+       (shift
+        (offset unit subtree)
+        (->> (shift-timestamps offset unit subtree)
+          (org-ml-headline-map-subheadlines*
+            (--map (shift offset unit it) it)))))
+    (shift offset unit subtree)))
 
 (defun org-x--subtree-repeat-shifted (n offset unit headline)
   "Return HEADLINE repeated and shifted by OFFSET UNITs N times."
   (->> (org-ml-clone-node-n n headline)
-    (--map-indexed (org-x--headline-shift-timestamps
+    (--map-indexed (org-x--subtree-shift-timestamps
                     (* offset (1+ it-index)) unit it))))
 
 (defun org-x-clone-subtree-with-time-shift (n)
@@ -855,7 +906,7 @@ N is the number of clones to produce."
   (interactive "nNumber of clones to produce: ")
   (-let* ((subtree (org-ml-parse-this-subtree))
           ((offset unit) (-> (org-entry-get nil org-x-prop-time-shift 'selective)
-                           (org-x-read-shift-from-minibuffer)))
+                           (org-x--read-shift-from-minibuffer)))
           (ins (->> (org-x--reset-subtree subtree)
                  (org-x--subtree-repeat-shifted n offset unit)
                  (-map #'org-ml-to-string)
@@ -868,7 +919,7 @@ N is the number of clones to produce."
 N is the number of clones to produce."
   (interactive "nNumber of clones to produce: ")
   (-let (((offset unit) (-> (org-entry-get nil org-x-prop-time-shift 'selective)
-                          (org-x-read-shift-from-minibuffer))))
+                          (org-x--read-shift-from-minibuffer))))
     (org-ml-update-this-subtree*
       (let ((new (->> (org-ml-headline-get-subheadlines it)
                    (-last-item)
@@ -877,6 +928,29 @@ N is the number of clones to produce."
           (append it (org-x--subtree-repeat-shifted n offset unit new))
           it)))))
 
+(defun org-x-subtree-shift-timestamps ()
+  "Shift all scheduled and deadlined timestamps in the current subtree."
+  (interactive)
+  (-let (((offset unit) (org-x--read-shift-from-minibuffer)))
+    (org-ml-update-this-subtree*
+      (org-x--subtree-shift-timestamps offset unit it))))
+      
+  ;; (save-excursion
+  ;;   (org-back-to-heading) ;; trigger error here if not at heading
+  ;;   (-let* ((end (save-excursion (org-end-of-subtree)))
+  ;;           ((mag unit) (org-x--read-shift-from-minibuffer))
+  ;;           (shift-ts-maybe
+  ;;            (lambda (type)
+  ;;              (let ((bound (save-excursion (outline-next-heading))))
+  ;;                (save-excursion
+  ;;                  (when (re-search-forward (org-re-timestamp type) bound t)
+  ;;                    (org-timestamp-change mag unit)))))))
+  ;;     (while (< (point) end)
+  ;;       (funcall shift-ts-maybe 'scheduled)
+  ;;       (funcall shift-ts-maybe 'deadline)
+  ;;       (outline-next-heading)))))
+
+
 ;; marking subtrees
 
 ;; put this in terms of org-ml
@@ -1097,42 +1171,6 @@ If BACK is t seek backward, else forward. Ignore blank lines."
   (interactive)
   (org-x-agenda--seek-heading))
 
-;; timestamp shifter
-
-(defun org-x-read-shift-from-minibuffer (&optional default)
-  (let* ((out (or default (read-from-minibuffer "Date shift (e.g. +1w): ")))
-         (match (s-match "\\`[ \t]*\\([\\+\\-]?[0-9]+\\)\\([MHdwmy]\\)[ \t]*\\'" out)))
-    (if (not match) (error "Invalid shift: %s" out)
-      (-let* (((_ mag unit) match)
-              ((mult unit*) (pcase unit
-                              ("M" '(1 minute))
-                              ("H" '(1 hour))
-                              ("d" '(1 day))
-                              ("w" '(7 day))
-                              ("m" '(1 month))
-                              ("y" '(1 year))
-                              (_ (error "Unsupported time unit")))))
-        (list (* mult (string-to-number mag)) unit*)))))
-
-;; TODO refactor in terms of org-ml to make cleaner/safer
-(defun org-x-time-shift ()
-  "Shift all scheduled and deadlined timestamps in the current subtree."
-  (interactive)
-  (save-excursion
-    (org-back-to-heading) ;; trigger error here if not at heading
-    (-let* ((end (save-excursion (org-end-of-subtree)))
-            ((mag unit) (org-x-read-shift-from-minibuffer))
-            (shift-ts-maybe
-             (lambda (type)
-               (let ((bound (save-excursion (outline-next-heading))))
-                 (save-excursion
-                   (when (re-search-forward (org-re-timestamp type) bound t)
-                     (org-timestamp-change mag unit)))))))
-      (while (< (point) end)
-        (funcall shift-ts-maybe 'scheduled)
-        (funcall shift-ts-maybe 'deadline)
-        (outline-next-heading)))))
-
 ;; agenda filtering
 
 ;; In order to implement the =hasprop= filter, the functions

local/lib/org-x/test/org-x-test-buffer-state.el

@@ -606,12 +606,130 @@ Forms are denoted like %(FORM)%."
        ((:start-time (2022 1 2 0 0) :range 86400 :offset 78 :filepath "fp"))))
 
 (org-x--test-buffer-strings "Timestamp shifter"
+    (let ((org-log-into-drawer "LOGGING")
+          (org-clock-into-drawer "CLOCKING"))
+      (->> (org-ml-parse-this-subtree)
+        (org-x--subtree-shift-timestamps 1 'day)
+        (org-ml-to-trimmed-string)))
+
+  ;; none of these should touch anything in the logbook or properties drawer
+
+  "task (scheduled)"
+  ("* TODO headline"
+   "SCHEDULED: <2020-01-01 Wed>"
+   ":PROPERTIES:"
+   ":CREATED:  [2019-01-01 Tue]"
+   ":END:"
+   ":LOGGING:"
+   "- State \"DONE\"       from \"TODO\"       [2021-04-18 Sun 13:09]"
+   ":END:"
+   ":CLOCKING:"
+   "CLOCK: [2021-04-18 Sun 13:02]--[2021-04-18 Sun 13:09] =>  0:07"
+   ":END:")
+  => (:result "* TODO headline"
+              "SCHEDULED: <2020-01-02 Thu>"
+              ":PROPERTIES:"
+              ":CREATED:  [2019-01-01 Tue]"
+              ":END:"
+              ":LOGGING:"
+              "- State \"DONE\"       from \"TODO\"       [2021-04-18 Sun 13:09]"
+              ":END:"
+              ":CLOCKING:"
+              "CLOCK: [2021-04-18 Sun 13:02]--[2021-04-18 Sun 13:09] =>  0:07"
+              ":END:")
+  
+  "task (deadlined)"
+  ("* TODO headline"
+   "DEADLINE: <2020-01-01 Wed>"
+   ":PROPERTIES:"
+   ":CREATED:  [2019-01-01 Tue]"
+   ":END:"
+   ":LOGGING:"
+   "- State \"DONE\"       from \"TODO\"       [2021-04-18 Sun 13:09]"
+   ":END:"
+   ":CLOCKING:"
+   "CLOCK: [2021-04-18 Sun 13:02]--[2021-04-18 Sun 13:09] =>  0:07"
+   ":END:")
+  => (:result "* TODO headline"
+              "DEADLINE: <2020-01-02 Thu>"
+              ":PROPERTIES:"
+              ":CREATED:  [2019-01-01 Tue]"
+              ":END:"
+              ":LOGGING:"
+              "- State \"DONE\"       from \"TODO\"       [2021-04-18 Sun 13:09]"
+              ":END:"
+              ":CLOCKING:"
+              "CLOCK: [2021-04-18 Sun 13:02]--[2021-04-18 Sun 13:09] =>  0:07"
+              ":END:")
+
+  "subtask"
+  ("* top"
+   "** TODO headline"
+   "DEADLINE: <2020-01-01 Wed>"
+   ":PROPERTIES:"
+   ":CREATED:  [2019-01-01 Tue]"
+   ":END:"
+   ":LOGGING:"
+   "- State \"DONE\"       from \"TODO\"       [2021-04-18 Sun 13:09]"
+   ":END:"
+   ":CLOCKING:"
+   "CLOCK: [2021-04-18 Sun 13:02]--[2021-04-18 Sun 13:09] =>  0:07"
+   ":END:")
+  => (:result "* top"
+              "** TODO headline"
+              "DEADLINE: <2020-01-02 Thu>"
+              ":PROPERTIES:"
+              ":CREATED:  [2019-01-01 Tue]"
+              ":END:"
+              ":LOGGING:"
+              "- State \"DONE\"       from \"TODO\"       [2021-04-18 Sun 13:09]"
+              ":END:"
+              ":CLOCKING:"
+              "CLOCK: [2021-04-18 Sun 13:02]--[2021-04-18 Sun 13:09] =>  0:07"
+              ":END:")
+
+  "non-task"
+  ("* headline"
+   ":PROPERTIES:"
+   ":CREATED:  [2019-01-01 Tue]"
+   ":END:"
+   ":LOGGING:"
+   "- State \"DONE\"       from \"TODO\"       [2021-04-18 Sun 13:09]"
+   ":END:"
+   ":CLOCKING:"
+   "CLOCK: [2021-04-18 Sun 13:02]--[2021-04-18 Sun 13:09] =>  0:07"
+   ":END:"
+   "something"
+   "something more"
+   "[2020-01-02 Thu]"
+   "<2020-01-01 Wed>"
+   "<2020-01-01 Wed>")
+  => (:result "* headline"
+              ":PROPERTIES:"
+              ":CREATED:  [2019-01-01 Tue]"
+              ":END:"
+              ":LOGGING:"
+              "- State \"DONE\"       from \"TODO\"       [2021-04-18 Sun 13:09]"
+              ":END:"
+              ":CLOCKING:"
+              "CLOCK: [2021-04-18 Sun 13:02]--[2021-04-18 Sun 13:09] =>  0:07"
+              ":END:"
+              "something"
+              "something more"
+              "[2020-01-02 Thu]"
+              "<2020-01-02 Thu>"
+              "<2020-01-01 Wed>")
+
+  )
+
+
+(org-x--test-buffer-strings "Timestamp cloner"
     (->> (org-ml-parse-this-subtree)
       (org-x--subtree-repeat-shifted 3 1 'day)
       (-map #'org-ml-to-string)
       (s-join ""))
 
-  "headline"
+  "task"
   ("* TODO headline"
    "SCHEDULED: <2020-01-01 Wed>")
   => (:result "* TODO headline"
@@ -622,7 +740,7 @@ Forms are denoted like %(FORM)%."
               "SCHEDULED: <2020-01-04 Sat>"
               "")
 
-  "subtree"
+  "project"
   ("* TODO headline"
    "SCHEDULED: <2020-01-01 Wed>"
    "** TODO headline"