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

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

221
local/lib/org-x/org-x-dag.el
View File

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