ENH make errors for sub-iterators more precise (and working)

local/lib/org-x/org-x-dag.el

@@ -88,14 +88,21 @@
 
 ;; datetime operations
 
-(defmacro org-x-dag-with-times (datetime0 datetime1 form)
+(defun org-x-dag-datetimes-same-length-p (datetime0 datetime1)
   ;; ASSUME all digits in this comparison are on the calendar/clock (eg day 32
   ;; does not 'rollover' to day 1 on the next month)
+  (not (xor (org-ml-time-is-long datetime0) (org-ml-time-is-long datetime1))))
+
+;; Maybe a -> Maybe a -> (a -> a -> b) -> b -> Maybe b
+(defun org-x-dag-with-datetimes (a b fun alt)
+  (when (and a b)
+    (if (org-x-dag-datetimes-same-length-p a b)
+        (funcall fun a b)
+      (funcall alt))))
+
+(defmacro org-x-dag-with-times (datetime0 datetime1 form)
   (declare (indent 2))
-  `(if (or (and (org-ml-time-is-long ,datetime0)
+  `(if (org-x-dag-datetimes-same-length-p datetime0 datetime1)
-                (org-ml-time-is-long ,datetime1))
-           (not (or (org-ml-time-is-long ,datetime0)
-                    (org-ml-time-is-long ,datetime1))))
        ,form
      (error "Datetimes are invalid lengths: %S and %S" ,datetime0 ,datetime1)))
 
@@ -126,6 +133,12 @@
          (--drop-while (= (car it) (cdr it)))
          (not))))
 
+(defun org-x-dag-datetime-compare (a b)
+  (cond
+   ((org-x-dag-datetime= a b) 'eq)
+   ((org-x-dag-datetime< a b) 'gt)
+   (t 'lt)))
+
 (defun org-x-dag-date< (datetime0 datetime1)
   (org-x-dag-datetime< (org-x-dag-datetime-to-date datetime0)
                        (org-x-dag-datetime-to-date datetime1)))
@@ -141,6 +154,12 @@
   (org-x-dag-datetime= (org-x-dag-datetime-to-date datetime0)
                        (org-x-dag-datetime-to-date datetime1)))
 
+(defun org-x-dag-datetime-max (datetimes)
+  (-max-by #'org-x-dag-datetime< datetimes))
+
+(defun org-x-dag-date-max (datetimes)
+  (-max-by #'org-x-dag-date< datetimes))
+
 (defun org-x-dag-datetime-shift (datetime shift unit)
   (cl-flet*
       ((enc-dec-long
@@ -173,6 +192,9 @@
 
 ;; date <-> epoch
 
+(defun org-x-dag-datetime-to-epoch (date)
+  (float-time (encode-time `(0 ,@(reverse date) nil -1 nil))))
+
 (defun org-x-dag-date-to-epoch (date)
   (float-time (encode-time `(0 0 0 ,@(reverse date) nil -1 nil))))
 
@@ -375,6 +397,36 @@ relative shift in days from ABS."
 ;;           (org-x-dag-format-month-tag m)
 ;;           (org-x-dag-format-day-tag d))))
 
+;; timestamps <-> datetime
+
+(defun org-x-dag-partition-timestamp (ts)
+  (list :datetime (org-ml-timestamp-get-start-time ts)
+        :length (org-ml-timestamp-get-range ts)
+        :pos (org-ml-get-property :begin ts)
+        :repeater (org-ml-timestamp-extract-modulus 'repeater ts)
+        :warning (org-ml-timestamp-extract-modulus 'warning ts)))
+
+(defun org-x--dag-pts-compare (fun a b)
+  (funcall (-on fun (lambda (ts) (plist-get ts :datetime))) a b))
+
+(defun org-x-dag-pts-compare (a b)
+  (org-x--dag-pts-compare #'org-x-dag-datetime-compare a b))
+
+(defun org-x-dag-pts= (a b)
+  (org-x--dag-pts-compare #'org-x-dag-datetime= a b))
+
+(defun org-x-dag-pts< (a b)
+  (org-x--dag-pts-compare #'org-x-dag-datetime< a b))
+
+(defun org-x-dag-pts> (a b)
+  (org-x--dag-pts-compare #'org-x-dag-datetime> a b))
+
+(defun org-x-dag-pts-max (ps)
+  (-max-by #'org-x-dag-pts> ps))
+
+(defun org-x-dag-pts-is-long-p (pts)
+  (org-ml-time-is-long (plist-get pts :datetime)))
+
 ;; allocation
 
 (pcase-defmacro regexp (capture regexp)
@@ -699,7 +751,8 @@ used for optimization."
         (pcase (car bss)
           (`(:right ,r)
            (if (funcall stop-fun r)
-               (->> (funcall acc-fun r)
+               (->> (either-rights bss)
+                    (--mapcat (funcall acc-fun it))
                     (funcall trans-fun r))
              (either>>= (fold-rank (list r nil) (cdr bss))
                (-let (((cur as) it))
@@ -708,8 +761,11 @@ used for optimization."
 
 (defun org-x-dag-bs-action-rankfold-children (bss default rank-fun stop-fun
                                                   acc-fun trans-fun)
-  (cl-flet ((get-local (x) (plist-get x :local)))
+  (declare (indent 2))
-    (declare (indent 2))
+  (cl-flet
+      ((get-local
+        (x)
+        (plist-get x :local)))
     (org-x-dag-bs-rankfold-children bss default
       (-on rank-fun #'get-local)
       (-compose stop-fun #'get-local)
@@ -947,51 +1003,87 @@ deadline (eg via epoch time) or if it has a repeater."
 
 (defun org-x-dag-bs-action-subiter-todo-fold (child-bss default trans-fun)
   (declare (indent 2))
-  (org-x-dag-bs-action-rankfold-children child-bss default
+  (cl-flet*
-    (lambda (acc next)
+      ((fmt-left
-      (pcase `(,acc ,next)
+        (sched? wrong)
-        ;; for active tasks, the furthest in the future is ranked the highest
+        (let ((what (if sched? "scheduled" "deadlined")))
-        (`((:si-task :task-active ,a) (:si-task :task-active ,b))
+          (org-x-dag-left "Sub-iter %s timestamps %s" what wrong)))
-         (-let (((&plist :sched as :dead ad) a)
+       (fmt-left-both
-                ((&plist :sched bs :dead bd) b))
+        (wrong)
-           (cond
+        (org-x-dag-left "Sub-iter scheduled/deadlined timestamps %s" wrong))
-            ((or (xor as bs) (xor ad bd))
+       (fmt-left-2
-             (->> "All sub-iters must have the same planning configuration"
+        (sched-wrong dead-wrong)
-                  (either :left)))
+        (org-x-dag-left
-            ((and as bs (xor (org-ml-time-is-long as) (org-ml-time-is-long bs)))
+         "Sub-iter scheduled timestamps %s and deadlined timestamps %s"
-             (->> "Sub-iters must have scheduled timestamp with same length"
+         sched-wrong dead-wrong))
-                  (either :left)))
+       (compare
-            ((and ad bd (xor (org-ml-time-is-long ad) (org-ml-time-is-long bd)))
+        (a b)
-             (->> "Sub-iters must have deadline timestamp with same length"
+        (cond
-                  (either :left)))
+         ((not (or a b)) (either :left nil))
-            ;; ASSUME this won't fail since the datetimes are assumed to be the
+         ((xor a b) (either :left 'presence))
-            ;; same length as per rules above
+         (t
-            ((and ad bd)
+          (org-x-dag-with-datetimes
-             (->> (org-x-dag-datetime< (org-ml-timestamp-get-start-time ad)
+           a b
-                                       (org-ml-timestamp-get-start-time bd))
+           (lambda (a b)
-                  (either :right)))
+             (either :right (org-x-dag-pts-compare a b)))
-            (t
+           (-const (either :left 'length))))))
-             (->> (org-x-dag-datetime< (org-ml-timestamp-get-start-time as)
+       (comp2right
-                                       (org-ml-timestamp-get-start-time bs))
+        (sched? comp)
-                  (either :right))))))
+        (if (eq comp 'eq) (fmt-left sched? "should be different")
-        ((or `((:si-task . ,_) (:si-proj . ,_))
+          (either :right (eq comp 'gt))))
-             `((:si-proj . ,_) (:si-task . ,_)))
+       (left2err
-         (either :left "Sub-iterators must have same project structure"))
+        (sym)
-        (`(,(or `(:si-task :task-active ,_) `(:si-proj :proj-active ,_)) ,_)
+        (pcase sym
-         (either :right nil))
+          (`presence "should be on all or none")
-        (`(,_ ,(or `(:si-task :task-active ,_) `(:si-proj :proj-active ,_)))
+          (`length "must have same length")))
-         (either :right t))
+       (sym-left
-        (`(,_ ,_) (either :right nil))))
+        (sched? sym)
-    (lambda (next)
+        (fmt-left sched? (left2err sym)))
-      (pcase next
+       (sym-left-2
-        ((or `(:si-task :task-active ,_) `(:si-proj :proj-active ,_)) t)
+        (sched-sym dead-sym)
-        (_ nil)))
+        (if (eq sched-sym dead-sym) (fmt-left-both (left2err sched-sym))
-    (lambda (next)
+          (fmt-left-2 (left2err sched-sym) (left2err dead-sym)))))
-      (pcase next
+    (org-x-dag-bs-action-rankfold-children child-bss default
-        (`(:si-proj :proj-active ,d) (plist-get d :child-scheds))
+      (lambda (acc next)
-        (`(:si-task :task-active ,d) (list (plist-get d :sched)))
+        (pcase `(,acc ,next)
-        (_ nil)))
+          ;; for active tasks, the furthest in the future is ranked the highest
-    trans-fun))
+          (`((:si-task :task-active ,a) (:si-task :task-active ,b))
+           (-let (((&plist :sched as :dead ad) a)
+                  ((&plist :sched bs :dead bd) b))
+             (pcase `(,(compare as bs) ,(compare ad bd))
+               (`((:left ,s) (:right ,d)) (if s (sym-left t s) (comp2right nil d)))
+               (`((:right ,s) (:left ,d)) (if d (sym-left nil d) (comp2right t s)))
+               (`((:right ,s) (:right ,d))
+                (pcase `(,s ,d)
+                  (`(gt gt) (either :right t))
+                  (`(lt lt) (either :right nil))
+                  ((or `(gt lt) `(lt gt)) (fmt-left-both "should not cross"))
+                  (`(eq eq) (fmt-left-both "should be different"))
+                  (`(eq ,_) (fmt-left t "should be different"))
+                  (`(,_ eq) (fmt-left nil "should be different"))))
+               (`((:left ,s) (:left ,d))
+                (cond
+                 ((and s d) (sym-left-2 s d))
+                 (s (sym-left t s))
+                 (d (sym-left nil d)))))))
+          ((or `((:si-task . ,_) (:si-proj . ,_))
+               `((:si-proj . ,_) (:si-task . ,_)))
+           (either :left "Sub-iterators must have same project structure"))
+          (`(,(or `(:si-task :task-active ,_) `(:si-proj :proj-active ,_)) ,_)
+           (either :right nil))
+          (`(,_ ,(or `(:si-task :task-active ,_) `(:si-proj :proj-active ,_)))
+           (either :right t))
+          (`(,_ ,_) (either :right nil))))
+      (lambda (next)
+        (pcase next
+          ((or `(:si-task :task-active ,_) `(:si-proj :proj-active ,_)) t)
+          (_ nil)))
+      (lambda (next)
+        (pcase next
+          (`(:si-proj :proj-active ,d) (plist-get d :child-scheds))
+          (`(:si-task :task-active ,d) (-some-> (plist-get d :sched) (list)))
+          (_ nil)))
+      trans-fun)))
 
 (defun org-x-dag-node-is-iterator-p (node)
   (org-x-dag-node-data-is-iterator-p (plist-get node :node-meta)))
@@ -1013,20 +1105,30 @@ deadline (eg via epoch time) or if it has a repeater."
         (lambda (c) `(:si-proj :proj-complete ,c))
         (lambda (c) `(:si-task :task-complete ,c)))
 
-      (-let (((sched dead) (-some->> it-planning
+      (-let* (((sched dead) (-some->> it-planning
-                             (org-ml-get-properties '(:scheduled :deadline)))))
+                              (org-ml-get-properties '(:scheduled :deadline))))
+              (sp (-some-> sched (org-x-dag-partition-timestamp)))
+              (dp (-some-> dead (org-x-dag-partition-timestamp))))
         (cond
-         ((and sched child-bss)
+         ((and sp child-bss)
           (either :left "Project sub-iterators cannot be scheduled"))
-         ((and dead child-bss)
+         ((and dp child-bss)
           (either :left "Project sub-iterators cannot be deadlined"))
          ((org-x-dag-node-data-is-iterator-p node-data)
           (either :left "Iterators cannot be nested"))
          ((org-x-dag-action-dead-after-parent-p ancestry dead)
           (either :left "Sub-iterator deadline must not start after parent"))
-         ((equal it-todo org-x-kw-todo)
+         ((and sp (plist-get sp :repeater))
+          (either :left "Scheduled sub-iterators cannot repeat"))
+         ((and dp (plist-get dp :repeater))
+          (either :left "Deadlined sub-iterators cannot repeat"))
+         ((and sp (< 0 (plist-get sp :length)))
+          (either :left "Scheduled sub-iterators cannot be ranged"))
+         ((and dp (< 0 (plist-get dp :length)))
+          (either :left "Deadlined sub-iterators cannot be ranged"))
+         ((member it-todo (list org-x-kw-todo org-x-kw-wait))
           (org-x-dag-bs-action-subiter-todo-fold child-bss
-              `(:si-task :task-active (:sched ,sched :dead ,dead))
+              `(:si-task :task-active (:sched ,sp :dead ,dp))
             (lambda (acc cs)
               (pcase acc
                 ((or `(:si-proj :proj-complete ,_)
@@ -1037,7 +1139,8 @@ deadline (eg via epoch time) or if it has a repeater."
                  (-let (((&plist :dead d :leading-sched s) ts-data))
                    (new-active-proj d s cs)))
                 (`(:si-task :task-active ,ts-data)
-                 (-let (((&plist :dead d :sched s) ts-data))
+                 (-let (((&plist :dead d) ts-data)
+                        ((&plist :datetime s) (org-x-dag-pts-max cs)))
                    (new-active-proj d s cs)))
                 (e (error "Invalid pattern: %s" e))))))
          (t
@@ -1067,7 +1170,8 @@ deadline (eg via epoch time) or if it has a repeater."
                    `(:si-proj :proj-complete ,_))
                (either :right '(:iter-nonempty :nonempty-complete)))
               (`(:si-task :task-active ,ts-data)
-               (-let (((&plist :dead d :sched s) ts-data))
+               (-let* (((&plist :dead d) ts-data)
+                       ((&plist :datetime s) (org-x-dag-pts-max cs)))
                  (new-active-iter d s cs)))
               (`(:si-proj :proj-active ,ts-data)
                (-let (((&plist :dead d :leading-sched s) ts-data))
@@ -2775,12 +2879,6 @@ encountered will be returned."
               (u (convert-unit unit)))
           `(,v ,u ,type))))))
 
-(defun org-x-dag-partition-timestamp (ts)
-  (list :datetime (org-ml-timestamp-get-start-time ts)
-        :pos (org-ml-get-property :begin ts)
-        :repeater (org-ml-timestamp-extract-modulus 'repeater ts)
-        :warning (org-ml-timestamp-extract-modulus 'warning ts)))
-
 (defun org-x-dag-repeater-get-next (sel-datetime datetime shift shifttype reptype)
   "Return the next timestamp repeater of DATETIME."
   (pcase reptype
@@ -3127,8 +3225,8 @@ FUTURE-LIMIT in a list."
           (`(:iter-empty :empty-active ,_) :empty)
           (`(:iter-nonempty :nonempty-active ,data)
            (-let* (((&plist :dead d :leading-sched s) data)
-                   (d* (-some->> d (org-x-dag-timestamp-to-epoch)))
+                   (d* (-some->> d (org-x-dag-datetime-to-epoch)))
-                   (s* (-some->> s (org-x-dag-timestamp-to-epoch))))
+                   (s* (-some->> s (org-x-dag-datetime-to-epoch))))
              (-if-let (epoch (if (and d* s*) (min d* s*) (or s* d*)))
                  (if (< (+ (float-time) org-x-iterator-active-future-offset)
                         epoch)

local/lib/org-x/test/org-x-dag-test.el

@@ -38,6 +38,10 @@
         org-x-weekly-plan-file "weekly.org"
         org-x-quarterly-plan-file "quarterly.org"))
 
+(defun partition-timestamp (s)
+  (->> (org-ml-from-string 'timestamp s)
+       (org-x-dag-partition-timestamp)))
+
 (buttercup-define-matcher :to-be-left-with (a x)
   (cl-destructuring-bind
       ((a-expr . a) (x-expr . x))
@@ -64,25 +68,65 @@
           `(nil . ,(format "Expected %s right with %s, but got right with %s"
                            a-expr x r)))))))
 
-(defun split-plists (a b)
+(defun split-plists (eq-funs a b)
-  (let* ((a* (-partition 2 a))
+  (cl-flet
-         (b* (-partition 2 b))
+      ((get-keys
-         (a- (-difference a* b*))
+        (x)
-         (b- (-difference b* a*)))
+        (->> (-partition 2 x)
-    `(,(-flatten-n 1 a-) ,(-flatten-n 1 b-))))
+             (-map #'car)))
+       (key-eq
+        (k)
+        (let ((av (plist-get a k))
+              (bv (plist-get b k))
+              (f (or (plist-get eq-funs k) #'equal)))
+          (funcall f av bv))))
+    (let* ((a* (get-keys a))
+           (b* (get-keys b))
+           (a- (-difference a* b*))
+           (b- (-difference b* a*))
+           (common (->> (-intersection a* b*)
+                        (--reduce-from (if (key-eq it) acc
+                                         (cons (list it
+                                                     (plist-get a it)
+                                                     (plist-get b it))
+                                               acc))
+                                       nil))))
+      `(,a- ,b- ,common))))
 
-(defun plist-diff-msg (expr a b)
+(defun plists-equal-p (a b)
-  (-let (((a-diff b-diff) (split-plists a b)))
+  (equal (split-plists nil a b) '(nil nil nil)))
+
+(defun element-equal-p (a b)
+  ;; NOTE this does not compare children of elements/objects
+  (cl-flet
+      ((get-useful-props
+        (node)
+        (->> (org-ml-get-all-properties node)
+             (-partition 2)
+             (--remove (memq (car it) '(:parent :begin :end :contents-begin :contents-end)))
+             (-flatten-n 1))))
+    (and (eq (org-ml-get-type a) (org-ml-get-type b))
+         (plists-equal-p (get-useful-props a) (get-useful-props b)))))
+
+(defun plist-diff-msg (eq-funs expr a b)
+  (-let (((a-diff b-diff common-diffs) (split-plists eq-funs a b)))
     (cond
      ((and a-diff b-diff)
-      (format "Expected %s to have pairs '%s' and not to have pairs '%s'"
+      (format "Expected %s to have keys '%s' and not to have keys '%s'"
               expr b-diff a-diff))
      (a-diff
-      (format "Expected %s not to have pairs '%s'" expr a-diff))
+      (format "Expected %s not to have keys '%s'" expr a-diff))
      (b-diff
-      (format "Expected %s to have pairs '%s'" expr b-diff)))))
+      (format "Expected %s to have keys '%s'" expr b-diff))
+     (common-diffs
+      (-let (((as bs)
+              (->> common-diffs
+                   (--map `((,(car it) ,(nth 1 it)) (,(car it) ,(nth 2 it))))
+                   (apply #'-zip-lists))))
+        (format "Expected %s to have key/value pairs '%s' but instead had '%s'"
+                expr as bs))))))
 
-(defun status-diff-msg (expr type subtype data to-test)
+(defun status-diff-msg (eq-funs expr type subtype data to-test)
   (-let* (((type* . rest) to-test)
           ((subtype* last) (-split-at (length subtype) rest))
           (data* (car last)))
@@ -94,12 +138,12 @@
       (format "Expected %s to have subtype '%s' but instead had subtype '%s'"
               expr subtype subtype*))
      (t
-      (plist-diff-msg expr data data*)))))
+      (plist-diff-msg eq-funs expr data data*)))))
 
-(defun ancestry-diff-msg (expr ancestry inner-fun to-test)
+(defun ancestry-diff-msg (eq-funs expr ancestry inner-fun to-test)
   (declare (indent 3))
   (-let* (((&plist :ancestry A :local L) to-test))
-    (or (plist-diff-msg expr A ancestry)
+    (or (plist-diff-msg eq-funs expr A ancestry)
         (funcall inner-fun L))))
 
 (defun buffer-status-diff-msg (expr type inner-fun to-test)
@@ -125,8 +169,14 @@
     (let* ((ancestry (list :canceled-parent-p c
                            :held-parent-p h
                            :parent-deadline e))
-           (f (->> (-partial #'status-diff-msg test-expr y s d)
+           (ancestry-eq-funs (list :parent-deadline #'element-equal-p))
-                   (-partial #'ancestry-diff-msg test-expr ancestry)
+           (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))))
+           (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)
                    (-partial #'right-diff-msg test-expr))))
       (-if-let (m (funcall f (org-x-dag-id->bs test)))
@@ -170,15 +220,11 @@
         (expect "a98df83f-bc98-4767-b2bc-f1054dbf89f9" :id-to-be-action
                 nil nil nil :sp-proj '(:proj-active) '(:child-scheds nil)))
 
-      ;; TODO these tests are broken because I don't have a robust way
+      (it "Active (scheduled)"
-      ;; to compare the equality of org elements here (likely will need to
+        (let ((sched (org-ml-from-string 'timestamp "<2022-06-10 Fri>")))
-      ;; steal something from the org-ml code, and then tell the plist
+          (expect "3788c7bc-390e-4caf-af8e-06831ff3276b" :id-to-be-action
-      ;; checker which equality tests to use)
+                  nil nil nil :sp-proj '(:proj-active)
-      ;; (it "Active (scheduled)"
+                  `(:child-scheds (,sched)))))
-      ;;   (let ((sched (org-ml-from-string 'timestamp "<2022-06-10 Fri>")))
-      ;;     (expect "3788c7bc-390e-4caf-af8e-06831ff3276b" :id-to-be-action
-      ;;             nil nil nil :sp-proj '(:proj-active)
-      ;;             `(:child-scheds (,sched)))))
 
       (it "Wait"
         (expect "26586b4d-7fc7-4a9f-b86f-e3c26a83a507" :id-to-be-action
@@ -230,7 +276,18 @@
       (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))))
+
+    (describe "Iterators"
+      (it "Active non-empty"
+        (let ((s0 (partition-timestamp "<2022-06-07 Tue>"))
+              (s1 (partition-timestamp "<2022-06-14 Tue>"))
+              (s2 (partition-timestamp "<2022-06-21 Tue>")))
+          (expect "2711e9b9-f765-415d-930f-b7ff16b3140b" :id-to-be-action
+                  nil nil nil :sp-iter '(:iter-nonempty :nonempty-active)
+                  (list :child-scheds `(,s0 ,s1 ,s2)
+                        :leading-sched (plist-get s2 :datetime)
+                        :dead nil)))))))
 
 (provide 'org-x-dag-test)
 ;;; org-x-dag-test.el ends here