ADD tests for timestamp shifter
This commit is contained in:
parent
9766604a83
commit
7c595ddb91
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(->> headline
|
||||
(org-ml-match-map* '(:any * timestamp)
|
||||
(org-ml-timestamp-shift offset unit it))
|
||||
(org-ml-match-map* '(:any * 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)))))))
|
||||
(defun org-x--subtree-shift-timestamps (offset unit subtree)
|
||||
"Return SUBTREE with timestamps shifted OFFSET UNITs.
|
||||
In the case of task headlines, only scheduled/deadlined
|
||||
timestamps will be shifted. Otherwise only the first active
|
||||
timestamp in the contents of the headline will be shifted."
|
||||
(cl-labels
|
||||
((shift-timestamps
|
||||
(offset unit subtree)
|
||||
(if (org-ml-get-property :todo-keyword subtree)
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Reference in New Issue