diff --git a/local/lib/either/either.el b/local/lib/either/either.el index c3fa150..6271511 100644 --- a/local/lib/either/either.el +++ b/local/lib/either/either.el @@ -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). diff --git a/local/lib/org-x/org-x-dag.el b/local/lib/org-x/org-x-dag.el index 53d3304..c5e50b1 100644 --- a/local/lib/org-x/org-x-dag.el +++ b/local/lib/org-x/org-x-dag.el @@ -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)))) diff --git a/local/lib/org-x/test/dag/action1.org b/local/lib/org-x/test/dag/action1.org index 15d9449..a11b3ef 100644 --- a/local/lib/org-x/test/dag/action1.org +++ b/local/lib/org-x/test/dag/action1.org @@ -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: diff --git a/local/lib/org-x/test/org-x-dag-test.el b/local/lib/org-x/test/org-x-dag-test.el index d0f58af..5d35f1b 100644 --- a/local/lib/org-x/test/org-x-dag-test.el +++ b/local/lib/org-x/test/org-x-dag-test.el @@ -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"