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

ENH make comprehensive action status function

This commit is contained in:
Nathan Dwarshuis 2022-03-12 21:15:43 -05:00
parent bd9e60b676
commit f9ecc76494
1 changed files with 363 additions and 228 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1382,6 +1382,8 @@ headline."
(org-x-dag-get-buffer-nodes file (org-x-dag-get-buffer-nodes file
org-todo-keywords-1 org-todo-keywords-1
(list org-x-prop-parent-type (list org-x-prop-parent-type
org-x-prop-time-shift
"ARCHIVE"
org-x-prop-created)))) org-x-prop-created))))
;;; DAG SYNCHRONIZATION/CONSTRUCTION ;;; DAG SYNCHRONIZATION/CONSTRUCTION
@ -1620,246 +1622,379 @@ removed from, added to, or edited within the DAG respectively."
;; - closed keywords must be marked DONE/CANC ;; - closed keywords must be marked DONE/CANC
(t (check-done id kw)))))))) (t (check-done id kw))))))))
(defun org-x-dag-id-status (id type data) ;; type Status = Either String (Enum, a)
(let ((payload (cl-case type ;; data NodeData a = Status { props :: [something], status = Status a }
((:error :status) `(,type ,data))
(t (error "invalid status type: %s" type)))))
`(,id . ,payload)))
(defun org-x-dag-id-action-status (id status-type action-type code) (defun org-x-dag-status-valid (id data)
(org-x-dag-id-status id status-type (list :type action-type :code code))) `(:valid :id ,id :data ,data))
(defun org-x-dag-id->task-status (id) (defun org-x-dag-status-error (id msg)
(cl-flet `(:error :id ,id :msg ,msg))
((to-status
(type data) (defmacro org-x-dag-status>>= (status form)
(org-x-dag-id-action-status id type :task data))) "Treat STATUS like an Either monad.
(let ((kw (org-x-dag-id->todo id))) FORM should take the data of a valid status bound to 'it' and
(-if-let (c (org-x-dag-id->planning-epoch :closed id)) return another status."
(if (member kw org-x-done-keywords) (declare (indent 1))
(->> (if (org-x-dag-time-is-archivable-p c) :archivable :complete) `(pcase ,status
(to-status :status)) (`(:error . ,d) `(:error ,@d))
(to-status :error "Closed id must be marked DONE/CANC")) (`(:valid . ,it) ,form)))
(cond
((member kw org-x-done-keywords) (defmacro org-x-dag-status-with-data (status form)
(to-status :error "Done id's must have closed timestamp")) (declare (indent 1))
(t `(org-x-dag-status>>= status
(to-status :status :active))))))) (-let (((&plist :id it-id :data it-data) it))
,form)))
(defmacro org-x-dag-status-from-data (status form)
(declare (indent 1))
`(pcase ,status
(`(:error . ,_) nil)
(`(:valid . ,d)
(-let (((&plist :id it-id :data it-data) d))
,form))))
(defun org-x-dag-action-status (id action-type code)
;; action types and their codes
;;
;; :task
;; - :archivable
;; - :complete
;; - :active
;;
;; :project
;; - :archivable
;; - :complete
;; - :stuck
;; - :held
;; - :wait
;; - :active
;;
;; :iterator
;; - :archivable
;; - :complete
;; - :empty
;; - :active
;; - :future
;;
;; :iterator-task/project
;; - :archivable
;; - :complete
;; - :active
;; - :future
(org-x-dag-status-valid id (list :code code :action-type action-type)))
(defun org-x-dag-goal-status (id code deadline)
(org-x-dag-status-valid (list :code code :deadline deadline)))
;; (defun org-x-dag-id->task-status (id)
;; (cl-flet
;; ((to-valid
;; (code)
;; (org-x-dag-action-status id :task code))
;; (to-error
;; (msg)
;; (org-x-dag-status-error id msg)))
;; (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-valid))
;; (to-error "Closed id must be marked DONE/CANC"))
;; (cond
;; ((member kw org-x-done-keywords)
;; (to-error "Done id's must have closed timestamp"))
;; (t
;; (to-valid :active)))))))
(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 status) :error))
(defmacro org-x-dag-id->with-child-statuses (id child-statuses task-key (defmacro org-x-dag-id->with-child-statuses (id child-statuses codelist
project-key codetree task-fun) to-valid-form rank-form
(declare (indent 4)) childless-form)
(let ((flat-codes (-map #'car codetree)) (declare (indent 3))
(proj-ranking-tbl (let ((c (make-symbol "--child-statuses"))
(->> codetree (i (make-symbol "--id")))
(--map-indexed `(-if-let (,c ,child-statuses)
(-let* (((key . child-codes) it) (let* ((,i ,id)
(i it-index) (ranks (--map (org-x-dag-status-from-data it ,rank-form)
(trans (--map (cons it i) child-codes))) ,child-statuses)))
(pcase key (if (-any #'null ranks)
(`(:error ,_) trans) (org-x-dag-status-error ,i "Child-dependent error")
(`(:status ,s) (cons (cons s it-index) trans))))) (pcase (nth (-max ranks) ',codelist)
(-flatten-n 1)))) (`nil (error "Invalid index returned during child translation"))
`(cl-flet (`(:error ,msg) (org-x-dag-status-error ,i msg))
((to-status (`(:valid ,it) ,to-valid-form))))
(type data) ,childless-form)))
(org-x-dag-id-action-status id type :project data)))
(let* ((ranks (--map (-let (((id . status) it))
(pcase status
(`(:error _) nil)
(`(:status (:type ,k :code ,code))
(cl-case k
(,task-key
(alist-get code ',proj-ranking-tbl))
(,project-key
(funcall ,task-fun id code))))))
,child-statuses)))
(if (-any #'null ranks)
(to-status :error "Child error")
(->> (nth (-max ranks) ',flat-codes)
(apply #'to-status)))))))
;; TODO not DRY (defmacro org-x-dag-id->with-action-child-statuses (id child-statuses action-type
(defun org-x-dag-id->iterator-task-status (id) codelist trans-fun
(cl-flet childless-form)
((to-status (declare (indent 3))
(type data) `(org-x-dag-id->with-child-statuses ,id ,child-statuses ,codelist
(org-x-dag-id-action-status id type :task data))) (org-x-dag-action-status ,id ,action-type it)
(let ((kw (org-x-dag-id->todo id))) (-let (((&plist :action-type a :code c) it-data))
(-if-let (c (org-x-dag-id->planning-epoch :closed id)) (funcall ,trans-fun it-id a c))
(if (member kw org-x-done-keywords) ,childless-form))
(->> (if (org-x-dag-time-is-archivable-p c) :archivable :complete)
(to-status :status)) (defun org-x-dag-id->action-status (id in-iteratorp)
(to-status :error "Closed iterator tasks must be marked DONE/CANC")) (cl-flet*
((get-child-statuses
(id iteratorp)
;; Distinguish between immediate children and all deeper children;
;; assume that the car of anything returned by
;; `org-x-dag-id->action-status' is the parent of all the status
;; objects in the cdr, so map these together
(-let (((shallow deep)
(->> (org-x-dag-id->buffer-children id)
(--reduce-from
(-let (((child . subchildren)
(org-x-dag-id->action-status it iteratorp))
((acc-children acc-subchildren) acc))
`((,child ,@acc-children)
(,@subchildren ,@acc-subchildren)))
nil))))
(list shallow deep)))
(to-valid-closed
(id type ts)
(->> (if (->> (org-ml-timestamp-get-start-time ts)
(org-ml-time-to-unixtime)
(org-x-dag-time-is-archivable-p))
:archivable
:complete)
(org-x-dag-action-status id type)))
(check-archivable
(id closed status)
(org-x-dag-status-with-data status
(-let (((&plist :code c :action-type a) it-data))
(if (eq c :archivable)
(to-valid-closed id a closed)
(org-x-dag-action-status id a c)))))
(iterator-status
(id kw closed c-statuses)
(cond (cond
((member kw org-x-done-keywords) ((not (org-x-dag-id->node-property "ARCHIVE" id))
(to-status :error "Done iterator tasks must have closed timestamp")) (org-x-dag-status-error id "Iterator must have ARCHIVE set"))
((equal kw org-x-k-todo) ((not (org-x-dag-id->node-property org-x-prop-time-shift id))
(-if-let (ts (or (org-x-dag-id->planning-epoch :scheduled id) (->> (format "Iterator must have %s set" org-x-prop-time-shift)
(org-x-dag-id->planning-epoch :deadline id))) (org-x-dag-status-error id)))
(if (< org-x-iterator-active-future-offset (- ts (float-time))) ((equal kw org-x-done-keywords)
(to-status :status :future) (->>
(to-status :status :active)) (org-x-dag-id->with-action-child-statuses id c-statuses :iterator
(to-status :error "Iterator tasks must be scheduled or deadlined"))) ((:valid :archivable)
(t (:valid :complete)
(to-status :error "Iterator tasks cannot have keyword: %s" kw))))))) (:error "Complete iterators can only have complete child nodes"))
(lambda (_ type code)
(defun org-x-dag-id->iterator-project-status (id) (when (memq type '(:iterator-task :iterator-project))
(cl-flet (pcase code
((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) (:archivable 0)
(:closed 1) (:complete 1)
(t 2))))) ((or :active :future) 2))))
((equal kw org-x-kw-todo) (org-x-dag-action-status id :iterator :complete))
(org-x-dag-id->with-child-statuses id child-statuses :iterator-task :iterator-project (check-archivable id closed)))
(((:error "Open iterator projects need to have at least one active child") ((equal kw org-x-kw-todo)
:complete :archivable) (org-x-dag-id->with-action-child-statuses id c-statuses :iterator
((:status :active)) ((:valid :empty)
((:status :future))) (:valid :active)
(lambda (_ code) (:valid :future))
(cl-case code (lambda (_ type code)
((:archivable :complete) 0) (when (memq type '(:iterator-task :iterator-project))
(:active 1) (pcase code
(:future 2))))) ((or :archivable :complete) 0)
(t (:active 1)
(to-error (format "Iterator projects has invalid keyword: %s" kw)))))) (:future 2))))
`(,status ,@child-statuses)))) (org-x-dag-action-status id :iterator :empty)))
(t
(funcall to-error "Iterator can only have DONE/CANC/TODO keywords"))))
(defun org-x-dag-headline-get-iterator-status (id) (iterator-project-status
(cl-flet (id kw closed c-statuses)
((to-status (cond
(code) ((equal kw org-x-kw-done)
(org-x-dag-id-action-status id :status :iterator code)) (->>
(to-error (org-x-dag-id->with-action-child-statuses id c-statuses :iterator-project
(msg) ((:valid :archivable)
(org-x-dag-id-action-status id :error :iterator msg))) (:valid :complete)
(let* ((kw (org-x-dag-id->todo id)) (:error "Complete iterator projects can only have complete children"))
(child-statuses (lambda (_ type code)
(->> (org-x-dag-id->buffer-children id) (when (memq type '(:iterator-task :iterator-project))
(-mapcat #'org-x-dag-id->iterator-project-status))) (pcase code
(this-status (:archivable 0)
(cond (:complete 1)
((not (org-x-dag-id->node-property "ARCHIVE" id)) ((or :active :future) 2))))
(to-error "Iterator must have ARCHIVE set")) (to-valid-closed id :iterator-task closed))
((not (org-x-dag-id->node-property org-x-prop-time-shift id)) (check-archivable id closed)))
(to-error "Iterator must have %s set" org-x-prop-time-shift)) ((equal kw org-x-kw-todo)
;; TODO this is set up to assume that iterators will never be (org-x-dag-id->with-action-child-statuses id c-statuses :iterator-project
;; archived, which is almost true (with almost doing some heavy lifting) ((:error "Open iterator projects must have at least one active child")
((not (equal kw org-x-kw-todo)) (:valid :active)
(to-error "Iterators can only be marked TODO")) (:valid :future))
((not child-statuses) (lambda (_ type code)
(to-status :empty)) (when (memq type '(:iterator-project :iterator-task))
(t (pcase code
;; TODO this is utterly gross... ((or :archivable :complete) 0)
(let ((s (if (--any-p (pcase (cdr it) (:active 1)
(`(:status (:type ,(or :iterator-task (:future 2))))
:iterator-proejct) (-if-let (ts (or (org-x-dag-id->planning-epoch :scheduled id)
:code :future)) (org-x-dag-id->planning-epoch :deadline id)))
t)) (let ((code (if (< org-x-iterator-active-future-offset
child-statuses) (- ts (float-time)))
:future :future :active)))
:active))) (org-x-dag-action-status id :iterator-task code))
(to-status s)))))) (->> "Iterator tasks must be scheduled or deadlined"
`(,this-status ,@child-statuses)))) (org-x-dag-status-error id)))))
(t
(->> (format "Iterated action has invalid keyword: %s" kw)
(org-x-dag-status-error id)))))
(defun org-x-dag-id->action-status (id) (project-status
(cl-flet (id kw closed c-statuses)
((to-status (cond
(code) ((equal kw org-x-kw-done)
(org-x-dag-id-action-status id :status :project code)) (->>
(to-error (org-x-dag-id->with-action-child-statuses id c-statuses :project
(msg) ((:valid :archivable)
(org-x-dag-id-action-status id :error :project msg))) (:valid :complete)
(if (org-x-dag-id->is-iterator-p id) (:error "DONE projects can only have complete child nodes"))
(org-x-dag-headline-get-iterator-status id) ;; TODO figure out what to do when a key doesn't match, it
(let* ((keyword (org-x-dag-id->todo id)) ;; should make an error but not sure if it should be a
(child-statuses (->> (org-x-dag-id->buffer-children id) ;; runtime error or a returned status error
(-mapcat #'org-x-dag-id->action-status))) (lambda (_ type code)
(this-status (pcase `(,type ,code)
(cond (`(,_ :archivable) 0)
;; TODO this isn't done for iterators (`(,_ :complete) 1)
((org-x-dag-id->any-illegal-p id) (`(:project ,(or :stuck :held :wait :active)) 2)
(to-error "Node has illegal links")) (`(:task :active) 2)
((not (org-x-dag-id->created-in-past-p id)) (`(:iterator ,(or :active :future :empty) 2))
(to-error "Node must have creation timestamp in the past")) (e (error "Invalid task/code combination: %S" e))))
((org-x-dag-id->is-iterator-p id) (to-valid-closed id :task closed))
((not child-statuses) (check-archivable id closed)))
(org-x-dag-id->task-status id)) ((equal kw org-x-kw-todo)
((org-x-dag-id->planning-timestamp :scheduled id) (org-x-dag-id->with-action-child-statuses id c-statuses :project
(to-error "Projects cannot be scheduled")) ((:error "TODO projects should have at least one active child")
((equal keyword org-x-kw-hold) (:valid :stuck)
(to-status :held)) (:valid :held)
((member keyword org-x--project-invalid-todostates) (:valid :wait)
(->> (s-join ", " org-x--project-invalid-todostates) (:valid :active))
(format "Projects cannot have these keywords: %s") (lambda (id type code)
(to-error))) (pcase `(,type ,code)
((equal keyword org-x-kw-canc) (`(,_ ,(or :archivable :complete)) 0)
(->> (if (org-x-dag-id->is-archivable-p id) :archivable :complete) (`(:project :stuck) 1)
(to-status))) (`(:project :held) 2)
((equal keyword org-x-kw-done) (`(:project :wait) 3)
(org-x-dag-id->with-child-statuses id child-statuses :task :project (`(:project :active) 4)
(((:status :archivable)) (`(:task ,_)
((:status :complete)) (let ((kw (org-x-dag-id->todo id)))
((:error "DONE projects can only have complete child nodes") (cond
:stuck :held :wait :active)) ((equal kw org-x-kw-hold) 2)
(lambda (_ code) ((equal kw org-x-kw-wait) 3)
(cl-case code ((equal kw org-x-kw-next) 4)
(:archivable 0) ((equal kw org-x-kw-todo)
(:complete 1) (if (org-x-dag-id->planning-timestamp :scheduled id)
(:active 2))))) 4 1))
((equal keyword org-x-kw-todo) (t
(org-x-dag-id->with-child-statuses id child-statuses :task :project (error "Could not translate task with keyword: %s" kw)))))
(((:error "TODO projects should have at least one active child") (`(:iterator ,(or :active :empty)) 1)
:archivable :complete) (`(:iterator :future) 4)
((:status :stuck)) (e (error "Invalid task/code combination: %S" e))))
((:status :held)) (org-x-dag-action-status id :task :active)))
((:status :wait)) (t
((:status :active))) (if c-statuses
(lambda (id _) (if (equal kw org-x-kw-hold)
(let ((kw (org-x-dag-id->todo id))) (org-x-dag-action-status id :project :held)
(->> (format "Projects cannot be marked %s" kw)
(org-x-dag-status-error)))
(org-x-dag-action-status id :task :active))))))
(-let* ((kw (org-x-dag-id->todo id))
(closed (org-x-dag-id->planning-timestamp :closed id))
(iteratorp (org-x-dag-id->is-iterator-p id))
((c-statuses subc-statuses) (get-child-statuses id iteratorp))
(this-status
;; first check for a bunch of errors that are equally valid at any
;; level in the DAG
(-if-let (general-error
(cond (cond
((equal kw org-x-kw-todo) ((org-x-dag-id->any-illegal-p id)
(if (org-x-dag-id->planning-timestamp :scheduled id) 4 1)) "Action has illegal links")
((equal kw org-x-kw-hold) 2) ((not (org-x-dag-id->created-in-past-p id))
((equal kw org-x-kw-wait) 3) "Action must have creation timestamp in the past")
((equal kw org-x-kw-next) 4) ((and closed (not (member kw org-x-done-keywords)))
;; ASSUME anything that doesn't have the above keywords "Closed actions must be marked with DONE/CANC")
;; is either :archivable or :complete in which case it ((and (not closed) (member kw org-x-done-keywords))
;; is an error "DONE/CANC actions must have closed timestamp")
(t 0)))))) ((and c-statuses
(t (error "Could not determine status for '%s'" id)))))) (org-x-dag-id->planning-timestamp :scheduled id))
`(,this-status ,@child-statuses))))) "Actions with children cannot be scheduled")
((and c-statuses
(org-x-dag-id->planning-timestamp :deadline id))
"Actions with children cannot be deadlined")
((and iteratorp in-iteratorp)
"Iterators cannot be nested")))
(org-x-dag-status-error id general-error)
(cond
;; CANC actions work the same regardless of action type; if the
;; closed timestamp is archivable, its :archivable, otherwise it
;; is :complete (NOTE that this is 'nice' because I made it such
;; that :complete and :archivable have the same meaning and key
;; for all action types)
((equal kw org-x-kw-canc)
(let ((type (cond
(iteratorp :iterator)
(in-iteratorp
(if c-statuses :iterator-project :iterator-task))
(t
(if c-statuses :project :task)))))
(to-valid-closed id type closed)))
;; assuming none of the general checks above matched, try more
;; specific checks depending on if the current action is an
;; iterator (and if we are inside one)
(iteratorp
(iterator-status id kw closed c-statuses))
(in-iteratorp
(iterator-project-status id kw closed c-statuses))
(t
(project-status id kw closed c-statuses))))))
`(,this-status ,@c-statuses ,@subc-statuses))))
(defun org-x-dag-id->endpoint-status (id) (defun org-x-dag-id->has-done-error-p (id)
()) (or (and (not (org-x-dag-id->is-done-p id)) (org-x-dag-id->is-closed-p id))
(and (org-x-dag-id->is-done-p id) (not (org-x-dag-id->is-closed-p id)))))
(defun org-x-dag-status-check-todo-or-done (id to-error alt-fun)
(declare (indent 2))
(org-x-dag-status-check-done id kw to-error
(lambda (id)
(let ((kw (org-x-dag-id->todo id)))
(if (equal kw org-x-kw-todo)
(to-error "Keyword must be marked TODO/DONE")
(funcall alt-fun id))))))
;; (defun org-x-dag-id->endpoint-status (id)
;; (cl-flet
;; ((to-status
;; (type code)
;; (org-x-dag-goal-status id :status type code))
;; (to-error
;; (type msg)
;; (org-x-dag-goal-status id :error type msg)))
;; (let ((child-statuses (->> (org-x-dag-id->buffer-children id)
;; (-mapcat #'org-x-dag-id->endpoint-status)))
;; (this-status
;; (cond
;; ((org-x-dag-id->has-done-error-p id)
;; (to-error :branch "Closed timestamps must have DONE/CANC"))
;; ((org-x-dag-id->planning-timestamp :scheduled id)
;; (to-error :branch "Endpoint goals cannot be scheduled"))
;; ((equal kw org-x-kw-todo)
;; (to-status :branch :active))
;; ((org-x-dag-id->is-done-p id)
;; (to-status :branch :complete))
;; ((not children)
;; ())))
;; `(,this-status ,@child-statuses)))))
(defun org-x-dag-id->file-level-status (id) (defun org-x-dag-id->file-level-status (id)
"Return file-level status of ID and its children. "Return file-level status of ID and its children.