ENH make status buffer use org syntax

This commit is contained in:
Nathan Dwarshuis 2022-05-08 19:37:25 -04:00
parent 5bb0f8d279
commit 71f293892a
1 changed files with 173 additions and 202 deletions

View File

@ -2122,17 +2122,20 @@ highest in the tree."
;; (s-chop-prefix "_")
;; (intern)))
(defun org-x-dag-id->link (id)
(defun org-x-dag-id->link (fullpath id)
"Return the link node for ID."
(let ((desc (org-x-dag-id->title id)))
(->> (org-ml-build-secondary-string! desc)
(apply #'org-ml-build-link id :type "id"))))
(->> (if fullpath (org-x-dag-id->path nil id) (org-x-dag-id->title id))
(org-ml-build-secondary-string!)
(apply #'org-ml-build-link id :type "id")))
(defun org-x-dag-id->link-item (id)
"Return the link node of ID wrapped in an item node."
(->> (org-x-dag-id->link id)
(org-ml-build-paragraph)
(org-ml-build-item)))
(let* ((group (org-x-dag-id->group id))
(tag (if (eq group :action) (org-x-dag-id->category id)
(org-x-dag-group-code group)))
(fullpathp (memq group `(:action :endpoint :lifetime :survival)))
(link (org-x-dag-id->link fullpathp id)))
(org-ml-build-item :tag `(,tag) (org-ml-build-paragraph link))))
(defun org-x-dag-id->ns (id)
(-if-let (nst (plist-get org-x-dag :netstat))
@ -4186,16 +4189,19 @@ FUTURE-LIMIT in a list."
(let ((s (make-string n ?\s)))
(--map (s-prepend s it) lines)))
(defun org-x-dag--format-bs (bs-data)
(cl-flet
((format-comptime
(defun org-x-dag--build-bs-paragraph (bs-data)
(cl-flet*
((format-event
(verb what y m d H M)
(format "%s %s on %d-%02d-%02d at %02d:%02d" verb what y m d H M))
(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))))
(format-event verb what y m d H M))))
;; TODO this could show more detail if I wanted
(pcase bs-data
(let ((ls (pcase bs-data
(`(:action . ,d)
(-let* (((&plist :ancestry a :local l) d)
(local-status
@ -4246,8 +4252,8 @@ FUTURE-LIMIT in a list."
"Unmasked")))
(list (format "Goal status: %s" local-status)
(format "Mask status: %s" ancestry-status))))
;; TODO I currently don't allow either of these to be anything other than
;; "TODO"
;; TODO I currently don't allow either of these to be
;; anything other than "TODO"
(`(,(or :lifetime :survival) . ,d)
(-let* (((&plist :ancestry a :local _) d)
(ancestry-status (plist-get a :canceled-parent-p)))
@ -4267,9 +4273,10 @@ FUTURE-LIMIT in a list."
(list (format-comptime "weekly plan" comptime)))
(`(:daily :active (:sched ,sched))
(-let (((y m d H M) (org-ml-timestamp-get-start-time sched)))
(list (format "Open and scheduled on %d-%d-%d at %02d:%02d" y m d H M))))
(list (format-event "Scheduled" "metablock" y m d H M))))
(`(:daily :complete ,comptime)
(list (format-comptime "daily metablock" comptime))))))
(org-ml-build-paragraph (s-join "\n" ls)))))
(defun org-x-dag--format-title-with-group (id)
(let ((title (org-x-dag-id->title id))
@ -4277,132 +4284,98 @@ FUTURE-LIMIT in a list."
(org-x-dag-group-code))))
(format "%s - %s" group title)))
(defun org-x-dag--format-ns (id ns-data)
(cl-flet
((format-group
(header key fun)
(-some->> (plist-get ns-data key)
(--map (funcall fun it))
(org-x-dag--indent-lines 2)
(cons (format "%s:" header))))
(append-groups
(&rest groups)
(or (->> (-non-nil groups)
(-interpose '(""))
(-flatten-n 1))
'("none"))))
(let ((group (org-x-dag-id->group id)))
(pcase group
(defun org-x-dag--build-ns-list (id ns-data)
(cl-flet*
((build-item
(header &rest children)
(apply #'org-ml-build-item! :post-blank 1 :paragraph header children))
(format-group
(header key)
(-if-let (subitems (-some->> (plist-get ns-data key)
(-map #'org-x-dag-id->link-item)))
(->> (apply #'org-ml-build-plain-list subitems)
(build-item (format "%s:" header)))
(build-item (format "%s: none" header)))))
(let* ((group (org-x-dag-id->group id))
(args (pcase group
(:action
(append-groups
(format-group "Planned"
:planned
#'org-x-dag-id->title)
(format-group "Committed Goals"
:committed
#'org-x-dag--format-title-with-group)))
'(("Planned" :planned)
("Committed Goals" :committed)))
(:lifetime
(append-groups
(format-group "Planned"
:planned
#'org-x-dag-id->title)
(format-group "Fulfilled"
:committed
#'org-x-dag--format-title-with-group)))
'(("Planned" :planned)
("Fulfilled" :committed)))
(:endpoint
(append-groups
(format-group "Planned"
:planned
#'org-x-dag-id->title)
(format-group "Committed"
:committed
(lambda (id)
(org-x-dag-id->path nil id)))
(format-group "Fulfilled"
:fulfilled
(lambda (id)
(org-x-dag-id->path t id)))))
'(("Planned" :planned)
("Committed" :committed)
("Fulfilled" :fulfilled)))
(:survival
(append-groups
;; TODO not sure if this works
(format-group "Planned"
:planned
(lambda (id)
(org-x-dag-id->path t id)))
(format-group "Fulfilled"
:fulfilled
(lambda (id)
(org-x-dag-id->path t id)))))
'(("Planned" :planned)
("Fulfilled" :fulfilled)))
(:quarterly
(append-groups
(format-group "Scheduled actions"
:scheduled-actions
(lambda (id)
(org-x-dag-id->path t id)))
(format-group "Planned"
:planned
#'org-x-dag-id->title)
(format-group "Committed Goals"
:committed
#'org-x-dag--format-title-with-group)))
'(("Scheduled actions" :scheduled-actions)
("Planned" :planned)
("Committed Goals" :committed)))
(:weekly
(append-groups
(format-group "Planned"
:planned
(lambda (id)
(org-x-dag-id->path t id)))
(format-group "Committed"
:committed
#'org-x-dag-id->title)))
'(("Planned" :planned)
("Committed" :committed)))
(:daily
(append-groups
(format-group "Planned"
:planned
(lambda (id)
(org-x-dag-id->path t id)))
(format-group "Committed"
:committed
#'org-x-dag-id->title)))))))
'(("Planned" :planned)
("Committed" :committed))))))
(->> (--map (apply #'format-group it) args)
(apply #'org-ml-build-plain-list)))))
(defun org-x-dag-pop-buffer (name to-insert)
(pop-to-buffer (format "*%s*" name))
(read-only-mode 0)
(org-mode)
(erase-buffer)
(insert to-insert)
(read-only-mode 1))
(defun org-x-dag-show-status ()
(interactive)
(cl-flet*
((format-maybe
((paragraph-maybe
(x alt)
(if (not x) (list "none") (funcall alt x)))
(format-header
(header lines)
(->> (org-x-dag--indent-lines 2 lines)
(s-join "\n")
(format "%s:\n%s" header)))
(format-titles
(if (not x) (list (org-ml-build-paragraph "none")) (funcall alt x)))
(build-headline
(title section)
(org-ml-build-headline! :title-text title
:post-blank 0
:section-children section))
(build-id-list
(ids)
(-map #'org-x-dag--format-title-with-group ids))
(format-ids
(->> (-map #'org-x-dag-id->link-item ids)
(apply #'org-ml-build-plain-list)
(list)))
(build-id-headline
(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))
(->> (paragraph-maybe ids #'build-id-list)
(build-headline what)))
(format-bs
(bs)
(->> (format-either bs (lambda (b) (org-x-dag--format-bs b)))
(format-header "Buffer Status")))
(->> (either-from* bs
(org-ml-build-paragraph (format "Error: %s" it))
(org-x-dag--build-bs-paragraph it))
(list)
(build-headline "Buffer Status")))
(format-ns-either
(id ns-either)
(either-from* ns-either
(->> it
(--mapcat
(-let (((&plist :msg :ids) it))
(->> (-map #'org-x-dag--format-title-with-group ids)
(org-x-dag--indent-lines 2)
(cons (format "Error: %s" msg))))))
(org-x-dag--format-ns id it)))
(-let (((&plist :msg :ids) it)
(para (org-ml-build-paragraph (format "Error: %s" msg))))
(->> (-map #'org-x-dag-id->link-item ids)
(apply #'org-ml-build-plain-list)
(org-ml-build-item para))))
(apply #'org-ml-build-plain-list))
(org-x-dag--build-ns-list id it)))
(format-ns
(id ns)
(->> (format-maybe ns (lambda (x) (format-ns-either id x)))
(format-header "Network Status"))))
(->> (paragraph-maybe ns (lambda (x) (list (format-ns-either id x))))
(build-headline "Network Status"))))
(org-x-dag-sync)
(-if-let (hl (org-ml-parse-this-headline))
(let* ((id (org-x-dag-headline-get-id hl))
@ -4411,17 +4384,15 @@ FUTURE-LIMIT in a list."
(format-bs))))
(if (not bs) (message "Headline is not node")
(let ((lps (->> (org-x-dag-id->linked-parents id)
(format-ids "Parent Links")))
(build-id-headline "Parent Links")))
(lcs (->> (org-x-dag-id->linked-children id)
(format-ids "Child Links")))
(build-id-headline "Child Links")))
(ns (->> (org-x-dag-id->ns id)
(format-ns id))))
;; TODO there is probably a better way to do this
(pop-to-buffer "*Org-DAG Node Status*")
(read-only-mode 0)
(erase-buffer)
(insert (s-join "\n\n" (list lps lcs bs ns)))
(read-only-mode 1))))
(->> (list lps lcs bs ns)
(-map #'org-ml-to-string)
(s-join "\n")
(org-x-dag-pop-buffer "Org-DAG Node Status")))))
(message "Not on headline"))))
(defun org-x-dag-agenda-show-status ()