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

ADD quarterly plan setter

This commit is contained in:
Nathan Dwarshuis 2021-12-30 00:15:00 -05:00
parent 72b702a869
commit b55fc844d3
1 changed files with 49 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1232,22 +1232,57 @@ Assumes point is on a valid headline or org mode file."
(org-id-get-create))))) (org-id-get-create)))))
(org-x-add-goal-link target-id title)))))) (org-x-add-goal-link target-id title))))))
(defun org-x-qt-headline-get-year (headline)
(let ((rt (org-ml-get-property :raw-value headline)))
(if (s-matches-p "[0-9]\\{4\\}" rt) (string-to-number rt)
(error "Invalid year headline in quarterly plan: %s" rt))))
(defun org-x-qt-headline-get-quarter (headline)
(let ((rt (org-ml-get-property :raw-value headline)))
(-if-let ((_ qt) (s-match "Q\\([0-9]\\)" rt)) (string-to-number qt)
(error "Invalid quarter headline in quarterly plan: %s" rt))))
(defun org-x-qt-headline-find-year (year headlines)
(--find (= year (org-x-qt-headline-get-year it)) headlines))
(defun org-x-qt-headline-find-quarter (quarter headlines)
(--find (= quarter (org-x-qt-headline-get-quarter it)) headlines))
(defun org-x-get-quarterly-plan (quarter year) (defun org-x-get-quarterly-plan (quarter year)
(unless (member quarter '(1 2 3 4)) (unless (member quarter '(1 2 3 4))
(error "Quarter must be an integer of 1, 2, 3 or 4")) (error "Quarter must be an integer of 1, 2, 3 or 4"))
(cl-flet (org-x-with-file (org-x-get-quarterly-plan-file)
((is-in-this-quarter (->> (org-ml-parse-subtrees 'all)
(quarter year headline) (--find (= year (org-x-qt-headline-get-year it)))
(-when-let (hl-ts (-some->> (org-ml-headline-get-planning headline) (org-ml-headline-get-subheadlines)
(org-ml-get-property :scheduled))) (--find (= quarter (org-x-qt-headline-get-quarter it)))
(let ((hl-qt (1+ (/ (1- (org-ml-get-property :month-start hl-ts)) 3))) (org-ml-get-children))))
(hl-yr (org-ml-get-property :year-start hl-ts)))
(and (= hl-yr year) (= hl-qt quarter)))))) (defun org-x-set-quarterly-plan (quarter year children)
(unless (member quarter '(1 2 3 4))
(error "Quarter must be an integer of 1, 2, 3 or 4"))
(cl-flet*
((build-qt-headline
(quarter children)
(apply #'org-ml-build-headline
:title (list (format "Q%s" quarter))
:level 2
children))
(build-yr-headline
(quarter year children)
(org-ml-build-headline! :title-text (number-to-string year)
(build-qt-headline quarter children))))
(org-x-with-file (org-x-get-quarterly-plan-file) (org-x-with-file (org-x-get-quarterly-plan-file)
(->> (org-ml-parse-subtrees 'all) (let ((sts (org-ml-parse-subtrees 'all)))
;; ASSUME all quarterly plans are level 2 headlines (-if-let (st-yr (org-x-qt-headline-find-year year sts))
(-mapcat #'org-ml-headline-get-subheadlines) (-if-let (st-qt (->> (org-ml-headline-get-subheadlines st-yr)
(--find (is-in-this-quarter quarter year it)))))) (org-x-qt-headline-find-quarter quarter)))
(org-ml-update* (org-ml-set-children children it) st-qt)
(org-ml-update*
(-snoc it (build-qt-headline quarter children))
st-yr))
(let ((end (1+ (org-ml-get-property :end (-last-item sts)))))
(org-ml-insert end (build-yr-headline quarter year children))))))))
(defun org-x-get-current-quarterly-plan () (defun org-x-get-current-quarterly-plan ()
(-let* (((_ _ _ _ month year) (decode-time (current-time))) (-let* (((_ _ _ _ month year) (decode-time (current-time)))
@ -1267,8 +1302,8 @@ Assumes point is on a valid headline or org mode file."
(defun org-x-qt-plan-check-categories (cats) (defun org-x-qt-plan-check-categories (cats)
(equal (-sort #'string< cats) org-x-life-categories)) (equal (-sort #'string< cats) org-x-life-categories))
(defun org-x-qt-plan-get-categories (headline) (defun org-x-qt-plan-get-categories (children)
(-when-let (cs (->> (org-ml-headline-get-contents (org-x-logbook-config) headline) (-when-let (cs (->> children
(--find (org-x--is-drawer-with-name org-x-drwr-categories it)) (--find (org-x--is-drawer-with-name org-x-drwr-categories it))
(org-ml-match '(plain-list item paragraph)) (org-ml-match '(plain-list item paragraph))
(--map (->> (org-ml-get-children it) (--map (->> (org-ml-get-children it)