ADD test for project deadline

This commit is contained in:
Nathan Dwarshuis 2022-06-12 19:32:38 -04:00
parent ca17ee15d5
commit efe3eac7c3
4 changed files with 107 additions and 51 deletions

View File

@ -36,16 +36,20 @@ left/right slot."
;; monad-y things ;; monad-y things
(defmacro either>>= (either form) (defmacro either-as>>= (sym either form)
"Bind EITHER to FORM where the right slot is bound to 'it'." "Bind EITHER to FORM where the right slot is bound to SYM."
(declare (indent 1)) (declare (indent 2))
(let ((e (make-symbol "--either"))) (let ((e (make-symbol "--either")))
`(let ((,e ,either)) `(let ((,e ,either))
(pcase ,e (pcase ,e
(`(:left ,_) ,e) (`(:left ,_) ,e)
(`(:right ,it) ,form) (`(:right ,,sym) ,form)
(e (error "Learn to use monads, dummy; this isn't one: %s" e)))))) (e (error "Learn to use monads, dummy; this isn't one: %s" e))))))
(defmacro either>>= (either form)
"Bind EITHER to FORM where the right slot is bound to 'it'."
`(either-as>>= it ,either ,form))
(defun either-foldM (fun init xs) (defun either-foldM (fun init xs)
"Mondically apply FUN to XS (a list). "Mondically apply FUN to XS (a list).

View File

@ -851,7 +851,7 @@ deadline (eg via epoch time) or if it has a repeater."
(< parent-epoch this-epoch)))))) (< parent-epoch this-epoch))))))
(defun org-x-dag-bs-action-project-inner (node-data ancestry child-bss) (defun org-x-dag-bs-action-project-inner (node-data ancestry child-bss)
(cl-flet (cl-flet*
((new-proj ((new-proj
(status) (status)
(either :right `(:sp-proj ,status))) (either :right `(:sp-proj ,status)))
@ -861,45 +861,39 @@ deadline (eg via epoch time) or if it has a repeater."
(is-next (is-next
(task-data) (task-data)
(-let (((&plist :todo :sched) task-data)) (-let (((&plist :todo :sched) task-data))
(or sched (equal todo org-x-kw-next))))) (or sched (equal todo org-x-kw-next))))
;; rankings (check-sched
;; *-active > proj-wait > proj-held > (proj-stuck == iter-empty) > *-complete (planning)
(org-x-dag-bs-action-with-closed node-data ancestry "projects" (if-let (sched (-some->> planning (org-ml-get-property :scheduled)))
(if child-bss (if child-bss (either :left "Projects cannot be scheduled")
`(:sp-proj :proj-complete ,it-comptime) (let ((sp (org-x-dag-partition-timestamp sched)))
`(:sp-task :task-complete ,it-comptime)) (if (< 0 (plist-get sp :length))
(->> "Tasks cannot have ranged scheduled timestamps"
(org-x-dag-bs-action-check-children child-bss (either :left))
(either :left "Completed projects cannot have active children") (either :right sp))))
(either :right `(:sp-proj :proj-complete ,it-comptime)) (either :right nil)))
`(:sp-task :task-complete ,it-comptime) (check-dead
(lambda (local) (planning)
(pcase local (if-let (dead (-some->> planning (org-ml-get-property :deadline)))
(`(:sp-proj :proj-complete ,_) t) (let ((dp (org-x-dag-partition-timestamp dead)))
(`(:sp-iter :iter-complete ,_) t) (cond
(`(:sp-task :task-complete ,_) t) ((< 0 (plist-get dp :length))
(_ nil)))) (either :left "Actions cannot have ranged deadlines"))
((and child-bss (plist-get dp :repeater))
(-let* (((sched dead) (-some->> it-planning (either :left "Projects cannot have repeated deadlines"))
(org-ml-get-properties '(:scheduled :deadline)))) ((org-x-dag-action-dead-after-parent-p ancestry dead)
(sp (-some-> sched (org-x-dag-partition-timestamp))) (either :left "Action deadline cannot end after parent deadline"))
(dp (-some-> dead (org-x-dag-partition-timestamp))) (t
(task-default (->> (list :todo it-todo :sched sp :dead dp) (either :right dp))))
(list :sp-task :task-active)))) (either :right nil)))
(check-todo
(todo task-default)
(cond (cond
((and child-bss (equal it-todo org-x-kw-hold))
(new-proj :proj-held))
((and child-bss sp)
(either :left "Projects cannot be scheduled"))
((and sp (< 0 (plist-get sp :length)))
(either :left "Projects cannot have ranged scheduled timestamps"))
((and dp (< 0 (plist-get dp :length)))
(either :left "Projects cannot have ranged deadline timestamps"))
((and child-bss (plist-get node-data :effort)) ((and child-bss (plist-get node-data :effort))
(either :left "Projects cannot have effort")) (either :left "Projects cannot have effort"))
((org-x-dag-action-dead-after-parent-p ancestry dead) ((and child-bss (equal todo org-x-kw-hold))
(either :left "Action deadline cannot end after parent deadline")) (new-proj :proj-held))
((equal it-todo org-x-kw-todo) ((equal todo org-x-kw-todo)
(org-x-dag-bs-action-rankfold-children child-bss task-default (org-x-dag-bs-action-rankfold-children child-bss task-default
(lambda (acc next) (lambda (acc next)
(->> (pcase `(,acc ,next) (->> (pcase `(,acc ,next)
@ -943,8 +937,8 @@ deadline (eg via epoch time) or if it has a repeater."
(`(,_ (:sp-task :task-active ,_)) t) (`(,_ (:sp-task :task-active ,_)) t)
;; any pair that makes it this far is completed in both, ;; any pair that makes it this far is completed in both,
;; which means neither takes precedence, which means choose ;; which means neither takes precedence, which means
;; the left one ;; choose the left one
(`(,_ ,_) nil)) (`(,_ ,_) nil))
(either :right))) (either :right)))
@ -984,9 +978,36 @@ deadline (eg via epoch time) or if it has a repeater."
(t (org-x-dag-bs-error-kw "Task action" o))))) (t (org-x-dag-bs-error-kw "Task action" o)))))
(e (error "Pattern fail: %s" e)))))) (e (error "Pattern fail: %s" e))))))
(child-bss (child-bss
(org-x-dag-bs-error-kw "Project action" it-todo)) (org-x-dag-bs-error-kw "Project action" todo))
(t (t
(either :right task-default))))))) (either :right task-default)))))
;; rankings
;; *-active > proj-wait > proj-held > (proj-stuck == iter-empty) > *-complete
(org-x-dag-bs-action-with-closed node-data ancestry "projects"
(if child-bss
`(:sp-proj :proj-complete ,it-comptime)
`(:sp-task :task-complete ,it-comptime))
(org-x-dag-bs-action-check-children child-bss
(either :left "Completed projects cannot have active children")
(either :right `(:sp-proj :proj-complete ,it-comptime))
`(:sp-task :task-complete ,it-comptime)
(lambda (local)
(pcase local
(`(:sp-proj :proj-complete ,_) t)
(`(:sp-iter :iter-complete ,_) t)
(`(:sp-task :task-complete ,_) t)
(_ nil))))
(either-as>>= sp (check-sched it-planning)
(either-as>>= dp (check-dead it-planning)
;; TODO it seems a bit odd that the only reason I need sp and dp here
;; is to seed the sub-project task form; idk why this is weird but it
;; smells like something could be optimized somewhere
(->> (list :todo it-todo :sched sp :dead dp)
(list :sp-task :task-active)
(check-todo it-todo)))))))
(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))
@ -1053,6 +1074,7 @@ deadline (eg via epoch time) or if it has a repeater."
(ts-data child-scheds) (ts-data child-scheds)
(->> (list :dead (plist-get ts-data :dead) (->> (list :dead (plist-get ts-data :dead)
:child-scheds child-scheds :child-scheds child-scheds
;; TODO this can be an epoch and not a datetime
:leading-sched-dt (-> (org-x-dag-pts-max child-scheds) :leading-sched-dt (-> (org-x-dag-pts-max child-scheds)
(plist-get :datetime))) (plist-get :datetime)))
(funcall new-active-fun)))) (funcall new-active-fun))))

View File

@ -89,6 +89,20 @@ CLOSED: [2022-06-10 Fri 19:13]
:ID: a834a585-acd1-44e9-8e62-17793146d6ab :ID: a834a585-acd1-44e9-8e62-17793146d6ab
:CREATED: [2022-06-10 Fri 19:13] :CREATED: [2022-06-10 Fri 19:13]
:END: :END:
** TODO this is a deadlined project
DEADLINE: <2022-06-12 Sun>
:PROPERTIES:
:ID: 51798071-f860-48fb-b3d8-e526ce270290
:CREATED: [2022-06-12 Sun 18:09]
:END:
*** NEXT subtask
:PROPERTIES:
:ID: fc1f3dda-a4b7-4b0d-b37c-fa67e112023a
:CREATED: [2022-06-12 Sun 18:10]
:END:
:LOGGING:
- State "NEXT" from "TODO" [2022-06-12 Sun 18:10]
:END:
* iterators * iterators
** TODO this is an iterator ** TODO this is an iterator
:PROPERTIES: :PROPERTIES:

View File

@ -46,6 +46,11 @@
(->> (org-ml-from-string 'timestamp s) (->> (org-ml-from-string 'timestamp s)
(org-ml-timestamp-get-start-time))) (org-ml-timestamp-get-start-time)))
(defun timestamp-to-epoch (s)
(->> (org-ml-from-string 'timestamp s)
(org-ml-timestamp-get-start-time)
(org-ml-time-to-unixtime)))
(buttercup-define-matcher :to-be-left-with (a x) (buttercup-define-matcher :to-be-left-with (a x)
(cl-destructuring-bind (cl-destructuring-bind
((a-expr . a) (x-expr . x)) ((a-expr . a) (x-expr . x))
@ -112,6 +117,14 @@
(and (eq (org-ml-get-type a) (org-ml-get-type b)) (and (eq (org-ml-get-type a) (org-ml-get-type b))
(plists-equal-p (get-useful-props a) (get-useful-props b))))) (plists-equal-p (get-useful-props a) (get-useful-props b)))))
(defun pts-equal-p (a b)
(-let (((&plist :datetime da :repeater ra :warning wa :length la) a)
((&plist :datetime db :repeater rb :warning wb :length lb) b))
(and (equal da db)
(equal ra rb)
(equal wa wb)
(equal la lb))))
(defun plist-diff-msg (eq-funs expr a b) (defun plist-diff-msg (eq-funs expr a b)
(-let (((a-diff b-diff common-diffs) (split-plists eq-funs a b))) (-let (((a-diff b-diff common-diffs) (split-plists eq-funs a b)))
(cond (cond
@ -173,12 +186,9 @@
(let* ((ancestry (list :canceled-parent-p c (let* ((ancestry (list :canceled-parent-p c
:held-parent-p h :held-parent-p h
:parent-deadline e)) :parent-deadline e))
(ancestry-eq-funs (list :parent-deadline #'element-equal-p)) (ancestry-eq-funs nil)
(local-eq-funs (list :sched #'element-equal-p (local-eq-funs (list :sched #'element-equal-p
;; TODO this is wrong :child-scheds #'pts-equal-p))
:child-scheds (lambda (a b)
(seq-set-equal-p
a b #'element-equal-p))))
(f (->> (-partial #'status-diff-msg local-eq-funs test-expr y s d) (f (->> (-partial #'status-diff-msg local-eq-funs test-expr y s d)
(-partial #'ancestry-diff-msg ancestry-eq-funs test-expr ancestry) (-partial #'ancestry-diff-msg ancestry-eq-funs test-expr ancestry)
(-partial #'buffer-status-diff-msg test-expr :action) (-partial #'buffer-status-diff-msg test-expr :action)
@ -280,7 +290,13 @@
(it "Canceled" (it "Canceled"
(expect "322af50a-f431-4940-8caf-cc5acdf5a555" :id-to-be-action (expect "322af50a-f431-4940-8caf-cc5acdf5a555" :id-to-be-action
nil nil nil :sp-task '(:task-complete) nil nil nil :sp-task '(:task-complete)
'(:canceledp t :epoch 1654903560)))) '(:canceledp t :epoch 1654903560)))
(it "Deadlined"
(let ((d (timestamp-to-epoch "<2022-06-12 Sun>")))
(expect "fc1f3dda-a4b7-4b0d-b37c-fa67e112023a" :id-to-be-action
nil nil d :sp-task '(:task-active)
'(:todo "NEXT" :sched nil :dead nil)))))
(describe "Standalone Tasks" (describe "Standalone Tasks"
(it "Active" (it "Active"