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

REF simplify getting time shifts from minibuffer

This commit is contained in:
Nathan Dwarshuis 2021-04-18 19:11:09 -04:00
parent cf2b63e276
commit 6427fe55b6
1 changed files with 47 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -827,83 +827,51 @@ This includes unchecking all checkboxes, marking keywords as
(org-ml-match-map* '(:any * headline)
(reset config created-ts it))))))
(defun org-x--headline-repeat-shifted (n shift headline)
"Return HEADLINE repeated and shifted N times.
SHIFT is a string specifier denoting the amount to shift, eg
\"+2d\"."
(defun org-x--headline-repeat-shifted (n offset unit headline)
"Return HEADLINE repeated and shifted by OFFSET UNITs N times."
(cl-flet
((convert-shift
(shift)
(-let* (((n unit)
(or (-some->>
shift
(s-match "\\(\\([-+]?[0-9]+\\)\\([ymwd]\\)\\)")
(cddr))
(error "Invalid shift specified: %s" shift)))
((unit mult)
(cl-case (intern unit)
(y '(year 1))
(m '(month 1))
(w '(day 7))
(d '(day 1))
(t (error "This shouldn't happen: %s" unit))))
(n (* mult (string-to-number n))))
(list n unit)))
(shift-timestamps
(T unit mult headline)
(let ((T* (* T mult)))
((shift-timestamps
(offset unit mult headline)
(let ((offset* (* offset mult)))
(->> headline
(org-ml-match-map* '(:any * timestamp)
(org-ml-timestamp-shift T* unit it))
(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 T* unit it)))
(when it (org-ml-timestamp-shift offset* unit it)))
(org-ml-map-property* :deadline
(when it (org-ml-timestamp-shift T* unit it)))))))))
(when it (org-ml-timestamp-shift offset* unit it)))))))))
(let ((headlines (org-ml-clone-node-n n headline)))
(if (equal "" shift) headlines
(-let (((T unit) (convert-shift shift)))
(--map-indexed (shift-timestamps T unit (1+ it-index) it) headlines))))))
(--map-indexed (shift-timestamps offset unit (1+ it-index) it) headlines))))
(defun org-x-clone-subtree-with-time-shift (n)
"Like `org-clone-subtree-with-time-shift' except reset items and todos.
N is the number of clones to produce."
(interactive "nNumber of clones to produce: ")
(let* ((st (org-ml-parse-this-subtree))
(shift
(or (org-entry-get nil org-x-prop-time-shift 'selective)
(read-from-minibuffer
"Date shift per clone (e.g. +1w, empty to copy unchanged): ")))
(ins (->> (org-x--reset-headline st)
(org-x--headline-repeat-shifted n shift)
(-map #'org-ml-to-string)
(s-join "")))
(end (org-ml-get-property :end st)))
(-let* ((st (org-ml-parse-this-subtree))
((offset unit) (-> (org-entry-get nil org-x-prop-time-shift 'selective)
(org-x-read-shift-from-minibuffer)))
(ins (->> (org-x--reset-headline st)
(org-x--headline-repeat-shifted n offset unit)
(-map #'org-ml-to-string)
(s-join "")))
(end (org-ml-get-property :end st)))
(org-ml-insert end ins)))
(defun org-x-clone-subtree-with-time-shift-toplevel (n)
"Like `org-clone-subtree-with-time-shift' except reset items and todos.
N is the number of clones to produce."
(interactive "nNumber of clones to produce: ")
(cl-flet
((get-shift
(subtree)
(or
(org-ml-headline-get-node-property org-x-prop-time-shift subtree)
(read-from-minibuffer
"Shift per clone (e.g. +1w, empty to copy unchanged): "))))
(-let (((offset unit) (-> (org-entry-get nil org-x-prop-time-shift 'selective)
(org-x-read-shift-from-minibuffer))))
(org-ml-update-this-subtree*
(let ((shift (get-shift it))
(new (->> (org-ml-headline-get-subheadlines it)
(-last-item)
(org-x--reset-headline))))
(let ((new (->> (org-ml-headline-get-subheadlines it)
(-last-item)
(org-x--reset-headline))))
(org-ml-map-children*
(append it (org-x--headline-repeat-shifted n shift new))
it)))
(let ((post (org-ml-parse-this-subtree)))
(org-ml-match-do '(section property-drawer) (lambda (it) (org-ml-fold it)) post)
(org-ml-match-do '(headline) (lambda (it) (org-ml-fold it)) post))))
(append it (org-x--headline-repeat-shifted n offset unit new))
it)))))
;; marking subtrees
@ -1127,34 +1095,35 @@ If BACK is t seek backward, else forward. Ignore blank lines."
;; 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)))
(shift
(-->
(read-from-minibuffer "Date shift (e.g. +1w): ")
(s-match "\\`[ \t]*\\([\\+\\-]?[0-9]+\\)\\([MHdwmy]\\)[ \t]*\\'" it)
(if (not it) (error "Invalid shift: %s" it) it)))
(mag (string-to-number (nth 1 shift)))
(unit
(pcase (nth 2 shift)
("M" 'minute)
("H" (setq mag (* mag 60)) 'minute)
("d" 'day)
("w" (setq mag (* mag 7)) 'day)
("m" 'month)
("y" 'year)
(_ (error "Unsupported time unit"))))
(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)))))))
(-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)