ENH show error nodes for network status
This commit is contained in:
parent
c0312a1f28
commit
e8b71bc03c
|
@ -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."
|
||||||
|
|
Loading…
Reference in New Issue