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

ENH update task-with-goal display

This commit is contained in:
Nathan Dwarshuis 2022-04-03 13:02:10 -04:00
parent d5536d7659
commit 16e179a261
1 changed files with 196 additions and 268 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -26,6 +26,7 @@
(require 'org-ml) (require 'org-ml)
(require 'dash) (require 'dash)
(require 'dag) (require 'dag)
(require 'either)
(require 'ht) (require 'ht)
;;; DATE/TIME FUNCTIONS ;;; DATE/TIME FUNCTIONS
@ -1424,64 +1425,38 @@ used for optimization."
(!cons (car res) acc)) (!cons (car res) acc))
acc))) acc)))
;; type BS a = Either String a
(defmacro org-x-dag-bs (key data)
(pcase key
((or :error :valid) `(list ,key ,data))
(e (error "Invalid status key: %s" key))))
(defmacro org-x-dag-bs>>= (bs form)
(declare (indent 1))
`(pcase ,bs
(`(:error ,_) ,bs)
(`(:valid ,it) ,form)
(e (error "Learn to use monads, dummy; this isn't one: %s" e))))
(defmacro org-x-dag-bs-fmap (bs form)
(declare (indent 1))
(let ((b (make-symbol "--bs")))
`(let ((,b ,bs))
(pcase ,b
(`(:error ,_) ,b)
(`(:valid ,it) (org-x-dag-bs :valid ,form))
(e (error "Learn to use functors, dummy; this isn't one: %s" e))))))
(defun org-x-dag-bs-error-p (bs)
(eq (car bs) :error))
;; [Status a] -> b -> (a -> a -> Status Bool) -> (a -> Bool) -> (a -> Status b) ;; [Status a] -> b -> (a -> a -> Status Bool) -> (a -> Bool) -> (a -> Status b)
;; -> Status b ;; -> Status b
(defmacro org-x-dag-bs-fold-children (bss default rank-form stop-form trans-form) (defmacro org-x-dag-bs-fold-children (bss default rank-form stop-form trans-form)
(declare (indent 2)) (declare (indent 2))
(let ((err (org-x-dag-bs :error "Child error"))) (let ((err (either :left "Child error")))
`(if ,bss `(if ,bss
(-let (((x . xs) ,bss)) (-let (((x . xs) ,bss))
;; (if (org-x-dag-bs-error-p x) (progn (print x) ',err) ;; (if (org-x-dag-bs-is-left-p x) (progn (print x) ',err)
(if (org-x-dag-bs-error-p x) ',err (if (either-is-left-p x) ',err
(let ((acc (cadr x)) r final) (let ((acc (cadr x)) r final)
(while (and (not final) xs) (while (and (not final) xs)
(setq x (car xs)) (setq x (car xs))
(if (org-x-dag-bs-error-p x) (if (either-is-left-p x)
(setq final ',err) (setq final ',err)
(setq it (cadr x) (setq it (cadr x)
r ,rank-form) r ,rank-form)
(unless r (unless r
(error "You forgot the difference between Maybe and Either")) (error "You forgot the difference between Maybe and Either"))
(if (org-x-dag-bs-error-p r) (if (either-is-left-p r)
(setq final r) (setq final r)
(when (cadr r) (when (cadr r)
(setq acc (cadr x))) (setq acc (cadr x)))
(if ,stop-form (if ,stop-form
(setq final (org-x-dag-bs :valid acc)) (setq final (either :right acc))
(!cdr xs))))) (!cdr xs)))))
(when (not final) (when (not final)
(setq final (org-x-dag-bs :valid acc))) (setq final (either :right acc)))
(org-x-dag-bs>>= final ,trans-form)))) (either>>= final ,trans-form))))
(org-x-dag-bs :valid ,default)))) (either :right ,default))))
(defun org-x-dag-bs-error-kw (type-name kw) (defun org-x-dag-bs-error-kw (type-name kw)
(->> (format "%ss cannot have keyword '%s" type-name kw) (either :left (format "%ss cannot have keyword '%s" type-name kw)))
(org-x-dag-bs :error)))
(defmacro org-x-dag-bs-action-with-closed (node-data type-name canc-bs-form (defmacro org-x-dag-bs-action-with-closed (node-data type-name canc-bs-form
done-form open-form) done-form open-form)
@ -1499,17 +1474,16 @@ used for optimization."
(cond (cond
((equal it-todo org-x-kw-canc) ((equal it-todo org-x-kw-canc)
(let ((it-comptime (complete-time ,c t))) (let ((it-comptime (complete-time ,c t)))
(org-x-dag-bs :valid ,canc-bs-form))) (either :right ,canc-bs-form)))
((equal it-todo org-x-kw-done) ((equal it-todo org-x-kw-done)
(let ((it-comptime (complete-time ,c nil))) (let ((it-comptime (complete-time ,c nil)))
,done-form)) ,done-form))
(t (t
(->> (format "Closed %s must be marked CANC/DONE" ,type-name) (->> (format "Closed %s must be marked CANC/DONE" ,type-name)
(org-x-dag-bs :error)))) (either :left))))
(cond (cond
((member it-todo org-x-done-keywords) ((member it-todo org-x-done-keywords)
(->> (format "DONE/CANC %s must be closed" ,type-name) (either :left (format "DONE/CANC %s must be closed" ,type-name)))
(org-x-dag-bs :error)))
(t (t
,open-form))))))) ,open-form)))))))
@ -1517,7 +1491,7 @@ used for optimization."
(cl-flet (cl-flet
((new-proj ((new-proj
(status) (status)
(org-x-dag-bs :valid `(:sp-proj ,@status))) (either :right `(:sp-proj ,@status)))
(is-next (is-next
(task-data) (task-data)
(-let (((&plist :todo :sched) task-data)) (-let (((&plist :todo :sched) task-data))
@ -1542,7 +1516,7 @@ used for optimization."
(`(,_ (:sp-iter :iter-complete ,_)) nil) (`(,_ (:sp-iter :iter-complete ,_)) nil)
(`(,_ (:sp-task :task-complete ,_)) nil) (`(,_ (:sp-task :task-complete ,_)) nil)
(e (error "Unmatched pattern: %S" e))) (e (error "Unmatched pattern: %S" e)))
(org-x-dag-bs :valid)) (either :right))
(pcase acc (pcase acc
(`(:sp-proj :proj-complete ,_) nil) (`(:sp-proj :proj-complete ,_) nil)
(`(:sp-iter :iter-complete ,_) nil) (`(:sp-iter :iter-complete ,_) nil)
@ -1552,8 +1526,8 @@ used for optimization."
((or `(:sp-proj :proj-complete ,_) ((or `(:sp-proj :proj-complete ,_)
`(:sp-iter :iter-complete ,_) `(:sp-iter :iter-complete ,_)
`(:sp-task :task-complete ,_)) `(:sp-task :task-complete ,_))
(org-x-dag-bs :valid `(:sp-proj :proj-complete ,it-comptime))) (either :right `(:sp-proj :proj-complete ,it-comptime)))
(_ (org-x-dag-bs :error "Completed projects cannot have active children")))) (_ (either :left "Completed projects cannot have active children"))))
;; undone form ;; undone form
(-let* (((sched dead) (-some->> it-planning (-let* (((sched dead) (-some->> it-planning
@ -1566,7 +1540,7 @@ used for optimization."
((and child-bss (equal it-todo org-x-kw-hold)) ((and child-bss (equal it-todo org-x-kw-hold))
(new-proj '(:proj-held))) (new-proj '(:proj-held)))
((and child-bss sched) ((and child-bss sched)
(org-x-dag-bs :error "Projects cannot be scheduled")) (either :left "Projects cannot be scheduled"))
((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)
@ -1612,7 +1586,7 @@ used for optimization."
;; any pair that makes it this far is completed in both, which means ;; any pair that makes it this far is completed in both, which means
;; neither takes precedence, which means choose the left one ;; neither takes precedence, which means choose the left one
(`(,_ ,_) nil)) (`(,_ ,_) nil))
(org-x-dag-bs :valid)) (either :right))
;; early stop ;; early stop
(pcase acc (pcase acc
@ -1626,7 +1600,7 @@ used for optimization."
((or `(:sp-proj :proj-complete ,_) ((or `(:sp-proj :proj-complete ,_)
`(:sp-task :task-complete ,_) `(:sp-task :task-complete ,_)
`(:sp-iter :iter-complete ,_)) `(:sp-iter :iter-complete ,_))
(org-x-dag-bs :error "Active projects must have at least one active child")) (either :left "Active projects must have at least one active child"))
(`(: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)))
@ -1644,7 +1618,7 @@ used for optimization."
(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
(org-x-dag-bs :valid task-default))))))) (either :right task-default)))))))
(defun org-x-dag-node-data-is-iterator-p (node-data) (defun org-x-dag-node-data-is-iterator-p (node-data)
(-let (((&plist :props) node-data)) (-let (((&plist :props) node-data))
@ -1662,16 +1636,16 @@ used for optimization."
(`((:si-complete ,_) ,_) t) (`((:si-complete ,_) ,_) t)
(`(,_ (:si-complete ,_)) nil) (`(,_ (:si-complete ,_)) nil)
(e (error "Unmatched pattern: %S" e))) (e (error "Unmatched pattern: %S" e)))
(org-x-dag-bs :valid)) (either :right))
(pcase acc (pcase acc
(`(:si-complete ,_) nil) (`(:si-complete ,_) nil)
(_ t)) (_ t))
(pcase it (pcase it
(`(:si-complete ,_) (`(:si-complete ,_)
(org-x-dag-bs :valid `(,comp-key ,comptime))) (either :right `(,comp-key ,comptime)))
(_ (_
(->> (format "Completed %s cannot have active children" type-name) (->> (format "Completed %s cannot have active children" type-name)
(org-x-dag-bs :error)))))) (either :left))))))
(defun org-x-dag-bs-action-subiter-todo-fold (child-bss type-name active-key default) (defun org-x-dag-bs-action-subiter-todo-fold (child-bss type-name active-key default)
(org-x-dag-bs-fold-children child-bss default (org-x-dag-bs-fold-children child-bss default
@ -1682,35 +1656,35 @@ used for optimization."
(cond (cond
((or (xor as bs) (xor ad bd)) ((or (xor as bs) (xor ad bd))
(->> "All sub-iters must have the same planning configuration" (->> "All sub-iters must have the same planning configuration"
(org-x-dag-bs :error))) (either :left)))
((and as bs (xor (org-ml-time-is-long as) (org-ml-time-is-long bs))) ((and as bs (xor (org-ml-time-is-long as) (org-ml-time-is-long bs)))
(->> "Sub-iters must have scheduled timestamp with same length" (->> "Sub-iters must have scheduled timestamp with same length"
(org-x-dag-bs :error))) (either :left)))
((and ad bd (xor (org-ml-time-is-long ad) (org-ml-time-is-long bd))) ((and ad bd (xor (org-ml-time-is-long ad) (org-ml-time-is-long bd)))
(->> "Sub-iters must have deadline timestamp with same length" (->> "Sub-iters must have deadline timestamp with same length"
(org-x-dag-bs :error))) (either :left)))
;; ASSUME this won't fail since the datetimes are assumed to be the ;; ASSUME this won't fail since the datetimes are assumed to be the
;; same length as per rules above ;; same length as per rules above
((and ad bd) ((and ad bd)
(->> (org-x-dag-datetime< (org-ml-timestamp-get-start-time ad) (->> (org-x-dag-datetime< (org-ml-timestamp-get-start-time ad)
(org-ml-timestamp-get-start-time bd)) (org-ml-timestamp-get-start-time bd))
(org-x-dag-bs :valid))) (either :right)))
(t (t
(->> (org-x-dag-datetime< (org-ml-timestamp-get-start-time as) (->> (org-x-dag-datetime< (org-ml-timestamp-get-start-time as)
(org-ml-timestamp-get-start-time bs)) (org-ml-timestamp-get-start-time bs))
(org-x-dag-bs :valid)))))) (either :right))))))
(`((:si-active ,_) ,_) (org-x-dag-bs :valid nil)) (`((:si-active ,_) ,_) (either :right nil))
(`(,_ (:si-active ,_)) (org-x-dag-bs :valid t)) (`(,_ (:si-active ,_)) (either :right t))
(`(,_ ,_) (org-x-dag-bs :valid nil))) (`(,_ ,_) (either :right nil)))
(pcase acc (pcase acc
(`(:si-active ,_) t) (`(:si-active ,_) t)
(_ nil)) (_ nil))
(pcase it (pcase it
(`(:si-complete ,_) (`(:si-complete ,_)
(->> (format "Active %s must have at least one active child" type-name) (->> (format "Active %s must have at least one active child" type-name)
(org-x-dag-bs :error))) (either :left)))
(`(:si-active ,ts-data) (`(:si-active ,ts-data)
(org-x-dag-bs :valid `(,active-key ,ts-data)))))) (either :right `(,active-key ,ts-data))))))
(defun org-x-dag-node-is-iterator-p (node) (defun org-x-dag-node-is-iterator-p (node)
(org-x-dag-node-data-is-iterator-p (plist-get node :node-meta))) (org-x-dag-node-data-is-iterator-p (plist-get node :node-meta)))
@ -1724,13 +1698,13 @@ used for optimization."
(org-ml-get-properties '(:scheduled :deadline))))) (org-ml-get-properties '(:scheduled :deadline)))))
(cond (cond
((and sched child-bss) ((and sched child-bss)
(org-x-dag-bs :error "Sub-iterators with children cannot be scheduled")) (either :left "Sub-iterators with children cannot be scheduled"))
((and dead child-bss) ((and dead child-bss)
(org-x-dag-bs :error "Sub-iterators with children cannot be deadlined")) (either :left "Sub-iterators with children cannot be deadlined"))
;; ((and (not child-bss) (not (xor sched dead))) ;; ((and (not child-bss) (not (xor sched dead)))
;; (org-x-dag-bs :error "Sub-iterators must either be deadlined or scheduled")) ;; (either :left "Sub-iterators must either be deadlined or scheduled"))
((org-x-dag-node-data-is-iterator-p node-data) ((org-x-dag-node-data-is-iterator-p node-data)
(org-x-dag-bs :error "Iterators cannot be nested")) (either :left "Iterators cannot be nested"))
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(org-x-dag-bs-action-subiter-todo-fold child-bss (org-x-dag-bs-action-subiter-todo-fold child-bss
"sub-iterator" :si-active "sub-iterator" :si-active
@ -1745,7 +1719,7 @@ used for optimization."
"iterators" :iter-complete) "iterators" :iter-complete)
(cond (cond
((and child-bss (-some->> it-planning (org-ml-get-property :scheduled))) ((and child-bss (-some->> it-planning (org-ml-get-property :scheduled)))
(org-x-dag-bs :error "Iterators cannot be scheduled")) (either :left "Iterators cannot be scheduled"))
;; TODO also check for timeshift and archive props ;; TODO also check for timeshift and archive props
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(org-x-dag-bs-action-subiter-todo-fold child-bss (org-x-dag-bs-action-subiter-todo-fold child-bss
@ -1762,17 +1736,17 @@ used for optimization."
(`((:complete ,_) (:complete ,_)) nil) (`((:complete ,_) (:complete ,_)) nil)
(`(,_ (:complete ,_)) nil) (`(,_ (:complete ,_)) nil)
(`((:complete ,_) ,_) t)) (`((:complete ,_) ,_) t))
(org-x-dag-bs :valid)) (either :right))
(pcase acc (pcase acc
(`(:complete ,_) nil) (`(:complete ,_) nil)
(_ t)) (_ t))
(pcase it (pcase it
(`(:complete ,_) (`(:complete ,_)
(org-x-dag-bs :valid `(:complete ,it-comptime))) (either :right `(:complete ,it-comptime)))
(_ (org-x-dag-bs :error "Completed EPGs cannot have active children")))) (_ (either :left "Completed EPGs cannot have active children"))))
(cond (cond
((-some->> it-planning (org-ml-get-property :scheduled)) ((-some->> it-planning (org-ml-get-property :scheduled))
(org-x-dag-bs :error "EPGs cannot be scheduled")) (either :left "EPGs cannot be scheduled"))
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(let ((dead (-some->> it-planning (org-ml-get-property :deadline)))) (let ((dead (-some->> it-planning (org-ml-get-property :deadline))))
(org-x-dag-bs-fold-children child-bss `(:active ,dead) (org-x-dag-bs-fold-children child-bss `(:active ,dead)
@ -1780,7 +1754,7 @@ used for optimization."
(`((:active ,_) (:active ,_)) nil) (`((:active ,_) (:active ,_)) nil)
(`(,_ (:active ,_)) t) (`(,_ (:active ,_)) t)
(`((:active ,_) ,_) nil)) (`((:active ,_) ,_) nil))
(org-x-dag-bs :valid)) (either :right))
nil nil
(pcase it (pcase it
(`(:active ,c-dead) (`(:active ,c-dead)
@ -1794,13 +1768,13 @@ used for optimization."
(org-ml-time-to-unixtime)))) (org-ml-time-to-unixtime))))
(cond (cond
((and c-epoch p-epoch (<= c-epoch p-epoch)) ((and c-epoch p-epoch (<= c-epoch p-epoch))
(org-x-dag-bs :valid `(:active ,dead))) (either :right `(:active ,dead)))
((not dead) ((not dead)
(org-x-dag-bs :valid `(:active ,c-dead))) (either :right `(:active ,c-dead)))
(t (t
(org-x-dag-bs :error "Child deadlines must be before parent deadlines"))))) (either :left "Child deadlines must be before parent deadlines")))))
(_ (_
(org-x-dag-bs :error "Active EPGs must have at least one active child")))))) (either :left "Active EPGs must have at least one active child"))))))
(t (t
(org-x-dag-bs-error-kw "Endpoint goal" it-todo))))) (org-x-dag-bs-error-kw "Endpoint goal" it-todo)))))
@ -1808,14 +1782,14 @@ used for optimization."
(declare (indent 3)) (declare (indent 3))
(-let* (((node . children) tree) (-let* (((node . children) tree)
((&plist :id i :parents ps :node-meta m) node) ((&plist :id i :parents ps :node-meta m) node)
(this (->> (org-x-dag-bs :error "Children not allowed") (this (->> (either :left "Children not allowed")
(org-x-dag-node i ps m)))) (org-x-dag-node i ps m))))
(cons this (--mapcat (org-x-dag-bs-with-treetop-error it) children)))) (cons this (--mapcat (org-x-dag-bs-with-treetop-error it) children))))
(defun org-x-dag-bs-with-treetop (tree node-fun) (defun org-x-dag-bs-with-treetop (tree node-fun)
(declare (indent 3)) (declare (indent 3))
(-let* ((((&plist :id i :parents ps :node-meta m) . children) tree) (-let* ((((&plist :id i :parents ps :node-meta m) . children) tree)
(bs (if children (org-x-dag-bs :error "Children not allowed") (bs (if children (either :left "Children not allowed")
(funcall node-fun m))) (funcall node-fun m)))
(top (org-x-dag-node i ps m bs))) (top (org-x-dag-node i ps m bs)))
(cons top (--mapcat (org-x-dag-bs-with-treetop-error it) children)))) (cons top (--mapcat (org-x-dag-bs-with-treetop-error it) children))))
@ -1876,7 +1850,7 @@ used for optimization."
tree tree
#'org-x-dag-bs-action-subiter #'org-x-dag-bs-action-subiter
(lambda (node-data child-bss) (lambda (node-data child-bss)
(org-x-dag-bs-fmap (org-x-dag-bs-action-iter-inner node-data child-bss) (either<$> (org-x-dag-bs-action-iter-inner node-data child-bss)
(cons :sp-proj it))))) (cons :sp-proj it)))))
(defun org-x-dag-bs-action-project (tree) (defun org-x-dag-bs-action-project (tree)
@ -1894,8 +1868,7 @@ used for optimization."
((lift-subiter ((lift-subiter
(node) (node)
(org-x-dag-node-fmap node (org-x-dag-node-fmap node
(org-x-dag-bs-fmap it (either<$> it (cons :sp-subiter it)))))
(cons :sp-subiter it)))))
(-let (((p (ps is)) (org-x-dag-bs-action-project node-tree))) (-let (((p (ps is)) (org-x-dag-bs-action-project node-tree)))
`(,p ,@ps ,@(-map #'lift-subiter is))))) `(,p ,@ps ,@(-map #'lift-subiter is)))))
@ -1906,7 +1879,7 @@ used for optimization."
#'org-x-dag-bs-epg-inner)) #'org-x-dag-bs-epg-inner))
(defun org-x-dag-bs-prefix (key nodes) (defun org-x-dag-bs-prefix (key nodes)
(--map (org-x-dag-node-fmap it (org-x-dag-bs-fmap it `(,key ,it))) nodes)) (--map (org-x-dag-node-fmap it (either<$> it `(,key ,it))) nodes))
(defun org-x-dag-bs-epg (tree) (defun org-x-dag-bs-epg (tree)
(-let (((n ns) (org-x-dag-bs-epg-outer tree))) (-let (((n ns) (org-x-dag-bs-epg-outer tree)))
@ -1916,12 +1889,11 @@ used for optimization."
(-let (((&plist :planning :todo) node-data)) (-let (((&plist :planning :todo) node-data))
(cond (cond
(planning (planning
(->> (format "%ss cannot have planning elements" type-name) (either :left (format "%ss cannot have planning elements" type-name)))
(org-x-dag-bs :error))) ((either-lefts child-bss)
((-any #'org-x-dag-bs-error-p child-bss) (either :left "Child error"))
(org-x-dag-bs :error "Child error"))
((equal todo org-x-kw-todo) ((equal todo org-x-kw-todo)
(org-x-dag-bs :valid '(:active))) (either :right '(:active)))
(t (t
(org-x-dag-bs-error-kw type-name todo))))) (org-x-dag-bs-error-kw type-name todo)))))
@ -1948,10 +1920,10 @@ used for optimization."
(defun org-x-dag-bs-qtp-inner (node-data) (defun org-x-dag-bs-qtp-inner (node-data)
(org-x-dag-bs-action-with-closed node-data "quarterly plan" (org-x-dag-bs-action-with-closed node-data "quarterly plan"
`(:complete ,it-comptime) `(:complete ,it-comptime)
(org-x-dag-bs :valid `(:complete ,it-comptime)) (either :right `(:complete ,it-comptime))
(cond (cond
((-some->> it-planning (org-ml-get-properties :scheduled)) ((-some->> it-planning (org-ml-get-properties :scheduled))
(org-x-dag-bs :error "QTPs cannot be scheduled")) (either :left "QTPs cannot be scheduled"))
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(-if-let (dead (-some->> it-planning (org-ml-get-properties :deadline))) (-if-let (dead (-some->> it-planning (org-ml-get-properties :deadline)))
(-let* (((&plist :tags) node-data) (-let* (((&plist :tags) node-data)
@ -1960,47 +1932,47 @@ used for optimization."
(org-x-dag-datetime-split) (org-x-dag-datetime-split)
(car)))) (car))))
(if (org-x-dag-datetime< tag-date dead-dt) (if (org-x-dag-datetime< tag-date dead-dt)
(org-x-dag-bs :valid `(:active ,dead)) (either :right `(:active ,dead))
(->> "QTP deadlines must be due after the quarter starts" (->> "QTP deadlines must be due after the quarter starts"
(org-x-dag-bs :error)))) (either :left))))
(org-x-dag-bs :valid '(:active nil)))) (either :right '(:active nil))))
(t (t
(org-x-dag-bs-error-kw "QTP" it-todo))))) (org-x-dag-bs-error-kw "QTP" it-todo)))))
(defun org-x-dag-bs-wkp-inner (node-data) (defun org-x-dag-bs-wkp-inner (node-data)
(org-x-dag-bs-action-with-closed node-data "weekly plan" (org-x-dag-bs-action-with-closed node-data "weekly plan"
`(:complete ,it-comptime) `(:complete ,it-comptime)
(org-x-dag-bs :valid `(:complete ,it-comptime)) (either :right `(:complete ,it-comptime))
(cond (cond
((-some->> it-planning (org-ml-get-properties :scheduled)) ((-some->> it-planning (org-ml-get-properties :scheduled))
(org-x-dag-bs :error "WKPs cannot be scheduled")) (either :left "WKPs cannot be scheduled"))
((-some->> it-planning (org-ml-get-properties :deadline)) ((-some->> it-planning (org-ml-get-properties :deadline))
(org-x-dag-bs :error "WKPs cannot be deadlined")) (either :left "WKPs cannot be deadlined"))
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(org-x-dag-bs :valid `(:active))) (either :right `(:active)))
(t (t
(org-x-dag-bs-error-kw "WKP" it-todo))))) (org-x-dag-bs-error-kw "WKP" it-todo)))))
(defun org-x-dag-bs-dlp-inner (node-data) (defun org-x-dag-bs-dlp-inner (node-data)
(org-x-dag-bs-action-with-closed node-data "daily metablock" (org-x-dag-bs-action-with-closed node-data "daily metablock"
`(:complete ,it-comptime) `(:complete ,it-comptime)
(org-x-dag-bs :valid `(:complete ,it-comptime)) (either :right `(:complete ,it-comptime))
(cond (cond
((-some->> it-planning (org-ml-get-properties :deadline)) ((-some->> it-planning (org-ml-get-properties :deadline))
(org-x-dag-bs :error "Daily metablocks cannot be deadlined")) (either :left "Daily metablocks cannot be deadlined"))
((equal it-todo org-x-kw-todo) ((equal it-todo org-x-kw-todo)
(-if-let ((sched-date sched-time) (-some->> it-planning (-if-let ((sched-date sched-time) (-some->> it-planning
(org-ml-get-property :scheduled) (org-ml-get-property :scheduled)
(org-ml-timestamp-get-start-time) (org-ml-timestamp-get-start-time)
(org-x-dag-datetime-split))) (org-x-dag-datetime-split)))
(if (not sched-time) (if (not sched-time)
(org-x-dag-bs :error "Daily metablocks must have scheduled time") (either :left "Daily metablocks must have scheduled time")
(-let* (((&plist :tags) node-data) (-let* (((&plist :tags) node-data)
(tag-date (org-x-dag-daily-tags-to-date tags))) (tag-date (org-x-dag-daily-tags-to-date tags)))
(if (org-x-dag-datetime= tag-date sched-date) (if (org-x-dag-datetime= tag-date sched-date)
(org-x-dag-bs :valid `(:active)) (either :right `(:active))
(org-x-dag-bs :error "Daily metablocks must be scheduled within their date")))) (either :left "Daily metablocks must be scheduled within their date"))))
(org-x-dag-bs :error "Daily metablocks must be scheduled"))) (either :left "Daily metablocks must be scheduled")))
(t (t
(org-x-dag-bs-error-kw "Daily metablock" it-todo))))) (org-x-dag-bs-error-kw "Daily metablock" it-todo)))))
@ -2076,7 +2048,7 @@ used for optimization."
(defun org-x-dag-bs-error-links (msg links) (defun org-x-dag-bs-error-links (msg links)
(->> (s-join ", " links) (->> (s-join ", " links)
(format "%s: %s" msg) (format "%s: %s" msg)
(org-x-dag-bs :error))) (either :left)))
(defun org-x-dag-ns-toplevel (tbl adjlist links ns) (defun org-x-dag-ns-toplevel (tbl adjlist links ns)
(let ((h (alist-get tbl ns))) (let ((h (alist-get tbl ns)))
@ -2094,9 +2066,9 @@ used for optimization."
(let (r) (let (r)
(--each targets (--each targets
(->> (if (setq r (ht-get htbl it)) (->> (if (setq r (ht-get htbl it))
(org-x-dag-bs-fmap r (either<$> r
(org-x-dag-plist-cons it key id)) (org-x-dag-plist-cons it key id))
(org-x-dag-bs :valid `(,key (,id)))) (either :right `(,key (,id))))
(ht-set htbl it))))) (ht-set htbl it)))))
(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)
@ -2109,7 +2081,7 @@ used for optimization."
(parent-group (parent-group
(h checkleafp adjlist id) (h checkleafp adjlist id)
(cond (cond
((org-x-dag-bs-error-p (ht-get h id)) ((either-is-left-p (ht-get h id))
:error) :error)
((and checkleafp (not (org-x-dag-get-children adjlist id))) ((and checkleafp (not (org-x-dag-get-children adjlist id)))
:non-leaf) :non-leaf)
@ -2149,14 +2121,13 @@ used for optimization."
'((:lifetime)) '((:lifetime))
(lambda (id this-h res) (lambda (id this-h res)
(-let (((&alist :lifetime l) res)) (-let (((&alist :lifetime l) res))
(ht-set this-h id (org-x-dag-bs :valid `(:committed ,l))) (ht-set this-h id (either :right `(:committed ,l)))
(org-x-dag-ht-add-links id ht-l :fulfilled l)))) (org-x-dag-ht-add-links id ht-l :fulfilled l))))
ns)) ns))
(defun org-x-dag-ht-get-maybe (htbl id key) (defun org-x-dag-ht-get-maybe (htbl id key)
(pcase (ht-get htbl id) (either-from-right (ht-get htbl id) nil
(`(:error ,_) nil) (plist-get it key)))
(`(:valid ,c) (plist-get c key))))
(defun org-x-dag-ns-qtp (adjlist links ns) (defun org-x-dag-ns-qtp (adjlist links ns)
(-let (((&alist :lifetime ht-l :endpoint ht-e :quarterly ht-q) ns)) (-let (((&alist :lifetime ht-l :endpoint ht-e :quarterly ht-q) ns))
@ -2164,7 +2135,7 @@ used for optimization."
'((:lifetime) (:endpoint)) '((:lifetime) (:endpoint))
(lambda (id this-h res) (lambda (id this-h res)
(-let (((&alist :lifetime l :endpoint e) res)) (-let (((&alist :lifetime l :endpoint e) res))
(ht-set this-h id (org-x-dag-bs :valid `(:committed (,@e ,@l)))) (ht-set this-h id (either :right `(:committed (,@e ,@l))))
(->> (--mapcat (org-x-dag-ht-get-maybe ht-e it :committed) e) (->> (--mapcat (org-x-dag-ht-get-maybe ht-e it :committed) e)
(org-x-dag-ht-add-links id ht-l :planned)) (org-x-dag-ht-add-links id ht-l :planned))
(org-x-dag-ht-add-links id ht-e :planned e) (org-x-dag-ht-add-links id ht-e :planned e)
@ -2177,7 +2148,7 @@ used for optimization."
'((:quarterly)) '((:quarterly))
(lambda (id this-h res) (lambda (id this-h res)
(-let (((&alist :quarterly q) res)) (-let (((&alist :quarterly q) res))
(ht-set this-h id (org-x-dag-bs :valid `(:committed ,q))) (ht-set this-h id (either :right `(:committed ,q)))
(org-x-dag-ht-add-links id ht-q :planned q)))) (org-x-dag-ht-add-links id ht-q :planned q))))
ns)) ns))
@ -2191,11 +2162,11 @@ used for optimization."
(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"
(org-x-dag-bs :error))) (either :left)))
(s (s
(org-x-dag-bs :valid `(:committed ,s :survivalp t))) (either :right `(:committed ,s :survivalp t)))
(t (t
(org-x-dag-bs :valid `(:committed (,@e ,@l) :survivalp nil)))))) (either :right `(:committed (,@e ,@l) :survivalp nil))))))
(ht-set this-h id this-ns) (ht-set this-h id this-ns)
(org-x-dag-ht-add-links id ht-l :fulfilled l) (org-x-dag-ht-add-links id ht-l :fulfilled l)
(org-x-dag-ht-add-links id ht-s :fulfilled s) (org-x-dag-ht-add-links id ht-s :fulfilled s)
@ -2224,13 +2195,13 @@ used for optimization."
(->> (list :scheduled w (->> (list :scheduled w
:committed (-uniq gs) :committed (-uniq gs)
:active a) :active a)
(org-x-dag-bs :valid) (either :right)
(ht-set this-h id)) (ht-set this-h id))
;; TODO add the goals to their goal links? (this might be ;; TODO add the goals to their goal links? (this might be
;; useful later when displaying) ;; useful later when displaying)
(org-x-dag-ht-add-links id ht-w :planned w) (org-x-dag-ht-add-links id ht-w :planned w)
(org-x-dag-ht-add-links id ht-a :planned a)) (org-x-dag-ht-add-links id ht-a :planned a))
(->> (org-x-dag-bs :error "Non overlapping goals") (->> (either :left "Non overlapping goals")
(ht-set ht-d id))))))) (ht-set ht-d id)))))))
ns))) ns)))
@ -2248,9 +2219,9 @@ used for optimization."
((propagate ((propagate
(adjlist htbl id to-set) (adjlist htbl id to-set)
(->> (-if-let (node (ht-get htbl id)) (->> (-if-let (node (ht-get htbl id))
(org-x-dag-bs-fmap node (either<$> node
(funcall set-fun it to-set)) (funcall set-fun it to-set))
(org-x-dag-bs :valid (funcall def-fun to-set))) (either :right (funcall def-fun to-set)))
(ht-set htbl id)) (ht-set htbl id))
(--each (org-x-dag-get-children adjlist id) (--each (org-x-dag-get-children adjlist id)
(propagate adjlist htbl it to-set)))) (propagate adjlist htbl it to-set))))
@ -2281,15 +2252,12 @@ used for optimization."
;; TODO there isn't a better way to do this? (seems like I'm ;; TODO there isn't a better way to do this? (seems like I'm
;; accessing either/maybe types too many times) ;; accessing either/maybe types too many times)
((n* rs*) (-if-let (n (ht-get htbl id)) ((n* rs*) (-if-let (n (ht-get htbl id))
(pcase n (either-from n
(`(:error ,_) (list n rs)) `(,n ,rs)
(`(:valid ,v) (let ((p (org-x-dag-plist-map it s-key
(let ((p (org-x-dag-plist-map v s-key (lambda (x) (append x rs)))))
(lambda (x) (append x rs))))) `(,(either :right p) ,(plist-get s-key p))))
(list (org-x-dag-bs :valid p) (list (either :right `(,s-key ,rs)) rs))))
(plist-get s-key p)))))
(list (org-x-dag-bs :valid `(,s-key ,rs))
rs))))
(ht-set htbl id n*) (ht-set htbl id n*)
rs*))) rs*)))
(let ((h (alist-get h-key ns))) (let ((h (alist-get h-key ns)))
@ -2324,12 +2292,9 @@ used for optimization."
(org-x-dag-ht-propagate-down adjlist :action :planned ns) (org-x-dag-ht-propagate-down adjlist :action :planned ns)
(org-x-dag-ht-map-down adjlist :action ns (org-x-dag-ht-map-down adjlist :action ns
(lambda (h id) (lambda (h id)
(pcase (ht-get h id) (either-from-right (ht-get h id) nil
(`(:error ,_) nil) (-when-let (committed (plist-get it :committed))
(`(:valid ,c) `(,committed ,(plist-get it :survivalp)))))
(-when-let (committed (plist-get c :committed))
(let ((survivalp (plist-get c :survivalp)))
(list committed survivalp))))))
(lambda (plist to-set) (lambda (plist to-set)
(-let (((committed survivalp) to-set)) (-let (((committed survivalp) to-set))
(-> (plist-put plist :survivalp survivalp) (-> (plist-put plist :survivalp survivalp)
@ -3156,6 +3121,20 @@ except it ignores inactive timestamps."
;; ;;
;; Not sure what to call these, they convert the DAG to a list of agenda strings ;; Not sure what to call these, they convert the DAG to a list of agenda strings
(defmacro org-x-dag-with-file-ids (files id-form)
(declare (indent 1))
`(with-temp-buffer
;; TODO this is silly and it adds 0.1 seconds to this function's runtime;
;; it is only needed to get the todo keyword the right color
(org-mode)
(->> (org-x-dag-files->ids ,files)
(--mapcat ,id-form))))
(defmacro org-x-dag-with-action-ids (id-form)
(declare (indent 0))
`(org-x-dag-with-file-ids (org-x-dag->action-files)
,id-form))
(defmacro org-x-dag-with-files (files pre-form form) (defmacro org-x-dag-with-files (files pre-form form)
(declare (indent 2)) (declare (indent 2))
(let* ((lookup-form '(ht-get file->ids it-file)) (let* ((lookup-form '(ht-get file->ids it-file))
@ -3176,34 +3155,29 @@ except it ignores inactive timestamps."
(-non-nil (-mapcat #'proc-file ,files)))))) (-non-nil (-mapcat #'proc-file ,files))))))
(defun org-x-dag-scan-projects () (defun org-x-dag-scan-projects ()
(cl-flet* (org-x-dag-with-action-ids
((format-key (either-from-right* (org-x-dag-id->bs it) nil
(id status-data) (lambda (bs)
;; NOTE in the future there might be more than just the car to this (pcase bs
(let ((status (car status-data))) (`(:sp-proj . ,status-data)
(print status) ;; NOTE in the future there might be more than just the car to this
(-when-let (priority (cl-case status (let ((status (car status-data)))
(:proj-active 4) (-when-let (priority (cl-case status
(:proj-wait 3) (:proj-active 4)
(:proj-hold 2) (:proj-wait 3)
(:proj-stuck 1))) (:proj-hold 2)
(pcase (org-x-dag-id->ns id) (:proj-stuck 1)))
(`(:valid ,v) (-when-let (ns (org-x-dag-id->ns it))
(when (plist-get v :committed) (either-from-right* ns nil
(let ((tags (org-x-dag-id->tags nil id))) (lambda (it-ns)
(-> (org-x-dag-format-tag-node tags id) (when (plist-get it-ns :committed)
(org-add-props nil (let ((tags (org-x-dag-id->tags nil it)))
'x-toplevelp (org-x-dag-id->is-toplevel-p id) (-> (org-x-dag-format-tag-node tags it)
'x-status status (org-add-props nil
'x-priority priority)))))))))) 'x-toplevelp (org-x-dag-id->is-toplevel-p it)
(with-temp-buffer 'x-status status
(org-mode) 'x-priority priority)
(->> (org-x-dag->action-files) (list)))))))))))))))
(org-x-dag-files->ids)
(--map (pcase (org-x-dag-id->bs it)
(`(:valid (:sp-proj . ,s))
(format-key it s))))
(-non-nil)))))
(defun org-x-dag--item-add-goal-ids (item ids) (defun org-x-dag--item-add-goal-ids (item ids)
(if ids (if ids
@ -3222,22 +3196,18 @@ except it ignores inactive timestamps."
(-mapcat #'split-parent-goals)))) (-mapcat #'split-parent-goals))))
(defun org-x-dag-scan-iterators () (defun org-x-dag-scan-iterators ()
(cl-flet (org-x-dag-with-action-ids
((format-id (either-from-right (org-x-dag-id->bs it) nil
(id status-data) (lambda (bs)
(let ((status (car status-data))) (pcase bs
(when (memq status '(:iter-empty :iter-active)) (`(:sp-proj . ,status-data)
(let ((tags (org-x-dag-id->tags nil id))) (let ((status (car status-data)))
(-> (org-x-dag-format-tag-node tags id) (when (memq status '(:iter-empty :iter-active))
(org-add-props nil (let ((tags (org-x-dag-id->tags nil it)))
'x-status status))))))) (-> (org-x-dag-format-tag-node tags it)
(with-temp-buffer (org-add-props nil
(org-mode) 'x-status status)
(->> (org-x-dag->action-files) (list)))))))))))
(org-x-dag-files->ids)
(--map (pcase (org-x-dag-id->bs it)
(`(:valid (:sp-proj . ,s)) (format-id it s))))
(-non-nil)))))
(defun org-x-dag-get-task-nodes (pred id) (defun org-x-dag-get-task-nodes (pred id)
(declare (indent 2)) (declare (indent 2))
@ -3254,79 +3224,43 @@ except it ignores inactive timestamps."
;; TODO this includes tasks underneath cancelled headlines ;; TODO this includes tasks underneath cancelled headlines
(defun org-x-dag-scan-tasks () (defun org-x-dag-scan-tasks ()
(cl-flet (org-x-dag-with-action-ids
((format-key (either-from-right* (org-x-dag-id->bs it) nil
(id s) (lambda (bs)
(-let (((&plist :todo :sched :dead) s)) (pcase bs
(pcase (org-x-dag-id->ns id) (`(:sp-task :task-active ,s)
(`(:valid ,ns) (-let (((&plist :todo :sched :dead) s))
(-let (((&plist :committed c) ns)) (-when-let (ns (org-x-dag-id->ns it))
(when (and (not sched) (not dead) c) (either-from-right* ns nil
(let ((tags (org-x-dag-id->tags nil id)) (lambda (it-ns)
(bp (org-x-dag-id->buffer-parent id))) (-let (((&plist :committed c) it-ns))
(-> (org-x-dag-format-tag-node tags id) (when (and (not sched) (not dead) c)
(org-add-props nil (let ((tags (org-x-dag-id->tags nil it))
'x-is-standalone (not bp) (bp (org-x-dag-id->buffer-parent it)))
'x-status :active)))))))))) (-> (org-x-dag-format-tag-node tags it)
;; TODO this is silly and it adds 0.1 seconds to this function's runtime; (org-add-props nil
;; it is only needed to get the todo keyword the right color 'x-is-standalone (not bp)
(with-temp-buffer 'x-status :active)
(org-mode) (list)))))))))))))))
(->> (org-x-dag->action-files)
(org-x-dag-files->ids)
(--reduce-from (pcase (org-x-dag-id->bs it)
(`(:valid (:sp-task :task-active ,s))
(-if-let (new (format-key it s))
(cons new acc)
acc))
(_ acc))
nil)))))
;; (org-x-dag-with-files (org-x-dag->action-files)
;; (org-x-dag-id->is-toplevel-p it)
;; (-if-let (project-tasks (org-x-dag-get-task-nodes
;; (lambda (it) (not (member (org-x-dag-id->todo it)
;; (list org-x-kw-canc org-x-kw-hold))))
;; it))
;; (--map (format-key it-category nil it) project-tasks)
;; (list (format-key it-category t it))))))
;; TODO wetter than Prince's dreams
(defun org-x-dag-scan-tasks-with-goals () (defun org-x-dag-scan-tasks-with-goals ()
(cl-flet* (org-x-dag-with-action-ids
((classify-parent (either-from-right* (org-x-dag-id->bs it) nil
(id) (lambda (bs)
(cond (pcase bs
((or (org-x-dag-id->is-goal-p :lifetime id) (`(:sp-task :task-active ,s)
(org-x-dag-id->is-goal-p :endpoint id)) (-let (((&plist :todo) s)
:non-survival) (goal-ids (-when-let (ns (org-x-dag-id->ns it))
((org-x-dag-id->is-goal-p :survival id) (either-from-right ns nil
:survival) (unless (plist-get it :survivalp)
(t (plist-get it :committed)))))
:ignore))) (tags (org-x-dag-id->tags nil it))
(format-key (bp (org-x-dag-id->buffer-parent it)))
(category is-standalone key) (-> (org-x-dag-format-tag-node tags it)
(-let (((goal-ids goal-status) (org-x-dag-id->goal-status 'current key))) (org-add-props nil
(when (memq goal-status '(:planned :committed)) 'x-is-standalone (not bp)
(let* ((s (org-x-dag-id->task-status key)) 'x-status :active)
(p (alist-get s org-x-headline-task-status-priorities)) (org-x-dag--item-add-goal-ids goal-ids)))))))))
(tags (org-x-dag-id->tags nil key)))
(unless (= p -1)
;; ASSUME only ids with at least one valid goal will get this
;; far
(-> (org-x-dag-format-tag-node category tags key)
(org-add-props nil
'x-is-standalone is-standalone
'x-status s)
(org-x-dag--item-add-goal-ids goal-ids))))))))
(org-x-dag-with-files (org-x-get-action-files)
(org-x-dag-id->is-toplevel-p it)
(-if-let (project-tasks (org-x-dag-get-task-nodes
(lambda (it) (not (member (org-x-dag-id->todo it)
(list org-x-kw-canc org-x-kw-hold))))
it))
(--mapcat (format-key it-category nil it) project-tasks)
(format-key it-category t it)))))
(defun org-x-dag-scan-survival-tasks () (defun org-x-dag-scan-survival-tasks ()
(cl-flet (cl-flet
@ -3403,26 +3337,20 @@ except it ignores inactive timestamps."
;; (list (format-key it-category it))))) ;; (list (format-key it-category it)))))
(defun org-x-dag-scan-archived () (defun org-x-dag-scan-archived ()
(cl-flet (org-x-dag-with-action-ids
((format-key (either-from-right* (org-x-dag-id->bs it) nil
(id bs) (lambda (bs)
(-when-let ((comptime is-project) (-when-let ((comptime is-project)
(pcase bs (pcase bs
(`(:sp-proj :proj-complete ,c) `(,c t)) (`(:sp-proj :proj-complete ,c) `(,c t))
(`(:sp-task :task-complete ,c) `(,c nil)))) (`(:sp-task :task-complete ,c) `(,c nil))))
(-let ((epoch (plist-get comptime :epoch))) (-let ((epoch (plist-get comptime :epoch)))
(when (org-x-dag-time-is-archivable-p epoch) (when (org-x-dag-time-is-archivable-p epoch)
(let ((tags (org-x-dag-id->tags nil id))) (let ((tags (org-x-dag-id->tags nil it)))
(-> (org-x-dag-format-tag-node tags id) (-> (org-x-dag-format-tag-node tags it)
(org-add-props nil (org-add-props nil
'x-project-p is-project)))))))) 'x-project-p is-project)
(with-temp-buffer (list))))))))))
(org-mode)
(->> (org-x-dag->action-files)
(org-x-dag-files->ids)
(--map (pcase (org-x-dag-id->bs it)
(`(:valid ,v) (format-key it v))))
(-non-nil)))))
(defun org-x-dag--classify-goal-link (which which-goal id) (defun org-x-dag--classify-goal-link (which which-goal id)
(let ((f (org-x-dag-id->file id))) (let ((f (org-x-dag-id->file id)))