ADD function to show buffer status of headline at point

This commit is contained in:
Nathan Dwarshuis 2022-04-16 17:49:58 -04:00
parent fe813c09a4
commit cd3dd4f95c
1 changed files with 236 additions and 75 deletions

View File

@ -1281,7 +1281,15 @@ used for optimization."
ns)) ns))
(defun org-x-dag-ns-action (adjlist links ns) (defun org-x-dag-ns-action (adjlist links ns)
(-let (((&alist :endpoint ht-e :lifetime ht-l :survival ht-s) ns)) (cl-flet
((get-planned
(htbl ids)
(--mapcat (org-x-dag-ht-get-maybe htbl it :planned) ids)))
(-let (((&alist :endpoint ht-e
:lifetime ht-l
:survival ht-s
:quarterly ht-q)
ns))
(org-x-dag-ns-with-valid ns adjlist :action links (org-x-dag-ns-with-valid ns adjlist :action links
'((:survival) (:endpoint) (:lifetime)) '((:survival) (:endpoint) (:lifetime))
(lambda (id this-h res) (lambda (id this-h res)
@ -1295,13 +1303,16 @@ used for optimization."
(either :right `(:committed ,s :survivalp t))) (either :right `(:committed ,s :survivalp t)))
(t (t
(either :right `(:committed (,@e ,@l) :survivalp nil)))))) (either :right `(:committed (,@e ,@l) :survivalp nil))))))
(when (org-x-dag-id->planning-timestamp :scheduled id)
(->> (-union (get-planned ht-e e) (get-planned ht-l l))
(org-x-dag-ht-add-links id ht-q :scheduled-actions)))
(ht-set this-h id this-ns) (ht-set this-h id this-ns)
(org-x-dag-ht-add-links id ht-l :fulfilled l) (org-x-dag-ht-add-links id ht-l :fulfilled l)
(org-x-dag-ht-add-links id ht-s :fulfilled s) (org-x-dag-ht-add-links id ht-s :fulfilled s)
(org-x-dag-ht-add-links id ht-e :fulfilled e) (org-x-dag-ht-add-links id ht-e :fulfilled e)
(->> (--mapcat (org-x-dag-ht-get-maybe ht-e it :committed) e) (->> (--mapcat (org-x-dag-ht-get-maybe ht-e it :committed) e)
(org-x-dag-ht-add-links id ht-l :fulfilled))))) (org-x-dag-ht-add-links id ht-l :fulfilled)))))
ns)) ns)))
(defun org-x-dag-ns-dlp (adjlist links ns) (defun org-x-dag-ns-dlp (adjlist links ns)
(cl-flet (cl-flet
@ -1419,12 +1430,21 @@ used for optimization."
;; add all links to the network status object (ew side effects) ;; add all links to the network status object (ew side effects)
(org-x-dag-ns-ltg l ns) (org-x-dag-ns-ltg l ns)
(org-x-dag-ns-svg s ns) (org-x-dag-ns-svg s ns)
(org-x-dag-ns-epg adjlist e ns) (org-x-dag-ns-epg adjlist e ns)
(org-x-dag-ht-propagate-down adjlist :endpoint :committed ns)
(org-x-dag-ns-qtp adjlist q ns) (org-x-dag-ns-qtp adjlist q ns)
(org-x-dag-ht-propagate-up adjlist :lifetime :planned ns)
(org-x-dag-ht-propagate-up adjlist :survival :planned ns)
(org-x-dag-ns-wkp adjlist w ns) (org-x-dag-ns-wkp adjlist w ns)
(org-x-dag-ns-action adjlist a ns) (org-x-dag-ns-action adjlist a ns)
(org-x-dag-ht-propagate-up adjlist :lifetime :fulfilled ns)
(org-x-dag-ht-propagate-up adjlist :survival :fulfilled ns)
(org-x-dag-ns-dlp adjlist d ns) (org-x-dag-ns-dlp adjlist d ns)
;; propagate network statuses across each buffer tree as needed
(org-x-dag-ht-propagate-down adjlist :action :planned ns) (org-x-dag-ht-propagate-down adjlist :action :planned ns)
(org-x-dag-ht-map-down adjlist :action ns (org-x-dag-ht-map-down adjlist :action ns
(lambda (h id) (lambda (h id)
@ -1442,12 +1462,7 @@ used for optimization."
(lambda (x) (append x committed)))))) (lambda (x) (append x committed))))))
(lambda (to-set) (lambda (to-set)
(-let (((committed survivalp) to-set)) (-let (((committed survivalp) to-set))
`(:committed ,committed :survivalp ,survivalp)))) `(:committed ,committed :survivalp ,survivalp))))))
(org-x-dag-ht-propagate-down adjlist :endpoint :committed ns)
(org-x-dag-ht-propagate-up adjlist :lifetime :fulfilled ns)
(org-x-dag-ht-propagate-up adjlist :lifetime :planned ns)
(org-x-dag-ht-propagate-up adjlist :survival :fulfilled ns)
(org-x-dag-ht-propagate-up adjlist :survival :planned ns)))
;; global pipeline control ;; global pipeline control
@ -1817,6 +1832,9 @@ Return value is a list like (BUFFER NON-BUFFER)."
"Return children of ID that are not linked." "Return children of ID that are not linked."
(car (org-x-dag-id->split-children-2 id))) (car (org-x-dag-id->split-children-2 id)))
(defun org-x-dag-id->linked-children (id)
(cadr (org-x-dag-id->split-children-2 id)))
(defun org-x-dag-id->all-buffer-children (id) (defun org-x-dag-id->all-buffer-children (id)
"Return nested children of ID that are in the same buffer." "Return nested children of ID that are in the same buffer."
(->> (org-x-dag-id->buffer-children id) (->> (org-x-dag-id->buffer-children id)
@ -2433,25 +2451,36 @@ FUTURE-LIMIT in a list."
(mk-item it :endpoint p f c))))))))) (mk-item it :endpoint p f c)))))))))
(defun org-x-dag-itemize-qtp (files) (defun org-x-dag-itemize-qtp (files)
(let ((wkp-ids (org-x-dag->current-wkp-ids)) (let* ((wkp-ids (org-x-dag->current-wkp-ids))
(sel-date (->> (org-x-dag->selected-date) (sel-date (org-x-dag->selected-date))
(org-x-dag-date-to-quarter-start)))) (q-date (org-x-dag-date-to-quarter-start sel-date))
(week-start (org-x-dag-date-to-week-start sel-date))
(week-end (org-x-dag-datetime-shift week-start 7 'submonth)))
(cl-flet
((is-scheduled-current
(id)
(-when-let (d (-some->> (org-x-dag-id->planning-datetime :scheduled id)
(org-x-dag-datetime-split)
(car)))
(and (not (org-x-dag-datetime< d week-start))
(org-x-dag-datetime< d week-end)))))
(org-x-dag-with-ids files (org-x-dag-with-ids files
(pcase (either-from-right (org-x-dag-id->bs it) nil) (pcase (either-from-right (org-x-dag-id->bs it) nil)
(`(:quarterly :active ,dead) (`(:quarterly :active ,dead)
(let* ((tags (org-x-dag-id->tags nil it)) (let* ((tags (org-x-dag-id->tags nil it))
(date (org-x-dag-quarter-tags-to-date tags))) (date (org-x-dag-quarter-tags-to-date tags)))
(when (org-x-dag-datetime= sel-date date) (when (org-x-dag-datetime= q-date date)
(-when-let (ns (org-x-dag-id->ns it)) (-when-let (ns (org-x-dag-id->ns it))
(-let (((&plist :planned p :committed c) (-let (((&plist :planned p :committed c :scheduled-actions a)
(either-from-right ns nil))) (either-from-right ns nil)))
;; TODO actually handle deadlines ;; TODO actually handle deadlines
(-> (org-x-dag-format-tag-node tags it) (-> (org-x-dag-format-tag-node tags it)
(org-add-props nil (org-add-props nil
'x-deadline dead 'x-deadline dead
'x-scheduled (-any-p #'is-scheduled-current a)
'x-plannedp (-intersection p wkp-ids) 'x-plannedp (-intersection p wkp-ids)
'x-committedp c) 'x-committedp c)
(list))))))))))) (list))))))))))))
;; TODO not DRY ;; TODO not DRY
(defun org-x-dag-itemize-wkp (files) (defun org-x-dag-itemize-wkp (files)
@ -2476,7 +2505,7 @@ FUTURE-LIMIT in a list."
(defun org-x-dag--item-add-goal-ids (item ids) (defun org-x-dag--item-add-goal-ids (item ids)
(if ids (if ids
(--map (org-add-props (copy-seq item) nil 'x-goal-id it) ids) (--map (org-add-props (-copy item) nil 'x-goal-id it) ids)
(list (org-add-props item nil 'x-goal-id nil)))) (list (org-add-props item nil 'x-goal-id nil))))
(defun org-x-dag-itemize-tasks-with-goals (files) (defun org-x-dag-itemize-tasks-with-goals (files)
@ -2853,38 +2882,38 @@ FUTURE-LIMIT in a list."
;; quarterly plan ;; quarterly plan
(defun org-x-dag-qtp-to-children (qt-plan) ;; (defun org-x-dag-qtp-to-children (qt-plan)
(-let* (((&plist :categories :goals) qt-plan) ;; (-let* (((&plist :categories :goals) qt-plan)
;; TODO what happens if there are no categories? ;; ;; TODO what happens if there are no categories?
(sec (-some->> categories ;; (sec (-some->> categories
(--map-indexed (org-ml-build-item! ;; (--map-indexed (org-ml-build-item!
:bullet it-index ;; :bullet it-index
:paragraph (symbol-name it))) ;; :paragraph (symbol-name it)))
(apply #'org-ml-build-plain-list) ;; (apply #'org-ml-build-plain-list)
(org-ml-build-drawer org-x-drwr-categories) ;; (org-ml-build-drawer org-x-drwr-categories)
(list))) ;; (list)))
(subtrees (--map (apply #'org-ml-build-headline! ;; (subtrees (--map (apply #'org-ml-build-headline!
:level 3 ;; :level 3
:title-text (plist-get (cdr it) :desc) ;; :title-text (plist-get (cdr it) :desc)
:tags `(,(plist-get (cdr it) :tag)) ;; :tags `(,(plist-get (cdr it) :tag))
(alist-get (car it) goals)) ;; (alist-get (car it) goals))
org-x-life-categories))) ;; org-x-life-categories)))
(list sec subtrees))) ;; (list sec subtrees)))
(defun org-x-dag-qtp-from-children (children) ;; (defun org-x-dag-qtp-from-children (children)
;; ignore properties, planning, etc ;; ;; ignore properties, planning, etc
(-let* (((sec subtrees) (if (org-ml-is-type 'section (car children)) ;; (-let* (((sec subtrees) (if (org-ml-is-type 'section (car children))
`(,(car children) ,(cdr children)) ;; `(,(car children) ,(cdr children))
`(nil ,children))) ;; `(nil ,children)))
(cats (-some->> sec ;; (cats (-some->> sec
(--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-x-qtp-drawer-to-categories))) ;; (org-x-qtp-drawer-to-categories)))
(goals (--map (let* ((tag (car (org-ml-get-property :tags it))) ;; (goals (--map (let* ((tag (car (org-ml-get-property :tags it)))
(key (car (--find (equal tag (plist-get (cdr it) :tag)) ;; (key (car (--find (equal tag (plist-get (cdr it) :tag))
org-x-life-categories)))) ;; org-x-life-categories))))
(cons key (org-ml-headline-get-subheadlines it))) ;; (cons key (org-ml-headline-get-subheadlines it)))
subtrees))) ;; subtrees)))
(list :categories cats :goals goals))) ;; (list :categories cats :goals goals)))
(defun org-x-dag-qtp-get-headline (date) (defun org-x-dag-qtp-get-headline (date)
(-let* (((y q) (org-x-dag-date-to-quarter date))) (-let* (((y q) (org-x-dag-date-to-quarter date)))
@ -2892,15 +2921,15 @@ FUTURE-LIMIT in a list."
(list (-partial #'org-x-dag-headlines-find-year y) (list (-partial #'org-x-dag-headlines-find-year y)
(-partial #'org-x-dag-headlines-find-quarter q))))) (-partial #'org-x-dag-headlines-find-quarter q)))))
(defun org-x-dag-qtp-get (quarter) ;; (defun org-x-dag-qtp-get (quarter)
(org-x-with-file (org-x-qtp-get-file) ;; (org-x-with-file (org-x-qtp-get-file)
(-let (((year qnum) quarter)) ;; (-let (((year qnum) quarter))
(->> (org-ml-parse-subtrees 'all) ;; (->> (org-ml-parse-subtrees 'all)
(org-x-dag-headlines-find-year year) ;; (org-x-dag-headlines-find-year year)
(org-ml-headline-get-subheadlines) ;; (org-ml-headline-get-subheadlines)
(org-x-dag-headlines-find-quarter qnum) ;; (org-x-dag-headlines-find-quarter qnum)
(org-ml-get-children) ;; (org-ml-get-children)
(org-x-dag-qtp-from-children))))) ;; (org-x-dag-qtp-from-children)))))
(defun org-x-dag-qtp-set-headlines (date headlines) (defun org-x-dag-qtp-set-headlines (date headlines)
(-let* (((y q) (org-x-dag-date-to-quarter date)) (-let* (((y q) (org-x-dag-date-to-quarter date))
@ -3555,6 +3584,134 @@ FUTURE-LIMIT in a list."
;; (org-x-dag-qtp-set cur-q `(:categories ,c :goals nil)) ;; (org-x-dag-qtp-set cur-q `(:categories ,c :goals nil))
;; (apply #'message "Created new quaterly plan for %d-Q%d" cur-q))))) ;; (apply #'message "Created new quaterly plan for %d-Q%d" cur-q)))))
;; show node info
(defun org-x-dag--indent-lines (n lines)
(let ((s (make-string n ?\s)))
(--map (s-prepend s it) lines)))
(defun org-x-dag--format-bs (bs-data)
(cl-flet
((format-comptime
(what comptime)
(-let* (((&plist :epoch e :canceledp c) comptime)
((y m d H M) (org-ml-unixtime-to-time-long e))
(verb (if c "Canceled" "Completed")))
(format "%s %s on %d-%d-%d at %02d:%02d" verb what y m d H M))))
;; TODO this could show more detail if I wanted
(pcase bs-data
;; action
(`(:sp-proj :proj-active)
"Active Project")
(`(:sp-proj :proj-wait)
"Waiting Project")
(`(:sp-proj :proj-hold)
"Held Project")
(`(:sp-proj :proj-stuck)
"Stuck Project")
(`(:sp-proj :proj-complete ,comptime)
(format-comptime "project" comptime))
(`(:sp-task :task-complete ,comptime)
(format-comptime "task" comptime))
(`(:sp-task :task-active ,_)
"Active Task")
(`(:endpoint :active ,dead)
(->> (if dead (->> (org-ml-to-trimmed-string dead)
(format "deadline: %s"))
"no deadline")
(format "Active with %s")))
(`(:sp-iter :iter-active ,_)
"Active Iterator")
(`(:sp-iter :iter-empty)
"Empty Iterator")
(`(:sp-iter :iter-complete ,comptime)
(format-comptime "iterator" comptime))
(`(:sp-subiter :si-active ,_)
"Active sub-iterator")
(`(:sp-subiter :si-complete ,comptime)
(format-comptime "sub-iterator" comptime))
;; everything else
(`(:endpoint :complete ,comptime)
(format-comptime "EPG" comptime))
(`(,(or :survival :lifetime) :active)
(list "Active"))
(`(:quarterly :active ,dead)
(->> (if dead (->> (org-ml-to-trimmed-string dead)
(format "deadline: %s"))
"no deadline")
(format "Active with %s")))
(`(:quarterly :complete ,comptime)
(format-comptime "quarterly plan" comptime))
(`(:weekly :active)
"Active")
(`(:weekly :complete ,comptime)
(format-comptime "weekly plan" comptime))
(`(:daily :active (:sched ,sched))
(-let (((y m d H M) (org-ml-timestamp-get-start-time sched)))
(format "Open and scheduled on %d-%d-%d at %02d:%02d" y m d H M)))
(`(:daily :complete ,comptime)
(format-comptime "daily metablock" comptime)))))
(defun org-x-dag-show-status ()
(interactive)
(cl-flet*
((format-maybe
(x alt)
(if (not x) (list "none") (funcall alt x)))
(format-header
(header lines)
(print lines)
(->> (org-x-dag--indent-lines 2 lines)
(s-join "\n")
(format "%s:\n%s" header)))
(format-title
(id)
(let ((title (org-x-dag-id->title id))
(group (->> (org-x-dag-id->group id)
(org-x-dag-group-code))))
(format "%s - %s" group title)))
(format-titles
(ids)
(-map #'format-title ids))
(format-ids
(what ids)
(->> (format-maybe ids #'format-titles)
(format-header what)))
(format-either
(e right)
(either-from e (lambda (e) (list (format "Error: %s" e))) right))
(format-bs
(id bs)
(->> (format-either bs (lambda (b) (list (org-x-dag--format-bs b))))
(format-header "Buffer Status")))
(format-ns-either
(ns-either)
(format-either
ns-either
(lambda (r)
(list (format "%S" r)))))
(format-ns
(id ns)
(->> (format-maybe ns #'format-ns-either)
(format-header "Network Status"))))
(org-x-dag-sync)
(-if-let (hl (org-ml-parse-this-headline))
(let* ((id (org-x-dag-headline-get-id hl))
(bs (-some->> id
(org-x-dag-id->bs)
(format-bs id))))
(if (not bs) (message "Headline is not node")
(let ((lps (->> (org-x-dag-id->linked-parents id)
(format-ids "Parent Links")))
;; TODO make this actually only linked children
(lcs (->> (org-x-dag-id->linked-children id)
(format-ids "Child Links")))
(ns (->> (org-x-dag-id->ns id)
(format-ns id))))
(message (s-join "\n\n" (list lps lcs bs ns))))))
(message "Not on headline"))))
;;; agenda views ;;; agenda views
;; agenda builders ;; agenda builders
@ -3789,8 +3946,11 @@ In the order of display
(lambda (line) (lambda (line)
(-let* ((c (get-text-property 1 'x-committedp line)) (-let* ((c (get-text-property 1 'x-committedp line))
(p (get-text-property 1 'x-plannedp line)) (p (get-text-property 1 'x-plannedp line))
(s (get-text-property 1 'x-scheduled line))
((rank text) ((rank text)
(cond (cond
((and s c)
'(5 "Committed | Scheduled"))
((and p c) ((and p c)
'(4 "Committed | Planned")) '(4 "Committed | Planned"))
((and (not p) c) ((and (not p) c)
@ -3893,6 +4053,7 @@ review phase)"
(org-x-dag-agenda-show-nodes "Iterators-0" #'org-x-dag-itemize-iterators files (org-x-dag-agenda-show-nodes "Iterators-0" #'org-x-dag-itemize-iterators files
`((org-agenda-sorting-strategy '(category-keep)) `((org-agenda-sorting-strategy '(category-keep))
(org-super-agenda-groups (org-super-agenda-groups
;; TODO this is wrong
',(nd/org-def-super-agenda-automap ',(nd/org-def-super-agenda-automap
(cl-case (org-x-headline-get-iterator-status) (cl-case (org-x-headline-get-iterator-status)
(:uninit "0. Uninitialized") (:uninit "0. Uninitialized")