ADD test for project deadline
This commit is contained in:
parent
ca17ee15d5
commit
efe3eac7c3
|
|
@ -36,16 +36,20 @@ left/right slot."
|
|||
|
||||
;; monad-y things
|
||||
|
||||
(defmacro either>>= (either form)
|
||||
"Bind EITHER to FORM where the right slot is bound to 'it'."
|
||||
(declare (indent 1))
|
||||
(defmacro either-as>>= (sym either form)
|
||||
"Bind EITHER to FORM where the right slot is bound to SYM."
|
||||
(declare (indent 2))
|
||||
(let ((e (make-symbol "--either")))
|
||||
`(let ((,e ,either))
|
||||
(pcase ,e
|
||||
(`(:left ,_) ,e)
|
||||
(`(:right ,it) ,form)
|
||||
(`(:right ,,sym) ,form)
|
||||
(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)
|
||||
"Mondically apply FUN to XS (a list).
|
||||
|
||||
|
|
|
|||
|
|
@ -851,7 +851,7 @@ deadline (eg via epoch time) or if it has a repeater."
|
|||
(< parent-epoch this-epoch))))))
|
||||
|
||||
(defun org-x-dag-bs-action-project-inner (node-data ancestry child-bss)
|
||||
(cl-flet
|
||||
(cl-flet*
|
||||
((new-proj
|
||||
(status)
|
||||
(either :right `(:sp-proj ,status)))
|
||||
|
|
@ -861,45 +861,39 @@ deadline (eg via epoch time) or if it has a repeater."
|
|||
(is-next
|
||||
(task-data)
|
||||
(-let (((&plist :todo :sched) task-data))
|
||||
(or sched (equal todo org-x-kw-next)))))
|
||||
;; 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))))
|
||||
|
||||
(-let* (((sched dead) (-some->> it-planning
|
||||
(org-ml-get-properties '(:scheduled :deadline))))
|
||||
(sp (-some-> sched (org-x-dag-partition-timestamp)))
|
||||
(dp (-some-> dead (org-x-dag-partition-timestamp)))
|
||||
(task-default (->> (list :todo it-todo :sched sp :dead dp)
|
||||
(list :sp-task :task-active))))
|
||||
(or sched (equal todo org-x-kw-next))))
|
||||
(check-sched
|
||||
(planning)
|
||||
(if-let (sched (-some->> planning (org-ml-get-property :scheduled)))
|
||||
(if child-bss (either :left "Projects cannot be scheduled")
|
||||
(let ((sp (org-x-dag-partition-timestamp sched)))
|
||||
(if (< 0 (plist-get sp :length))
|
||||
(->> "Tasks cannot have ranged scheduled timestamps"
|
||||
(either :left))
|
||||
(either :right sp))))
|
||||
(either :right nil)))
|
||||
(check-dead
|
||||
(planning)
|
||||
(if-let (dead (-some->> planning (org-ml-get-property :deadline)))
|
||||
(let ((dp (org-x-dag-partition-timestamp dead)))
|
||||
(cond
|
||||
((< 0 (plist-get dp :length))
|
||||
(either :left "Actions cannot have ranged deadlines"))
|
||||
((and child-bss (plist-get dp :repeater))
|
||||
(either :left "Projects cannot have repeated deadlines"))
|
||||
((org-x-dag-action-dead-after-parent-p ancestry dead)
|
||||
(either :left "Action deadline cannot end after parent deadline"))
|
||||
(t
|
||||
(either :right dp))))
|
||||
(either :right nil)))
|
||||
(check-todo
|
||||
(todo task-default)
|
||||
(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))
|
||||
(either :left "Projects cannot have effort"))
|
||||
((org-x-dag-action-dead-after-parent-p ancestry dead)
|
||||
(either :left "Action deadline cannot end after parent deadline"))
|
||||
((equal it-todo org-x-kw-todo)
|
||||
((and child-bss (equal todo org-x-kw-hold))
|
||||
(new-proj :proj-held))
|
||||
((equal todo org-x-kw-todo)
|
||||
(org-x-dag-bs-action-rankfold-children child-bss task-default
|
||||
(lambda (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)
|
||||
|
||||
;; any pair that makes it this far is completed in both,
|
||||
;; which means neither takes precedence, which means choose
|
||||
;; the left one
|
||||
;; which means neither takes precedence, which means
|
||||
;; choose the left one
|
||||
(`(,_ ,_) nil))
|
||||
(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)))))
|
||||
(e (error "Pattern fail: %s" e))))))
|
||||
(child-bss
|
||||
(org-x-dag-bs-error-kw "Project action" it-todo))
|
||||
(org-x-dag-bs-error-kw "Project action" todo))
|
||||
(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)
|
||||
(-let (((&plist :props) node-data))
|
||||
|
|
@ -1053,6 +1074,7 @@ deadline (eg via epoch time) or if it has a repeater."
|
|||
(ts-data child-scheds)
|
||||
(->> (list :dead (plist-get ts-data :dead)
|
||||
:child-scheds child-scheds
|
||||
;; TODO this can be an epoch and not a datetime
|
||||
:leading-sched-dt (-> (org-x-dag-pts-max child-scheds)
|
||||
(plist-get :datetime)))
|
||||
(funcall new-active-fun))))
|
||||
|
|
|
|||
|
|
@ -89,6 +89,20 @@ CLOSED: [2022-06-10 Fri 19:13]
|
|||
:ID: a834a585-acd1-44e9-8e62-17793146d6ab
|
||||
:CREATED: [2022-06-10 Fri 19:13]
|
||||
: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
|
||||
** TODO this is an iterator
|
||||
:PROPERTIES:
|
||||
|
|
|
|||
|
|
@ -46,6 +46,11 @@
|
|||
(->> (org-ml-from-string 'timestamp s)
|
||||
(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)
|
||||
(cl-destructuring-bind
|
||||
((a-expr . a) (x-expr . x))
|
||||
|
|
@ -112,6 +117,14 @@
|
|||
(and (eq (org-ml-get-type a) (org-ml-get-type 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)
|
||||
(-let (((a-diff b-diff common-diffs) (split-plists eq-funs a b)))
|
||||
(cond
|
||||
|
|
@ -173,12 +186,9 @@
|
|||
(let* ((ancestry (list :canceled-parent-p c
|
||||
:held-parent-p h
|
||||
:parent-deadline e))
|
||||
(ancestry-eq-funs (list :parent-deadline #'element-equal-p))
|
||||
(ancestry-eq-funs nil)
|
||||
(local-eq-funs (list :sched #'element-equal-p
|
||||
;; TODO this is wrong
|
||||
:child-scheds (lambda (a b)
|
||||
(seq-set-equal-p
|
||||
a b #'element-equal-p))))
|
||||
:child-scheds #'pts-equal-p))
|
||||
(f (->> (-partial #'status-diff-msg local-eq-funs test-expr y s d)
|
||||
(-partial #'ancestry-diff-msg ancestry-eq-funs test-expr ancestry)
|
||||
(-partial #'buffer-status-diff-msg test-expr :action)
|
||||
|
|
@ -280,7 +290,13 @@
|
|||
(it "Canceled"
|
||||
(expect "322af50a-f431-4940-8caf-cc5acdf5a555" :id-to-be-action
|
||||
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"
|
||||
(it "Active"
|
||||
|
|
|
|||
Loading…
Reference in New Issue