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

ADD iterator junk to the action status function

This commit is contained in:
Nathan Dwarshuis 2022-03-10 23:16:00 -05:00
parent 1cfbf77ade
commit bd9e60b676
1 changed files with 176 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1649,8 +1649,9 @@ removed from, added to, or edited within the DAG respectively."
(defun org-x-dag-status-is-error-p (status) (defun org-x-dag-status-is-error-p (status)
(eq (car (cdr status)) :error)) (eq (car (cdr status)) :error))
(defmacro org-x-dag-id->with-project-children (id child-statuses codetree task-fun) (defmacro org-x-dag-id->with-child-statuses (id child-statuses task-key
(declare (indent 2)) project-key codetree task-fun)
(declare (indent 4))
(let ((flat-codes (-map #'car codetree)) (let ((flat-codes (-map #'car codetree))
(proj-ranking-tbl (proj-ranking-tbl
(->> codetree (->> codetree
@ -1669,17 +1670,126 @@ removed from, added to, or edited within the DAG respectively."
(let* ((ranks (--map (-let (((id . status) it)) (let* ((ranks (--map (-let (((id . status) it))
(pcase status (pcase status
(`(:error _) nil) (`(:error _) nil)
(`(:status (:type :task :code ,code)) (`(:status (:type ,k :code ,code))
(cl-case k
(,task-key
(alist-get code ',proj-ranking-tbl)) (alist-get code ',proj-ranking-tbl))
(`(:status (:type :project :code ,code)) (,project-key
(funcall ,task-fun id code)))) (funcall ,task-fun id code))))))
,child-statuses))) ,child-statuses)))
(if (-any #'null ranks) (if (-any #'null ranks)
(to-status :error "Child error") (to-status :error "Child error")
(->> (nth (-max ranks) ',flat-codes) (->> (nth (-max ranks) ',flat-codes)
(apply #'to-status))))))) (apply #'to-status)))))))
;; TODO where do iterators fit into this? ;; TODO not DRY
(defun org-x-dag-id->iterator-task-status (id)
(cl-flet
((to-status
(type data)
(org-x-dag-id-action-status id type :task data)))
(let ((kw (org-x-dag-id->todo id)))
(-if-let (c (org-x-dag-id->planning-epoch :closed id))
(if (member kw org-x-done-keywords)
(->> (if (org-x-dag-time-is-archivable-p c) :archivable :complete)
(to-status :status))
(to-status :error "Closed iterator tasks must be marked DONE/CANC"))
(cond
((member kw org-x-done-keywords)
(to-status :error "Done iterator tasks must have closed timestamp"))
((equal kw org-x-k-todo)
(-if-let (ts (or (org-x-dag-id->planning-epoch :scheduled id)
(org-x-dag-id->planning-epoch :deadline id)))
(if (< org-x-iterator-active-future-offset (- ts (float-time)))
(to-status :status :future)
(to-status :status :active))
(to-status :error "Iterator tasks must be scheduled or deadlined")))
(t
(to-status :error "Iterator tasks cannot have keyword: %s" kw)))))))
(defun org-x-dag-id->iterator-project-status (id)
(cl-flet
((to-status
(code)
(org-x-dag-id-action-status id :status :project code))
(to-error
(msg)
(org-x-dag-id-action-status id :error :project msg)))
(let ((kw (org-x-dag-id->todo id))
(child-statuses
(->> (org-x-dag-id->buffer-children id)
(-mapcat #'org-x-dag-id->iterator-project-status)))
(status
(cond
((not child-statuses)
(org-x-dag-id->iterator-task-status id))
((org-x-dag-id->planning-timestamp :scheduled id)
(to-error "Iterator project nodes cannot be scheduled"))
((equal kw org-x-kw-canc)
(to-status :complete))
((equal kw org-x-kw-done)
(org-x-dag-id->with-child-statuses id child-statuses :iterator-task :iterator-project
(((:status :archivable))
((:status :complete))
((:error "Complete iterator projects can only have complete children")
:active :future))
(lambda (_ code)
(cl-case code
(:archivable 0)
(:closed 1)
(t 2)))))
((equal kw org-x-kw-todo)
(org-x-dag-id->with-child-statuses id child-statuses :iterator-task :iterator-project
(((:error "Open iterator projects need to have at least one active child")
:complete :archivable)
((:status :active))
((:status :future)))
(lambda (_ code)
(cl-case code
((:archivable :complete) 0)
(:active 1)
(:future 2)))))
(t
(to-error (format "Iterator projects has invalid keyword: %s" kw))))))
`(,status ,@child-statuses))))
(defun org-x-dag-headline-get-iterator-status (id)
(cl-flet
((to-status
(code)
(org-x-dag-id-action-status id :status :iterator code))
(to-error
(msg)
(org-x-dag-id-action-status id :error :iterator msg)))
(let* ((kw (org-x-dag-id->todo id))
(child-statuses
(->> (org-x-dag-id->buffer-children id)
(-mapcat #'org-x-dag-id->iterator-project-status)))
(this-status
(cond
((not (org-x-dag-id->node-property "ARCHIVE" id))
(to-error "Iterator must have ARCHIVE set"))
((not (org-x-dag-id->node-property org-x-prop-time-shift id))
(to-error "Iterator must have %s set" org-x-prop-time-shift))
;; TODO this is set up to assume that iterators will never be
;; archived, which is almost true (with almost doing some heavy lifting)
((not (equal kw org-x-kw-todo))
(to-error "Iterators can only be marked TODO"))
((not child-statuses)
(to-status :empty))
(t
;; TODO this is utterly gross...
(let ((s (if (--any-p (pcase (cdr it)
(`(:status (:type ,(or :iterator-task
:iterator-proejct)
:code :future))
t))
child-statuses)
:future
:active)))
(to-status s))))))
`(,this-status ,@child-statuses))))
(defun org-x-dag-id->action-status (id) (defun org-x-dag-id->action-status (id)
(cl-flet (cl-flet
((to-status ((to-status
@ -1688,15 +1798,19 @@ removed from, added to, or edited within the DAG respectively."
(to-error (to-error
(msg) (msg)
(org-x-dag-id-action-status id :error :project msg))) (org-x-dag-id-action-status id :error :project msg)))
(if (org-x-dag-id->is-iterator-p id)
(org-x-dag-headline-get-iterator-status id)
(let* ((keyword (org-x-dag-id->todo id)) (let* ((keyword (org-x-dag-id->todo id))
(child-statuses (->> (org-x-dag-id->buffer-children id) (child-statuses (->> (org-x-dag-id->buffer-children id)
(-mapcat #'org-x-dag-id->action-status))) (-mapcat #'org-x-dag-id->action-status)))
(this-status (this-status
(cond (cond
;; TODO this isn't done for iterators
((org-x-dag-id->any-illegal-p id) ((org-x-dag-id->any-illegal-p id)
(to-error "Node has illegal links")) (to-error "Node has illegal links"))
((not (org-x-dag-id->created-in-past-p id)) ((not (org-x-dag-id->created-in-past-p id))
(to-error "Node must have creation timestamp in the past")) (to-error "Node must have creation timestamp in the past"))
((org-x-dag-id->is-iterator-p id)
((not child-statuses) ((not child-statuses)
(org-x-dag-id->task-status id)) (org-x-dag-id->task-status id))
((org-x-dag-id->planning-timestamp :scheduled id) ((org-x-dag-id->planning-timestamp :scheduled id)
@ -1711,7 +1825,7 @@ removed from, added to, or edited within the DAG respectively."
(->> (if (org-x-dag-id->is-archivable-p id) :archivable :complete) (->> (if (org-x-dag-id->is-archivable-p id) :archivable :complete)
(to-status))) (to-status)))
((equal keyword org-x-kw-done) ((equal keyword org-x-kw-done)
(org-x-dag-id->with-project-children id child-statuses (org-x-dag-id->with-child-statuses id child-statuses :task :project
(((:status :archivable)) (((:status :archivable))
((:status :complete)) ((:status :complete))
((:error "DONE projects can only have complete child nodes") ((:error "DONE projects can only have complete child nodes")
@ -1722,7 +1836,7 @@ removed from, added to, or edited within the DAG respectively."
(:complete 1) (:complete 1)
(:active 2))))) (:active 2)))))
((equal keyword org-x-kw-todo) ((equal keyword org-x-kw-todo)
(org-x-dag-id->with-project-children id child-statuses (org-x-dag-id->with-child-statuses id child-statuses :task :project
(((:error "TODO projects should have at least one active child") (((:error "TODO projects should have at least one active child")
:archivable :complete) :archivable :complete)
((:status :stuck)) ((:status :stuck))
@ -1741,8 +1855,8 @@ removed from, added to, or edited within the DAG respectively."
;; is either :archivable or :complete in which case it ;; is either :archivable or :complete in which case it
;; is an error ;; is an error
(t 0)))))) (t 0))))))
(t (error "Could not determine status for '%s'" id))))) (t (error "Could not determine status for '%s'" id))))))
`(,this-status ,@child-statuses)))) `(,this-status ,@child-statuses)))))
(defun org-x-dag-id->endpoint-status (id) (defun org-x-dag-id->endpoint-status (id)
()) ())