ADD tests for timestamp shifter

This commit is contained in:
Nathan Dwarshuis 2021-04-18 21:35:29 -04:00
parent 9766604a83
commit 7c595ddb91
3 changed files with 209 additions and 53 deletions

View File

@ -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) (local-set-key (kbd "C-c C-x c") 'org-x-clone-subtree-with-time-shift)
;; add time shifter ;; 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 ;; 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-set-key (kbd "C-x C-c C-x C-i") 'org-tomato-user-hl-clock-in)

View File

@ -743,6 +743,9 @@ latter codes in the list trump earlier ones."
() ()
(-some->> (org-ml-parse-this-headline) (-some->> (org-ml-parse-this-headline)
(org-ml-headline-get-contents (org-x-logbook-config)) (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 (org-ml-match '(:first :any * (:and timestamp
(:or (:type 'active) (:or (:type 'active)
(:type 'active-range))))) (:type 'active-range)))))
@ -795,7 +798,33 @@ function will simply return the point of the next headline."
;;; INTERACTIVE FUNCTIONS ;;; 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) (defun org-x--reset-subtree (headline)
"Reset HEADLINE node to incomplete state. "Reset HEADLINE node to incomplete state.
@ -832,21 +861,43 @@ This includes unchecking all checkboxes, marking keywords as
(org-ml-to-string)))) (org-ml-to-string))))
(reset (org-x-logbook-config) created-ts headline)))) (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) (defun org-x--subtree-repeat-shifted (n offset unit headline)
"Return HEADLINE repeated and shifted by OFFSET UNITs N times." "Return HEADLINE repeated and shifted by OFFSET UNITs N times."
(->> (org-ml-clone-node-n n headline) (->> (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)))) (* offset (1+ it-index)) unit it))))
(defun org-x-clone-subtree-with-time-shift (n) (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: ") (interactive "nNumber of clones to produce: ")
(-let* ((subtree (org-ml-parse-this-subtree)) (-let* ((subtree (org-ml-parse-this-subtree))
((offset unit) (-> (org-entry-get nil org-x-prop-time-shift 'selective) ((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) (ins (->> (org-x--reset-subtree subtree)
(org-x--subtree-repeat-shifted n offset unit) (org-x--subtree-repeat-shifted n offset unit)
(-map #'org-ml-to-string) (-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." N is the number of clones to produce."
(interactive "nNumber of clones to produce: ") (interactive "nNumber of clones to produce: ")
(-let (((offset unit) (-> (org-entry-get nil org-x-prop-time-shift 'selective) (-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* (org-ml-update-this-subtree*
(let ((new (->> (org-ml-headline-get-subheadlines it) (let ((new (->> (org-ml-headline-get-subheadlines it)
(-last-item) (-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)) (append it (org-x--subtree-repeat-shifted n offset unit new))
it))))) 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 ;; marking subtrees
;; put this in terms of org-ml ;; put this in terms of org-ml
@ -1097,42 +1171,6 @@ If BACK is t seek backward, else forward. Ignore blank lines."
(interactive) (interactive)
(org-x-agenda--seek-heading)) (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 ;; agenda filtering
;; In order to implement the =hasprop= filter, the functions ;; In order to implement the =hasprop= filter, the functions

View File

@ -606,12 +606,130 @@ Forms are denoted like %(FORM)%."
((:start-time (2022 1 2 0 0) :range 86400 :offset 78 :filepath "fp")))) ((:start-time (2022 1 2 0 0) :range 86400 :offset 78 :filepath "fp"))))
(org-x--test-buffer-strings "Timestamp shifter" (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-ml-parse-this-subtree)
(org-x--subtree-repeat-shifted 3 1 'day) (org-x--subtree-repeat-shifted 3 1 'day)
(-map #'org-ml-to-string) (-map #'org-ml-to-string)
(s-join "")) (s-join ""))
"headline" "task"
("* TODO headline" ("* TODO headline"
"SCHEDULED: <2020-01-01 Wed>") "SCHEDULED: <2020-01-01 Wed>")
=> (:result "* TODO headline" => (:result "* TODO headline"
@ -622,7 +740,7 @@ Forms are denoted like %(FORM)%."
"SCHEDULED: <2020-01-04 Sat>" "SCHEDULED: <2020-01-04 Sat>"
"") "")
"subtree" "project"
("* TODO headline" ("* TODO headline"
"SCHEDULED: <2020-01-01 Wed>" "SCHEDULED: <2020-01-01 Wed>"
"** TODO headline" "** TODO headline"