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

ENH show error nodes for network status

This commit is contained in:
Nathan Dwarshuis 2022-04-21 18:25:29 -04:00
parent c0312a1f28
commit e8b71bc03c
1 changed files with 65 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1131,6 +1131,9 @@ used for optimization."
;; - scheduled: x -> plan ;; - scheduled: x -> plan
;; - active: x -> action ;; - active: x -> action
(defun org-x-dag--ns-error (msg ids)
(either :left `(:msg ,msg :ids ,ids)))
(defun org-x-dag-id-link-group (adjlist id) (defun org-x-dag-id-link-group (adjlist id)
(-> (ht-get adjlist id) (-> (ht-get adjlist id)
(plist-get :node-meta) (plist-get :node-meta)
@ -1249,7 +1252,7 @@ used for optimization."
(defun org-x-dag-ns-is-leaf-p (adjlist id) (defun org-x-dag-ns-is-leaf-p (adjlist id)
(if (org-x-dag-get-children adjlist id) (if (org-x-dag-get-children adjlist id)
(either :left "Linked to non-leaf node") (org-x-dag--ns-error "Linked to non-leaf node" (list id))
(either :right id))) (either :right id)))
(defun org-x-dag-ns-with-valid (ns adjlist cur-key links keypairs valid-fun) (defun org-x-dag-ns-with-valid (ns adjlist cur-key links keypairs valid-fun)
@ -1263,7 +1266,7 @@ used for optimization."
(h valid-fun acc id) (h valid-fun acc id)
(cond (cond
((either-is-left-p (ht-get h id)) ((either-is-left-p (ht-get h id))
(either :left "Linked to invalid links")) (org-x-dag--ns-error "Linked to non-leaf node" (list id)))
(valid-fun (valid-fun
;; NOTE this valid-fun doesn't just have to return a Right ID upon ;; NOTE this valid-fun doesn't just have to return a Right ID upon
;; success, it can return a Right anything which might be useful ;; success, it can return a Right anything which might be useful
@ -1284,7 +1287,8 @@ used for optimization."
(grouped (--group-by (key-group keys it) it-targets)) (grouped (--group-by (key-group keys it) it-targets))
(cur-h (alist-get cur-key ns))) (cur-h (alist-get cur-key ns)))
(-if-let (invalid (alist-get :invalid grouped)) (-if-let (invalid (alist-get :invalid grouped))
(ht-set cur-h it (org-x-dag-bs-error-links "Invalid links" invalid)) (->> (org-x-dag--ns-error "Invalid links" invalid)
(ht-set cur-h it))
(let ((x (either-foldM* (reduce-valid grouped acc it) nil keypairs))) (let ((x (either-foldM* (reduce-valid grouped acc it) nil keypairs)))
(either-from x (either-from x
(lambda (_) (lambda (_)
@ -1352,9 +1356,9 @@ used for optimization."
ns) ns)
(is-committed-leaf-p (is-committed-leaf-p
(lambda (adjlist id) (lambda (adjlist id)
(if (not (org-x-dag-ht-get-maybe ht-e id :committed)) (if (org-x-dag-ht-get-maybe ht-e id :committed)
(either :left "Linked to non-committed endpoint node") (org-x-dag-ns-is-leaf-p adjlist id)
(org-x-dag-ns-is-leaf-p adjlist id))))) (org-x-dag--ns-error "Linked to non-committed endpoint node" (list id))))))
(org-x-dag-ns-with-valid ns adjlist :action links (org-x-dag-ns-with-valid ns adjlist :action links
`((:survival org-x-dag-ns-is-leaf-p) `((:survival org-x-dag-ns-is-leaf-p)
(:endpoint ,is-committed-leaf-p) (:endpoint ,is-committed-leaf-p)
@ -1363,8 +1367,8 @@ used for optimization."
(-let (((&alist :survival s :endpoint e :lifetime l) res)) (-let (((&alist :survival s :endpoint e :lifetime l) res))
(->> (cond (->> (cond
((and s (or e l)) ((and s (or e l))
(->> "Action has both survival and endpoint/lifetime links" (-> "Action has both survival and endpoint/lifetime links"
(either :left))) (org-x-dag--ns-error (append s e l))))
(s (s
(either :right `(:committed ,s :survivalp t))) (either :right `(:committed ,s :survivalp t)))
(t (t
@ -1418,23 +1422,25 @@ used for optimization."
;; buffer status ;; buffer status
(-let (((_ time) (org-x-dag-datetime-split sched))) (-let (((_ time) (org-x-dag-datetime-split sched)))
(if time (if time
(either :left "Linked to action with HH:MM timestamp") (-> "Linked to action with HH:MM timestamp"
(org-x-dag--ns-error (list id)))
(if (org-x-dag-ht-get-maybe ht-a id :survivalp) (if (org-x-dag-ht-get-maybe ht-a id :survivalp)
(to-valid id survival committed-ids) (to-valid id survival committed-ids)
(-if-let (q (funcall get-planned id committed-ids)) (-if-let (q (funcall get-planned id committed-ids))
(to-valid id :quarterly q) (to-valid id :quarterly q)
(->> "Linked to scheduled action that isn't on QTP" (-> "Linked to scheduled action that isn't on QTP"
(either :left)))))) (org-x-dag--ns-error (list id)))))))
(-if-let (w (->> (funcall get-planned id committed-ids) (-if-let (w (->> (funcall get-planned id committed-ids)
(--mapcat (org-x-dag-ht-get-maybe ht-q it :planned)))) (--mapcat (org-x-dag-ht-get-maybe ht-q it :planned))))
(to-valid id :weekly w) (to-valid id :weekly w)
(->> "Linked to unscheduled action that isn't on WKP" (-> "Linked to unscheduled action that isn't on WKP"
(either :left)))))) (org-x-dag--ns-error (list id)))))))
(is-valid-action (is-valid-action
(lambda (adjlist id) (lambda (adjlist id)
(-if-let (c (org-x-dag-ht-get-maybe ht-a id :committed)) (-if-let (c (org-x-dag-ht-get-maybe ht-a id :committed))
(funcall is-scheduled-action adjlist id c) (funcall is-scheduled-action adjlist id c)
(either :left "Linked to uncommitted action"))))) (-> "Linked to uncommitted action"
(org-x-dag--ns-error (list id)))))))
(org-x-dag-ns-with-valid ns adjlist :daily links (org-x-dag-ns-with-valid ns adjlist :daily links
`((:action ,is-valid-action)) `((:action ,is-valid-action))
(lambda (id this-h res) (lambda (id this-h res)
@ -1506,17 +1512,18 @@ DEF-FUN and the output from GET-FUN (type :: a -> NS)."
;; finishes before the ancestor, else throw an error; if these two ;; finishes before the ancestor, else throw an error; if these two
;; conditions pass return the original deadline ;; conditions pass return the original deadline
(lambda (plist to-set) (lambda (plist to-set)
;; TODO need to pass the id here to get the error messages correct
(-if-let (this-dead (-some->> (plist-get plist :deadline) (-if-let (this-dead (-some->> (plist-get plist :deadline)
(org-ml-timestamp-get-start-time))) (org-ml-timestamp-get-start-time)))
(let ((set-dead (org-ml-timestamp-get-start-time to-set))) (let ((set-dead (org-ml-timestamp-get-start-time to-set)))
(cond (cond
((xor (org-ml-time-is-long this-dead) ((xor (org-ml-time-is-long this-dead)
(org-ml-time-is-long set-dead)) (org-ml-time-is-long set-dead))
(->> "EPG has parent with different deadline precision" (-> "EPG has parent with different deadline precision"
(either :left)) (org-x-dag--ns-error nil))
((org-x-dag-datetime< set-dead this-dead) ((org-x-dag-datetime< set-dead this-dead)
(->> "EPG has deadline the ends after parent deadline" (-> "EPG has deadline that ends after parent deadline"
(either :left))) (org-x-dag--ns-error nil)))
(t (t
(either :right plist))))) (either :right plist)))))
(either :right plist))) (either :right plist)))
@ -1822,14 +1829,22 @@ If FORCE is non-nil, sync no matter what."
(defun org-x-dag->goal-file (which) (defun org-x-dag->goal-file (which)
(plist-get (org-x-dag->goal-file-state) which)) (plist-get (org-x-dag->goal-file-state) which))
(defun org-x-dag->goal-files ()
(-map #'org-x-dag->goal-file (list :lifetime :endpoint :survival)))
(defun org-x-dag->planning-file (which) (defun org-x-dag->planning-file (which)
(plist-get (org-x-dag->planning-file-state) which)) (plist-get (org-x-dag->planning-file-state) which))
(defun org-x-dag->planning-files ()
(-map #'org-x-dag->planning-file (list :quarterly :weekly :daily)))
(defun org-x-dag->action-files () (defun org-x-dag->action-files ()
(plist-get (org-x-dag->file-state) :action-files)) (plist-get (org-x-dag->file-state) :action-files))
(defun org-x-dag->files () (defun org-x-dag->files ()
(org-x-dag-flatten-file-state (org-x-dag->file-state))) (append (org-x-dag->planning-files)
(org-x-dag->goal-files)
(org-x-dag->action-files)))
;; id properties ;; id properties
@ -2732,17 +2747,21 @@ FUTURE-LIMIT in a list."
(defun org-x-dag-itemize-errors (files) (defun org-x-dag-itemize-errors (files)
(cl-flet (cl-flet
((format-id ((format-error
(id msg) (id type msg)
(-> (org-x-dag-format-tag-node nil id) (-> (org-x-dag-format-tag-node nil id)
(org-add-props nil (org-add-props nil
'x-error msg)))) 'x-error-type type
(with-temp-buffer 'x-error msg)
(org-mode) (list))))
(->> (org-x-dag-files->ids files) (org-x-dag-with-ids files
(--map (pcase (org-x-dag-id->bs it) (-if-let (b-err (either-from-left (org-x-dag-id->bs it) nil))
(`(:error ,msg) (format-id it msg)))) (format-error it :buffer-status b-err)
(-non-nil))))) (-when-let (n-err (-some-> (org-x-dag-id->ns it)
(either-from
(lambda (it) (plist-get it :msg))
(-const nil))))
(format-error it :network-status n-err))))))
;; agenda/calendar ;; agenda/calendar
@ -3939,10 +3958,12 @@ FUTURE-LIMIT in a list."
(format-header "Buffer Status"))) (format-header "Buffer Status")))
(format-ns-either (format-ns-either
(id ns-either) (id ns-either)
(format-either (either-from* ns-either
ns-either (-let (((&plist :msg :ids) it))
(lambda (r) (->> (-map #'org-x-dag--format-title-with-group ids)
(org-x-dag--format-ns id r)))) (org-x-dag--indent-lines 2)
(cons (format "Error: %s" msg))))
(org-x-dag--format-ns id it)))
(format-ns (format-ns
(id ns) (id ns)
(->> (format-maybe ns (lambda (x) (format-ns-either id x))) (->> (format-maybe ns (lambda (x) (format-ns-either id x)))
@ -3968,6 +3989,11 @@ FUTURE-LIMIT in a list."
(read-only-mode 1)))) (read-only-mode 1))))
(message "Not on headline")))) (message "Not on headline"))))
(defun org-x-dag-agenda-show-status ()
(interactive)
(org-x-agenda-cmd-wrapper nil
(org-x-dag-show-status)))
;;; agenda views ;;; agenda views
;; agenda builders ;; agenda builders
@ -4322,12 +4348,17 @@ review phase)"
(defun org-x-dag-agenda-errors () (defun org-x-dag-agenda-errors ()
"Show the critical errors agenda view." "Show the critical errors agenda view."
(interactive) (interactive)
(let ((files (org-x-dag->action-files))) (let ((files (org-x-dag->files)))
(org-x-dag-agenda-show-nodes "Errors" #'org-x-dag-itemize-errors files (org-x-dag-agenda-show-nodes "Errors" #'org-x-dag-itemize-errors files
`((org-super-agenda-groups `((org-super-agenda-groups
'((:auto-map '((:auto-map
(lambda (line) (lambda (line)
(get-text-property 1 'x-error line))))))))) (-let* ((e (get-text-property 1 'x-error line))
(et (get-text-property 1 'x-error-type line))
((rank key) (cl-case et
(:buffer-status '(1 "Buffer Status"))
(:network-status '(2 "Network Status")))))
(format "%d. %s - %s" rank key e))))))))))
(defun org-x-dag-agenda-archive () (defun org-x-dag-agenda-archive ()
"Show the archive agenda view." "Show the archive agenda view."