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

ENH keep track of multiple errors in network status left

This commit is contained in:
Nathan Dwarshuis 2022-04-21 19:17:07 -04:00
parent e8b71bc03c
commit 34817889b6
2 changed files with 62 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
local/lib/either/either.el
View File

@ -140,5 +140,14 @@ left/right slots."
(!cons (cadr it) acc))) (!cons (cadr it) acc)))
(nreverse acc))) (nreverse acc)))
(defun either-partition (eithers)
"Return separate EITHERS into list like (LEFTS RIGHTS)."
(let (acc-left acc-right)
(--each eithers
(if (either-is-right-p it)
(!cons (cadr it) acc-right)
(!cons (cadr it) acc-left)))
`(,(nreverse acc-left) ,(nreverse acc-right))))
(provide 'either) (provide 'either)
;;; either.el ends here ;;; either.el ends here

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

@ -1252,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)
(org-x-dag--ns-error "Linked to non-leaf node" (list id)) (either :left `("Linked to non-leaf node" ,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,25 +1263,32 @@ used for optimization."
(let ((g (org-x-dag-id-link-group adjlist id))) (let ((g (org-x-dag-id-link-group adjlist id)))
(if (member g keys) g :invalid))) (if (member g keys) g :invalid)))
(id-is-valid (id-is-valid
(h valid-fun acc id) (h valid-fun id)
(cond (cond
((either-is-left-p (ht-get h id)) ((either-is-left-p (ht-get h id))
(org-x-dag--ns-error "Linked to non-leaf node" (list id))) (either :left `("Linked to non-leaf node" ,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
;; downstream ;; downstream
(-> (funcall valid-fun adjlist id) (funcall valid-fun adjlist id))
(either<$> (cons it acc))))
(t (t
(either :right (cons id acc))))) (either :right id))))
(reduce-valid (reduce-valid
(grouped-targets acc keypair) (grouped-targets acc keypair)
(-let* (((key valid-fun) keypair) (-let* (((key valid-fun) keypair)
((acc-rights acc-lefts) acc)
(h (alist-get key ns)) (h (alist-get key ns))
(new (->> (alist-get key grouped-targets) ((lefts rights) (->> (alist-get key grouped-targets)
(either-foldM* (id-is-valid h valid-fun acc it) nil)))) (--map (id-is-valid h valid-fun it))
(either<$> new `((,key ,@it) ,@acc))))) (either-partition))))
`(((,key ,@rights) ,@acc-rights)
(,@lefts ,@acc-lefts))))
(group-errors
(errors)
(->> (-group-by #'car errors)
(--map (list :msg (car it) :ids (-map #'cadr (cdr it))))
(either :left))))
(org-x-dag-each-links links (org-x-dag-each-links links
(let* ((keys (-map #'car keypairs)) (let* ((keys (-map #'car keypairs))
(grouped (--group-by (key-group keys it) it-targets)) (grouped (--group-by (key-group keys it) it-targets))
@ -1289,13 +1296,11 @@ used for optimization."
(-if-let (invalid (alist-get :invalid grouped)) (-if-let (invalid (alist-get :invalid grouped))
(->> (org-x-dag--ns-error "Invalid links" invalid) (->> (org-x-dag--ns-error "Invalid links" invalid)
(ht-set cur-h it)) (ht-set cur-h it))
(let ((x (either-foldM* (reduce-valid grouped acc it) nil keypairs))) (-let (((valid errors)
(either-from x (--reduce-from (reduce-valid grouped acc it) nil keypairs)))
(lambda (_) (if errors (ht-set cur-h it (group-errors errors))
(ht-set cur-h it x)) (when valid-fun
(lambda (valid-ids) (funcall valid-fun it cur-h valid)))))))))
(when valid-fun
(funcall valid-fun it cur-h valid-ids))))))))))
(defun org-x-dag-ns-ltg (adjlist links ns) (defun org-x-dag-ns-ltg (adjlist links ns)
(org-x-dag-ns-with-valid ns adjlist :lifetime links (org-x-dag-ns-with-valid ns adjlist :lifetime links
@ -1358,7 +1363,8 @@ used for optimization."
(lambda (adjlist id) (lambda (adjlist id)
(if (org-x-dag-ht-get-maybe ht-e id :committed) (if (org-x-dag-ht-get-maybe ht-e id :committed)
(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)))))) (->> (list "Linked to non-committed endpoint node" id)
(either :left))))))
(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)
@ -1367,8 +1373,10 @@ 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" (->> (list :msg "Action has SVG and EPG/LTG links"
(org-x-dag--ns-error (append s e l)))) :ids (append s e l))
(list)
(either :left)))
(s (s
(either :right `(:committed ,s :survivalp t))) (either :right `(:committed ,s :survivalp t)))
(t (t
@ -1422,25 +1430,24 @@ 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
(-> "Linked to action with HH:MM timestamp" (->> (list "Linked to action with HH:MM timestamp" id)
(org-x-dag--ns-error (list id))) (either :left))
(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" (->> (list "Linked to scheduled action that isn't on QTP" id)
(org-x-dag--ns-error (list id))))))) (either :left)))))
(-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" (->> (list "Linked to unscheduled action that isn't on WKP" id)
(org-x-dag--ns-error (list id))))))) (either :left)))))))
(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)
(-> "Linked to uncommitted action" (either :left (list "Linked to uncommitted action" id))))))
(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)
@ -1519,14 +1526,13 @@ DEF-FUN and the output from GET-FUN (type :: a -> NS)."
(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" (either :left '(("EPG has parent with different deadline precision"))))
(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 that 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)))
(lambda (to-set) (lambda (to-set)
`(:deadline ,to-set)))) `(:deadline ,to-set))))
@ -2752,16 +2758,15 @@ FUTURE-LIMIT in a list."
(-> (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-type type 'x-error-type type
'x-error msg) 'x-error msg))))
(list))))
(org-x-dag-with-ids files (org-x-dag-with-ids files
(-if-let (b-err (either-from-left (org-x-dag-id->bs it) nil)) (-if-let (b-err (either-from-left (org-x-dag-id->bs it) nil))
(format-error it :buffer-status b-err) (list (format-error it :buffer-status b-err))
(-when-let (n-err (-some-> (org-x-dag-id->ns it) (-when-let (n-err (-some-> (org-x-dag-id->ns it)
(either-from (either-from-left nil)))
(lambda (it) (plist-get it :msg)) (-map (lambda (e)
(-const nil)))) (format-error it :network-status (plist-get e :msg)))
(format-error it :network-status n-err)))))) n-err))))))
;; agenda/calendar ;; agenda/calendar
@ -3959,10 +3964,12 @@ FUTURE-LIMIT in a list."
(format-ns-either (format-ns-either
(id ns-either) (id ns-either)
(either-from* ns-either (either-from* ns-either
(-let (((&plist :msg :ids) it)) (->> it
(->> (-map #'org-x-dag--format-title-with-group ids) (--mapcat
(org-x-dag--indent-lines 2) (-let (((&plist :msg :ids) it))
(cons (format "Error: %s" msg)))) (->> (-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))) (org-x-dag--format-ns id it)))
(format-ns (format-ns
(id ns) (id ns)