ENH keep track of multiple errors in network status left
This commit is contained in:
parent
e8b71bc03c
commit
34817889b6
|
@ -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
|
||||||
|
|
|
@ -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))
|
|
||||||
(lambda (valid-ids)
|
|
||||||
(when valid-fun
|
(when valid-fun
|
||||||
(funcall valid-fun it cur-h valid-ids))))))))))
|
(funcall valid-fun it cur-h valid)))))))))
|
||||||
|
|
||||||
(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"))
|
||||||
(org-x-dag--ns-error nil)))
|
(either :left)))
|
||||||
(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
|
||||||
|
(->> it
|
||||||
|
(--mapcat
|
||||||
(-let (((&plist :msg :ids) it))
|
(-let (((&plist :msg :ids) it))
|
||||||
(->> (-map #'org-x-dag--format-title-with-group ids)
|
(->> (-map #'org-x-dag--format-title-with-group ids)
|
||||||
(org-x-dag--indent-lines 2)
|
(org-x-dag--indent-lines 2)
|
||||||
(cons (format "Error: %s" msg))))
|
(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)
|
||||||
|
|
Loading…
Reference in New Issue