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

REF make lefts in network status more robust (and probably solve lots of bugs)

This commit is contained in:
Nathan Dwarshuis 2022-05-09 23:29:56 -04:00
parent 65005a2f9f
commit 06fa37e30b
1 changed files with 30 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1272,8 +1272,14 @@ deadline (eg via epoch time) or if it has a repeater."
;; - scheduled: x -> plan ;; - scheduled: x -> plan
;; - active: x -> action ;; - active: x -> action
(defun org-x-dag--ns-error (msg ids) (defun org-x-dag--ns-err (msg ids)
(either :left `(:msg ,msg :ids ,ids))) (either :left `((:msg ,msg :ids ,ids))))
(defun org-x-dag--ns-errN (pairs)
(either :left (--map `(:msg ,(car it) :ids ,(cadr it)) pairs)))
(defun org-x-dag--link-err (msg id)
(either :left `(,msg ,id)))
(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)
@ -1300,17 +1306,6 @@ deadline (eg via epoch time) or if it has a repeater."
,@body ,@body
(!cdr ,links)))) (!cdr ,links))))
(defun org-x-dag-bs-error-links (msg links)
(->> (s-join ", " links)
(format "%s: %s" msg)
(either :left)))
;; (defun org-x-dag-ns-toplevel (tbl links ns)
;; (let ((h (alist-get tbl ns)))
;; (org-x-dag-each-links links
;; (ht-set h it (org-x-dag-bs-error-links "Invalid links" it-targets)))
;; ns))
(defun org-x-dag-ht-add-links (id htbl key targets) (defun org-x-dag-ht-add-links (id htbl key targets)
(let (r) (let (r)
(--each targets (--each targets
@ -1348,7 +1343,7 @@ deadline (eg via epoch time) or if it has a repeater."
(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" ,id)) (org-x-dag--link-err "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)
@ -1362,7 +1357,7 @@ deadline (eg via epoch time) or if it has a repeater."
(h valid-fun id) (h valid-fun id)
(cond (cond
((either-is-left-p (ht-get h id)) ((either-is-left-p (ht-get h id))
(either :left `("Linked to non-leaf node" ,id))) (org-x-dag--link-err "Linked to node with error" 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
@ -1383,14 +1378,14 @@ deadline (eg via epoch time) or if it has a repeater."
(group-errors (group-errors
(errors) (errors)
(->> (-group-by #'car errors) (->> (-group-by #'car errors)
(--map (list :msg (car it) :ids (-map #'cadr (cdr it)))) (--map `(,(car it) ,(-map #'cadr (cdr it))))
(either :left)))) (org-x-dag--ns-errN))))
(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))
(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))
(->> (org-x-dag--ns-error "Invalid links" invalid) (->> (org-x-dag--ns-err "Invalid links" invalid)
(ht-set cur-h it)) (ht-set cur-h it))
(-let (((valid errors) (-let (((valid errors)
(--reduce-from (reduce-valid grouped acc it) nil keypairs))) (--reduce-from (reduce-valid grouped acc it) nil keypairs)))
@ -1417,7 +1412,7 @@ deadline (eg via epoch time) or if it has a repeater."
(-let* (((&alist :lifetime l) res) (-let* (((&alist :lifetime l) res)
(d (org-x-dag-adjlist-id-planning adjlist :deadline id)) (d (org-x-dag-adjlist-id-planning adjlist :deadline id))
(ns (if (car (org-ml-timestamp-get-repeater d)) (ns (if (car (org-ml-timestamp-get-repeater d))
(either :left '((:msg "EPG has deadline with repeater"))) (org-x-dag--ns-err "EPG has deadline with repeater" nil)
(either :right `(:committed ,l :deadline ,d))))) (either :right `(:committed ,l :deadline ,d)))))
(ht-set this-h id ns) (ht-set this-h id ns)
(org-x-dag-ht-add-links id ht-l :fulfilled l)))))) (org-x-dag-ht-add-links id ht-l :fulfilled l))))))
@ -1468,8 +1463,8 @@ deadline (eg via epoch time) or if it has a repeater."
(lambda (id) (lambda (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)
(->> (list "Linked to non-committed endpoint node" id) (-> "Linked to non-committed endpoint node"
(either :left))))) (org-x-dag--link-err id)))))
((week-start week-end) weekly-span) ((week-start week-end) weekly-span)
(put-scheduled-action-maybe (put-scheduled-action-maybe
(lambda (id committed-ids) (lambda (id committed-ids)
@ -1491,10 +1486,8 @@ deadline (eg via epoch time) or if it has a repeater."
(-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))
(->> (list :msg "Action has SVG and EPG/LTG links" (-> "Action has SVG and EPG/LTG links"
:ids (append s e l)) (org-x-dag--ns-error (append s e l))))
(list)
(either :left)))
(s (s
(either :right `(:committed ,s :survivalp t))) (either :right `(:committed ,s :survivalp t)))
(t (t
@ -1545,24 +1538,25 @@ deadline (eg via epoch time) or if it has a repeater."
;; buffer status ;; buffer status
(-let (((_ time) (org-x-dag-datetime-split sched))) (-let (((_ time) (org-x-dag-datetime-split sched)))
(if time (if time
(->> (list "Linked to action with HH:MM timestamp" id) (-> "Linked to action with HH:MM timestamp"
(either :left)) (org-x-dag--link-err 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 committed-ids)) (-if-let (q (funcall get-planned committed-ids))
(to-valid id :quarterly q) (to-valid id :quarterly q)
(->> (list "Linked to scheduled action that isn't on QTP" id) (-> "Linked to scheduled action that isn't on QTP"
(either :left)))))) (org-x-dag--link-err id))))))
(-if-let (w (->> (funcall get-planned committed-ids) (-if-let (w (->> (funcall get-planned 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)
(->> (list "Linked to unscheduled action that isn't on WKP" id) (-> "Linked to unscheduled action that isn't on WKP"
(either :left)))))) (org-x-dag--link-err id))))))
(is-valid-action (is-valid-action
(lambda (id) (lambda (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 id c) (funcall is-scheduled-action id c)
(either :left (list "Linked to uncommitted action" id)))))) (-> "Linked to uncommitted action"
(org-x-dag--link-err 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)
@ -1641,10 +1635,11 @@ 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))
(either :left '(("EPG has parent with different deadline precision")))) (-> "EPG as parent with different deadline precision"
(org-x-dag--ns-err 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-err nil)))
(t (t
(either :right plist))))) (either :right plist)))))
(either :right plist)) (either :right plist))