ADD a bunch of tests for actions

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

@@ -1,13 +1,93 @@
-* TODO this is a project
+* TODO this is an active project
 :PROPERTIES:
 :ID:       a98df83f-bc98-4767-b2bc-f1054dbf89f9
 :CREATED:  [2022-06-07 Tue 22:41]
 :END:
-** TODO this is a project task
+** NEXT this is a project task
 :PROPERTIES:
 :ID:       2db32ed8-0a1f-488c-8e41-dd3549ac8b1b
 :CREATED:  [2022-06-07 Tue 22:41]
 :END:
+* TODO this is an active project (scheduled)
+:PROPERTIES:
+:ID:       3788c7bc-390e-4caf-af8e-06831ff3276b
+:CREATED:  [2022-06-10 Fri 19:29]
+:END:
+** TODO this is a scheduled task
+SCHEDULED: <2022-06-10 Fri>
+:PROPERTIES:
+:ID:       19a7d558-e087-47ec-b686-feee29d352a1
+:CREATED:  [2022-06-10 Fri 19:29]
+:END:
+* TODO this is a waiting project
+:PROPERTIES:
+:ID:       26586b4d-7fc7-4a9f-b86f-e3c26a83a507
+:CREATED:  [2022-06-10 Fri 19:18]
+:END:
+** WAIT this is a waiting subtask
+:PROPERTIES:
+:ID:       cf58280a-ac7c-4951-a3de-a3f79f92f2b0
+:CREATED:  [2022-06-10 Fri 19:18]
+:END:
+* HOLD this is a held project
+:PROPERTIES:
+:ID:       d5065c21-b717-41fe-8232-22afbd6b2243
+:CREATED:  [2022-06-10 Fri 19:14]
+:END:
+** TODO this is a subtask masked by a hold
+:PROPERTIES:
+:ID:       ee9c6ec9-7626-40f5-9f06-3c91bc1338ed
+:CREATED:  [2022-06-10 Fri 19:14]
+:END:
+* TODO this is a project held by a subtask
+:PROPERTIES:
+:ID:       a771dc18-0c5f-4196-903d-ada3c8a9d817
+:CREATED:  [2022-06-10 Fri 19:15]
+:END:
+** HOLD this is a held subtask
+:PROPERTIES:
+:ID:       4f743d31-2df4-4e32-85de-cedae0cffeb2
+:CREATED:  [2022-06-10 Fri 19:15]
+:END:
+* TODO this is a stuck project
+:PROPERTIES:
+:CREATED:  [2022-06-07 Tue 22:41]
+:ID:       c93fe96f-7130-4433-a960-98c07a3b21f4
+:END:
+** TODO this is a subtask
+:PROPERTIES:
+:ID:       2def43a3-e814-4793-adc7-38ddbbf30411
+:CREATED:  [2022-06-10 Fri 19:08]
+:END:
+* DONE this is a completed project
+CLOSED: [2022-06-10 Fri 19:10]
+:PROPERTIES:
+:ID:       87682ef6-cd4c-41a7-8f0d-6ac41e572b05
+:CREATED:  [2022-06-10 Fri 19:10]
+:END:
+** DONE this is a completed subtask
+CLOSED: [2022-06-10 Fri 19:26]
+:PROPERTIES:
+:ID:       61866e72-7153-44d1-ae0f-af527fe5f9f4
+:CREATED:  [2022-06-10 Fri 19:10]
+:END:
+** CANC this is a cancelled task
+CLOSED: [2022-06-10 Fri 19:26]
+:PROPERTIES:
+:ID:       322af50a-f431-4940-8caf-cc5acdf5a555
+:CREATED:  [2022-06-10 Fri 19:25]
+:END:
+* CANC this is a cancelled project
+CLOSED: [2022-06-10 Fri 19:13]
+:PROPERTIES:
+:ID:       eca77dea-4a40-4697-a69d-d1ec798fe9ba
+:CREATED:  [2022-06-10 Fri 19:13]
+:END:
+** TODO this is a subtask masked by a cancel
+:PROPERTIES:
+:ID:       a834a585-acd1-44e9-8e62-17793146d6ab
+:CREATED:  [2022-06-10 Fri 19:13]
+:END:
 * TODO this is an iterator
 :PROPERTIES:
 :ID:       2711e9b9-f765-415d-930f-b7ff16b3140b

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

@@ -51,53 +51,186 @@
       (lambda ()
         `(nil . ,(format "Expected %s to be a left, got a right" a-expr))))))
 
-(buttercup-define-matcher :to-have-same-as-plist (a b)
+(buttercup-define-matcher :to-be-right-with (a x)
   (cl-destructuring-bind
-      ((a-expr . a) (b-expr . b))
+      ((a-expr . a) (x-expr . x))
-      (mapcar #'buttercup--expr-and-value (list a b))
+      (mapcar #'buttercup--expr-and-value (list a x))
-    (let* ((a* (-partition 2 a))
+    (either-from a
-           (b* (-partition 2 b))
+      (lambda ()
-           (a-diff (->> (-difference a* b*) (--map (format "%S" it)) (s-join ", ")))
+        `(nil . ,(format "Expected %s to be a right, got a left" a-expr)))
-           (b-diff (->> (-difference b* a*) (--map (format "%S" it)) (s-join ", "))))
+      (lambda (r)
-      (cond
+        (if (equal r x)
-       ((and a-diff b-diff)
+            `(t . ,(format "Expected %s right with %s" a-expr x))
-        (cons nil (format "Expected %s to have pairs '%s' and not to have pairs '%s'"
+          `(nil . ,(format "Expected %s right with %s, but got right with %s"
-                          a-expr b-diff a-diff)))
+                           a-expr x r)))))))
-       (a-diff
-        (cons nil (format "Expected %s not to have pairs '%s'" a-expr a-diff)))
-       (b-diff
-        (cons nil (format "Expected %s to have pairs '%s'" a-expr b-diff)))
-       (t
-        (cons t (format "Expected %s not to have same items as '%s'"
-                        a-expr b-expr)))))))
 
-;; (defun bs-error (id left)
+(defun split-plists (a b)
-;;   (let ((bs (org-x-dag-id->bs id)))
+  (let* ((a* (-partition 2 a))
-;;     (expect (either-is-left-p bs))
+         (b* (-partition 2 b))
-;;     (expect (either-from-left bs nil) :to-equal left)))
+         (a- (-difference a* b*))
+         (b- (-difference b* a*)))
+    `(,(-flatten-n 1 a-) ,(-flatten-n 1 b-))))
 
-;; (defun bs-action-equal (id ancestry local)
+(defun plist-diff-msg (expr a b)
-;;   (let ((bs (org-x-dag-id-bs id)))
+  (-let (((a-diff b-diff) (split-plists a b)))
-;;     (expect (either-is-right-p bs))
+    (cond
-;;     (from-either (org-x-dag-id-bs id)
+     ((and a-diff b-diff)
-;;   (expect (org-x-dag-id-bs id) :to-equal bs))
+      (format "Expected %s to have pairs '%s' and not to have pairs '%s'"
+              expr b-diff a-diff))
+     (a-diff
+      (format "Expected %s not to have pairs '%s'" expr a-diff))
+     (b-diff
+      (format "Expected %s to have pairs '%s'" expr b-diff)))))
+
+(defun status-diff-msg (expr type subtype data to-test)
+  (-let* (((type* . rest) to-test)
+          ((subtype* last) (-split-at (length subtype) rest))
+          (data* (car last)))
+    (cond
+     ((not (eq type* type))
+      (format "Expected %s to have type '%s' but instead had type '%s'"
+              expr type type*))
+     ((and subtype (not (equal subtype* subtype)))
+      (format "Expected %s to have subtype '%s' but instead had subtype '%s'"
+              expr subtype subtype*))
+     (t
+      (plist-diff-msg expr data data*)))))
+
+(defun ancestry-diff-msg (expr ancestry inner-fun to-test)
+  (declare (indent 3))
+  (-let* (((&plist :ancestry A :local L) to-test))
+    (or (plist-diff-msg expr A ancestry)
+        (funcall inner-fun L))))
+
+(defun buffer-status-diff-msg (expr type inner-fun to-test)
+  (declare (indent 3))
+  (-let (((type* . rest) to-test))
+    (if (eq type type*) (funcall inner-fun rest)
+      (format "Expected buffer-status %s to be type '%s' but instead was type '%s'"
+              expr type type*))))
+
+(defun right-diff-msg (expr inner-fun to-test)
+  (declare (indent 2))
+  (either-from to-test
+    (lambda ()
+      (format "Expected %s to be a right, got a left" expr))
+    inner-fun))
+
+(buttercup-define-matcher :id-to-be-action (to-test canceled held deadline
+                                                    type subtype data)
+  (cl-destructuring-bind
+      ((test-expr . test) (_ . c) (_ . h) (_ . e) (_ . y) (_ . s) (_ . d))
+      (->> (list to-test canceled held deadline type subtype data)
+           (-map #'buttercup--expr-and-value))
+    (let* ((ancestry (list :canceled-parent-p c
+                           :held-parent-p h
+                           :parent-deadline e))
+           (f (->> (-partial #'status-diff-msg test-expr y s d)
+                   (-partial #'ancestry-diff-msg 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)))
+        (cons nil m)
+      (cons t (format "Expected '%s' not to be the indicated action" test-expr))))))
+
+;; (buttercup-define-matcher :to-have-same-as-plist (a b)
+;;   (cl-destructuring-bind
+;;       ((a-expr . a) (b-expr . b))
+;;       (mapcar #'buttercup--expr-and-value (list a b))
+;;     (let* ((a* (-partition 2 a))
+;;            (b* (-partition 2 b))
+;;            (a-diff (->> (-difference a* b*) (--map (format "%S" it)) (s-join ", ")))
+;;            (b-diff (->> (-difference b* a*) (--map (format "%S" it)) (s-join ", "))))
+;;       (cond
+;;        ((and a-diff b-diff)
+;;         (cons nil (format "Expected %s to have pairs '%s' and not to have pairs '%s'"
+;;                           a-expr b-diff a-diff)))
+;;        (a-diff
+;;         (cons nil (format "Expected %s not to have pairs '%s'" a-expr a-diff)))
+;;        (b-diff
+;;         (cons nil (format "Expected %s to have pairs '%s'" a-expr b-diff)))
+;;        (t
+;;         (cons t (format "Expected %s not to have same items as '%s'"
+;;                         a-expr b-expr)))))))
+
+(defmacro bs-ltg-active (id)
+  (declare (indent 1))
+  `(expect (org-x-dag-id->bs ,id) :to-be-right-with '(:lifetime :active)))
 
 (describe "Sync DAG"
-  ;; TODO this won't actually fail if there is an error
+  (before-all
+    (setup))
+
   (it "Sync completes without error"
-    (setup)
+    (expect (org-x-dag-sync t) :not :to-throw))
-    (org-x-dag-sync t))
 
-  (it "One random hash is present in the dag"
+  (describe "Action buffer statuses"
-    (expect (org-x-dag-id->title "06592f95-9cf5-4d7e-8546-da7796d76813")
+    (describe "Projects"
-            :to-equal
+      (it "Active"
-            "don't be a dick"))
+        (expect "a98df83f-bc98-4767-b2bc-f1054dbf89f9" :id-to-be-action
+                nil nil nil :sp-proj '(:proj-active) '(:child-scheds nil)))
 
-  (it "test my own macros"
+      ;; TODO these tests are broken because I don't have a robust way
-    (expect (either :left "blabla") :to-be-left-with "blabla"))
+      ;; to compare the equality of org elements here (likely will need to
+      ;; steal something from the org-ml code, and then tell the plist
+      ;; checker which equality tests to use)
+      ;; (it "Active (scheduled)"
+      ;;   (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 "test my own macros"
+      (it "Wait"
-    (expect '(:a 1) :to-have-same-as-plist '(:b 1))))
+        (expect "26586b4d-7fc7-4a9f-b86f-e3c26a83a507" :id-to-be-action
+                nil nil nil :sp-proj '(:proj-wait) nil))
+
+      (it "Held (toplevel)"
+        (expect "d5065c21-b717-41fe-8232-22afbd6b2243" :id-to-be-action
+                nil nil nil :sp-proj '(:proj-held) nil))
+
+      (it "Held (subtask)"
+        (expect "a771dc18-0c5f-4196-903d-ada3c8a9d817" :id-to-be-action
+                nil nil nil :sp-proj '(:proj-held) nil))
+
+      (it "Stuck"
+        (expect "c93fe96f-7130-4433-a960-98c07a3b21f4" :id-to-be-action
+                nil nil nil :sp-proj '(:proj-stuck) nil))
+
+      (it "Completed"
+        (expect "87682ef6-cd4c-41a7-8f0d-6ac41e572b05" :id-to-be-action
+                nil nil nil :sp-proj '(:proj-complete)
+                '(:canceledp nil :epoch 1654902600)))
+      
+      (it "Canceled"
+        (expect "eca77dea-4a40-4697-a69d-d1ec798fe9ba" :id-to-be-action
+                nil nil nil :sp-proj '(:proj-complete)
+                '(:canceledp t :epoch 1654902780))))
+
+    (describe "Tasks"
+      (it "Active"
+        (expect "2db32ed8-0a1f-488c-8e41-dd3549ac8b1b" :id-to-be-action
+                nil nil nil :sp-task '(:task-active)
+                '(:todo "NEXT" :sched nil :dead nil)))
+
+      (it "Waiting"
+        (expect "cf58280a-ac7c-4951-a3de-a3f79f92f2b0" :id-to-be-action
+                nil nil nil :sp-task '(:task-active)
+                '(:todo "WAIT" :sched nil :dead nil)))
+
+      (it "Held"
+        (expect "4f743d31-2df4-4e32-85de-cedae0cffeb2" :id-to-be-action
+                nil nil nil :sp-task '(:task-active)
+                '(:todo "HOLD" :sched nil :dead nil)))
+
+      (it "Completed"
+        (expect "61866e72-7153-44d1-ae0f-af527fe5f9f4" :id-to-be-action
+                nil nil nil :sp-task '(:task-complete)
+                '(:canceledp nil :epoch 1654903560)))
+
+      (it "Canceled"
+        (expect "322af50a-f431-4940-8caf-cc5acdf5a555" :id-to-be-action
+                nil nil nil :sp-task '(:task-complete)
+                '(:canceledp t :epoch 1654903560))))))
 
 (provide 'org-x-dag-test)
 ;;; org-x-dag-test.el ends here