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

FIX a bunch of bugs that screwed up projects

This commit is contained in:
Nathan Dwarshuis 2022-04-02 19:57:52 -04:00
parent 56436f7147
commit 8cc48bb484
1 changed files with 33 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1553,7 +1553,10 @@ used for optimization."
;; undone form ;; undone form
(-let* (((sched dead) (-some->> it-planning (-let* (((sched dead) (-some->> it-planning
(org-ml-get-properties '(:scheduled :deadline)))) (org-ml-get-properties '(:scheduled :deadline))))
(task-default `(:sp-task :task-active (,it-todo ,sched ,dead)))) (task-default (->> (list :todo it-todo
:sched sched
:dead dead)
(list :sp-task :task-active))))
(cond (cond
((equal it-todo org-x-kw-hold) ((equal it-todo org-x-kw-hold)
(new-proj '(:proj-held))) (new-proj '(:proj-held)))
@ -1562,12 +1565,15 @@ used for optimization."
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(org-x-dag-bs-fold-children child-bss task-default (org-x-dag-bs-fold-children child-bss task-default
(->> (pcase `(,acc ,it) (->> (pcase `(,acc ,it)
(`((:sp-task :task-active ,a) (:sp-task :task-active ,b))
(and (not (plist-get a :sched)) (plist-get b :sched)))
(`((:sp-proj :proj-active) ,_) nil) (`((:sp-proj :proj-active) ,_) nil)
(`((:sp-iter :iter-active ,_) ,_) nil) (`((:sp-iter :iter-active ,_) ,_) nil)
(`((:sp-task :task-active, _) ,_) nil) (`((:sp-task :task-active ,d) ,_) (not (plist-get d :sched)))
(`(,_ (:sp-proj :proj-active)) t) (`(,_ (:sp-proj :proj-active)) t)
(`(,_ (:sp-iter :iter-active ,_)) t) (`(,_ (:sp-iter :iter-active ,_)) t)
(`(,_ (:sp-task :task-active ,_)) t) (`(,_ (:sp-task :task-active ,d)) (plist-get d :sched))
(`((:sp-proj :proj-wait) ,_) nil) (`((:sp-proj :proj-wait) ,_) nil)
(`(,_ (:sp-proj :proj-wait)) t) (`(,_ (:sp-proj :proj-wait)) t)
@ -1589,7 +1595,7 @@ used for optimization."
(pcase acc (pcase acc
(`(:sp-proj :proj-active) t) (`(:sp-proj :proj-active) t)
(`(:sp-iter :iter-active ,_) t) (`(:sp-iter :iter-active ,_) t)
(`(:sp-task :task-active ,_) t) (`(:sp-task :task-active ,d) (plist-get d :sched))
(_ nil)) (_ nil))
;; child -> parent translation ;; child -> parent translation
@ -1601,16 +1607,17 @@ used for optimization."
(`(:sp-proj . ,s) (new-proj s)) (`(:sp-proj . ,s) (new-proj s))
(`(:sp-iter :iter-active ,_) (new-proj '(:proj-active))) (`(:sp-iter :iter-active ,_) (new-proj '(:proj-active)))
(`(:sp-iter :iter-empty) (new-proj '(:proj-stuck))) (`(:sp-iter :iter-empty) (new-proj '(:proj-stuck)))
(`(:sp-task :task-active (,c-todo ,c-sched ,_)) (`(:sp-task :task-active ,d)
(cond (-let (((&plist :todo o :sched s) d))
((equal c-todo org-x-kw-todo) (->> (if c-sched :proj-active (cond
:proj-stuck) ((equal o org-x-kw-todo) (->> (if s :proj-active
(list) :proj-stuck)
(new-proj))) (list)
((equal c-todo org-x-kw-next) (new-proj '(:proj-active))) (new-proj)))
((equal c-todo org-x-kw-wait) (new-proj '(:proj-wait))) ((equal o org-x-kw-next) (new-proj '(:proj-active)))
((equal c-todo org-x-kw-hold) (new-proj '(:proj-hold))) ((equal o org-x-kw-wait) (new-proj '(:proj-wait)))
(t (org-x-dag-bs-error-kw "Task action" c-todo))))))) ((equal o org-x-kw-hold) (new-proj '(:proj-hold)))
(t (org-x-dag-bs-error-kw "Task action" o))))))))
(child-bss (child-bss
(org-x-dag-bs-error-kw "Project action" it-todo)) (org-x-dag-bs-error-kw "Project action" it-todo))
(t (t
@ -2217,12 +2224,12 @@ used for optimization."
(cl-labels (cl-labels
((propagate ((propagate
(adjlist htbl id to-set) (adjlist htbl id to-set)
(->> (-if-let (node (ht-get htbl id))
(org-x-dag-bs-fmap node
(funcall set-fun it to-set))
(org-x-dag-bs :valid (funcall def-fun to-set)))
(ht-set htbl id))
(--each (org-x-dag-get-children adjlist id) (--each (org-x-dag-get-children adjlist id)
(->> (-if-let (node (ht-get htbl it))
(org-x-dag-bs-fmap node
(funcall set-fun it to-set))
(org-x-dag-bs :valid (funcall def-fun to-set)))
(ht-set htbl it))
(propagate adjlist htbl it to-set)))) (propagate adjlist htbl it to-set))))
(let ((h (alist-get h-key ns))) (let ((h (alist-get h-key ns)))
(-each (ht-keys h) (-each (ht-keys h)
@ -3151,16 +3158,15 @@ except it ignores inactive timestamps."
(id status-data) (id status-data)
;; NOTE in the future there might be more than just the car to this ;; NOTE in the future there might be more than just the car to this
(let ((status (car status-data))) (let ((status (car status-data)))
(unless (eq status :proj-complete) (-when-let (priority (cl-case status
(:proj-active 4)
(:proj-wait 3)
(:proj-hold 2)
(:proj-stuck 1)))
(pcase (org-x-dag-id->ns id) (pcase (org-x-dag-id->ns id)
(`(:valid ,v) (`(:valid ,v)
(when (plist-get v :committed) (when (plist-get v :committed)
(let ((tags (org-x-dag-id->tags nil id)) (let ((tags (org-x-dag-id->tags nil id)))
(priority (cl-case status
(:proj-active 4)
(:proj-wait 3)
(:proj-hold 2)
(:proj-stuck 1))))
(-> (org-x-dag-format-tag-node tags id) (-> (org-x-dag-format-tag-node tags id)
(org-add-props nil (org-add-props nil
'x-toplevelp (org-x-dag-id->is-toplevel-p id) 'x-toplevelp (org-x-dag-id->is-toplevel-p id)
@ -3227,7 +3233,7 @@ except it ignores inactive timestamps."
(cl-flet (cl-flet
((format-key ((format-key
(id s) (id s)
(-let (((todo sched dead) s)) (-let (((&plist :todo :sched :dead) s))
(pcase (org-x-dag-id->ns id) (pcase (org-x-dag-id->ns id)
(`(:valid ,ns) (`(:valid ,ns)
(-let (((&plist :committed c) ns)) (-let (((&plist :committed c) ns))