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) (org-ml-match-map* '(:any * headline)
(reset config created-ts it)))))) (reset config created-ts it))))))
(defun org-x--headline-repeat-shifted (n shift headline) (defun org-x--headline-repeat-shifted (n offset unit headline)
"Return HEADLINE repeated and shifted N times. "Return HEADLINE repeated and shifted by OFFSET UNITs N times."
SHIFT is a string specifier denoting the amount to shift, eg
\"+2d\"."
(cl-flet (cl-flet
((convert-shift ((shift-timestamps
(shift) (offset unit mult headline)
(-let* (((n unit) (let ((offset* (* offset mult)))
(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)))
(->> headline (->> headline
(org-ml-match-map* '(:any * timestamp) (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) (org-ml-match-map* '(:any * planning)
(->> it (->> it
(org-ml-map-property* :scheduled (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 (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))) (let ((headlines (org-ml-clone-node-n n headline)))
(if (equal "" shift) headlines (--map-indexed (shift-timestamps offset unit (1+ it-index) it) headlines))))
(-let (((T unit) (convert-shift shift)))
(--map-indexed (shift-timestamps T unit (1+ it-index) it) headlines))))))
(defun org-x-clone-subtree-with-time-shift (n) (defun org-x-clone-subtree-with-time-shift (n)
"Like `org-clone-subtree-with-time-shift' except reset items and todos. "Like `org-clone-subtree-with-time-shift' except reset items and todos.
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* ((st (org-ml-parse-this-subtree)) (-let* ((st (org-ml-parse-this-subtree))
(shift ((offset unit) (-> (org-entry-get nil org-x-prop-time-shift 'selective)
(or (org-entry-get nil org-x-prop-time-shift 'selective) (org-x-read-shift-from-minibuffer)))
(read-from-minibuffer (ins (->> (org-x--reset-headline st)
"Date shift per clone (e.g. +1w, empty to copy unchanged): "))) (org-x--headline-repeat-shifted n offset unit)
(ins (->> (org-x--reset-headline st) (-map #'org-ml-to-string)
(org-x--headline-repeat-shifted n shift) (s-join "")))
(-map #'org-ml-to-string) (end (org-ml-get-property :end st)))
(s-join "")))
(end (org-ml-get-property :end st)))
(org-ml-insert end ins))) (org-ml-insert end ins)))
(defun org-x-clone-subtree-with-time-shift-toplevel (n) (defun org-x-clone-subtree-with-time-shift-toplevel (n)
"Like `org-clone-subtree-with-time-shift' except reset items and todos. "Like `org-clone-subtree-with-time-shift' except reset items and todos.
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: ")
(cl-flet (-let (((offset unit) (-> (org-entry-get nil org-x-prop-time-shift 'selective)
((get-shift (org-x-read-shift-from-minibuffer))))
(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): "))))
(org-ml-update-this-subtree* (org-ml-update-this-subtree*
(let ((shift (get-shift it)) (let ((new (->> (org-ml-headline-get-subheadlines it)
(new (->> (org-ml-headline-get-subheadlines it) (-last-item)
(-last-item) (org-x--reset-headline))))
(org-x--reset-headline))))
(org-ml-map-children* (org-ml-map-children*
(append it (org-x--headline-repeat-shifted n shift new)) (append it (org-x--headline-repeat-shifted n offset unit new))
it))) 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))))
;; marking subtrees ;; marking subtrees
@ -1127,34 +1095,35 @@ If BACK is t seek backward, else forward. Ignore blank lines."
;; timestamp shifter ;; 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 ;; TODO refactor in terms of org-ml to make cleaner/safer
(defun org-x-time-shift () (defun org-x-time-shift ()
"Shift all scheduled and deadlined timestamps in the current subtree." "Shift all scheduled and deadlined timestamps in the current subtree."
(interactive) (interactive)
(save-excursion (save-excursion
(org-back-to-heading) ;; trigger error here if not at heading (org-back-to-heading) ;; trigger error here if not at heading
(let* ((end (save-excursion (org-end-of-subtree))) (-let* ((end (save-excursion (org-end-of-subtree)))
(shift ((mag unit) (org-x-read-shift-from-minibuffer))
(--> (shift-ts-maybe
(read-from-minibuffer "Date shift (e.g. +1w): ") (lambda (type)
(s-match "\\`[ \t]*\\([\\+\\-]?[0-9]+\\)\\([MHdwmy]\\)[ \t]*\\'" it) (let ((bound (save-excursion (outline-next-heading))))
(if (not it) (error "Invalid shift: %s" it) it))) (save-excursion
(mag (string-to-number (nth 1 shift))) (when (re-search-forward (org-re-timestamp type) bound t)
(unit (org-timestamp-change mag 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)))))))
(while (< (point) end) (while (< (point) end)
(funcall shift-ts-maybe 'scheduled) (funcall shift-ts-maybe 'scheduled)
(funcall shift-ts-maybe 'deadline) (funcall shift-ts-maybe 'deadline)