Simple test harness

syndicate/bag.rkt

@@ -10,7 +10,8 @@
          bag-member?
          in-bag
          in-bag/count
-         set->bag)
+         set->bag
+         bag->set)
 
 (require racket/set)
 
@@ -55,3 +56,6 @@
 (define (set->bag s [count 1])
   (for/hash [(e (in-set s))]
     (values e count)))
+
+(define (bag->set b)
+  (list->set (hash-keys b)))

syndicate/dataspace.rkt

@@ -8,6 +8,7 @@
          (struct-out observe)
 
          dataspace?
+         dataspace-assertions ;; TODO: shouldn't be provided - needed by test.rkt
          generate-id! ;; TODO: shouldn't be provided - inline syntax.rkt??
 
          actor?
@@ -25,6 +26,8 @@
          field-handle-owner
          field-handle-value
 
+         current-actor-crash-logger
+
          current-actor
          current-facet
          in-script? ;; TODO: shouldn't be provided - inline syntax.rkt??
@@ -169,6 +172,12 @@
          (field-handle-owner f)
          (current-actor)))
 
+;; Parameterof (Actor Exn -> Void)
+(define current-actor-crash-logger
+  (make-parameter
+   (lambda (a e)
+     (log-error "Actor ~a died with exception:\n~a" a (exn->string e)))))
+
 ;; Parameterof Actor
 (define current-actor (make-parameter #f))
 
@@ -259,7 +268,7 @@
                    (in-script? script?))
       (with-handlers ([(lambda (e) (not (exn:break? e)))
                        (lambda (e)
-                         (log-error "Actor ~a died with exception:\n~a" a (exn->string e))
+                         ((current-actor-crash-logger) a e)
                          (abandon-queued-work! a)
                          (terminate-actor! a))]) ;; TODO: tracing
         (call-with-syndicate-prompt

syndicate/syntax.rkt

@@ -581,121 +581,148 @@
 ;;---------------------------------------------------------------------------
 
 (module+ test
-  (message-struct set-box (new-value))
+  (require "test.rkt")
-  (assertion-struct box-state (value))
 
-  (define ds
+  (test-case
-    (make-dataspace
-     (lambda ()
-       (schedule-script!
-        (current-actor)
-
-        #;(lambda ()
       ;; See .../syndicate/examples/actor/example-during-criterion-shapshotting.rkt
-
+      [(struct foo (x y) #:prefab)
-          (struct foo (x y) #:prefab)
-
        (spawn (field [x 123])
               (assert (foo (x) 999))
               (during (foo (x) $v)
-                   (log-info "x=~a v=~a" (x) v)
+                (printf "x=~a v=~a\n" (x) v)
                 (when (= (x) 123) (x 124))
-                   (on-stop
+                (on-stop (printf "finally for x=~a v=~a\n" (x) v))))]
-                    (log-info "finally for x=~a v=~a" (x) v))))
+    no-crashes
-          )
+    (expected-output "x=123 v=999"
+                     "x=124 v=999"
+                     "finally for x=124 v=999"))
 
-        #;(lambda ()
+  (test-case
       ;; Goal: no matter the circumstances (e.g. exception in a
       ;; stop script), we will never retract an assertion more or
       ;; fewer than the correct number of times.
-
+      [(spawn #:name 'supply
-          ;; Expected output:
+              #:assertions ['marker]
-          ;;
-          ;; marker appeared
-          ;; marker disappeared
-          ;;
-          ;; (plus the exception report for "Deliberate error")
-
-          (spawn #:assertions ['marker]
               (assert 'marker) ;; NB this is the change wrt the test case immediately below
-                 (error 'test-case "Deliberate error")
+              (error 'test-case "Deliberate error"))
-                 (void))
 
        (spawn (on (asserted 'marker) (printf "marker appeared\n"))
-                 (on (retracted 'marker) (printf "marker disappeared\n")))
+              (on (retracted 'marker) (printf "marker disappeared\n")))]
-          )
+    (it "should crash deliberately" (actor-died? 'supply "Deliberate error"))
+    (expected-output "marker appeared"
+                     "marker disappeared"))
 
-        #;(lambda ()
+  (test-case
       ;; Goal: no matter the circumstances (e.g. exception in a
       ;; stop script), we will never retract an assertion more or
       ;; fewer than the correct number of times.
-
+      [(spawn #:name 'supply
-          ;; Expected output:
+              #:assertions ['marker]
-          ;;
+              (error 'test-case "Deliberate error"))
-          ;; marker appeared
-          ;; marker disappeared
-          ;;
-          ;; (plus the exception report for "Deliberate error")
-
-          (spawn #:assertions ['marker]
-                 (error 'test-case "Deliberate error")
-                 (void))
 
        (spawn (on (asserted 'marker) (printf "marker appeared\n"))
-                 (on (retracted 'marker) (printf "marker disappeared\n")))
+              (on (retracted 'marker) (printf "marker disappeared\n")))]
-          )
+    (it "should crash deliberately" (actor-died? 'supply "Deliberate error"))
+    (expected-output "marker appeared"
+                     "marker disappeared"))
 
-        #;(lambda ()
+  (test-case
       ;; Goal: no matter the circumstances (e.g. exception in a
       ;; stop script), we will never retract an assertion more or
       ;; fewer than the correct number of times.
-
+      ;;
       ;; Test cleanup after exception in stop script
-          ;;
+      [(assertion-struct layer (name))
-          ;; Correct output:
+       (spawn #:name 'crasher
-          ;;
+              (define root-facet (current-facet))
-          ;; inner gone
-          ;; outer gone
-          ;; middle gone
-          ;;
-          ;; (or some permutation of these) plus an exception report for the division by zero.
-
-          (assertion-struct layer (name))
-
-          (spawn (define root-facet (current-facet))
               (assert (layer 'outer))
               (on-start (react (assert (layer 'middle))
                                (on-start (flush!) (flush!) (stop-facet root-facet))
                                (on-stop (/ 1 0))
                                (on-start (react (assert (layer 'inner)))))))
+       (spawn (on (retracted (layer $x)) (printf "~a gone\n" x)))]
+    (it "should crash with division by zero" (actor-died? 'crasher "division by zero"))
+    ;; a permutation of these lines is acceptable:
+    (expected-output "middle gone"
+                     "inner gone"
+                     "outer gone"))
 
-          (spawn (on (retracted (layer $x)) (printf "~a gone\n" x))))
+  (begin ;; Suite of four related tests.
-
-        #;(lambda ()
     ;; See .../syndicate/examples/actor/example-responsibility-transfer-2.rkt
 
-          (spawn #:name 'factory-1
+    (test-case
+        [(spawn #:name 'factory-1
                 (on (asserted (list 'X 1))
                     (spawn #:name 'service-1
                            #:assertions [(observe (list 'X 1))] ;; (A)
                            (stop-when (retracted (list 'X 1)))  ;; (B)
-                            (on (message 'dummy))) ;; exists just to keep the service alive if
+                           (on (message 'dummy)))
-                                                   ;; there are no other endpoints
-                     ;; spawn executes *before* teardown of this on-asserted endpoint, and thus
-                     ;; before the patch withdrawing (observe (list 'X 1)).
                     (stop-current-facet)))
-
          (spawn (on (asserted (observe (list 'X $supplier)))
                     (printf "Supply ~v asserted.\n" supplier)
                     (assert! (list 'X supplier)))
                 (on (retracted (observe (list 'X $supplier)))
-                     (printf "Supply ~v retracted.\n" supplier)))
+                    (printf "Supply ~v retracted.\n" supplier)))]
+      no-crashes
+      (expected-output "Supply 1 asserted."))
+
+    (test-case
+        [(spawn #:name 'factory-1
+                (on (asserted (list 'X 1))
+                    (spawn #:name 'service-1
+                           ;; #:assertions [(observe (list 'X 1))] ;; (A)
+                           (stop-when (retracted (list 'X 1)))  ;; (B)
+                           (on (message 'dummy)))
+                    (stop-current-facet)))
+         (spawn (on (asserted (observe (list 'X $supplier)))
+                    (printf "Supply ~v asserted.\n" supplier)
+                    (assert! (list 'X supplier)))
+                (on (retracted (observe (list 'X $supplier)))
+                    (printf "Supply ~v retracted.\n" supplier)))]
+      no-crashes
+      (expected-output "Supply 1 asserted."
+                       "Supply 1 retracted."
+                       "Supply 1 asserted."))
+
+    (test-case
+        [(spawn #:name 'factory-1
+                (on (asserted (list 'X 1))
+                    (spawn #:name 'service-1
+                           #:assertions [(observe (list 'X 1))] ;; (A)
+                           ;; (stop-when (retracted (list 'X 1)))  ;; (B)
+                           (on (message 'dummy)))
+                    (stop-current-facet)))
+         (spawn (on (asserted (observe (list 'X $supplier)))
+                    (printf "Supply ~v asserted.\n" supplier)
+                    (assert! (list 'X supplier)))
+                (on (retracted (observe (list 'X $supplier)))
+                    (printf "Supply ~v retracted.\n" supplier)))]
+      no-crashes
+      (expected-output "Supply 1 asserted."
+                       "Supply 1 retracted."))
+
+    (test-case
+        [(spawn #:name 'factory-1
+                (on (asserted (list 'X 1))
+                    (spawn #:name 'service-1
+                           ;; #:assertions [(observe (list 'X 1))] ;; (A)
+                           ;; (stop-when (retracted (list 'X 1)))  ;; (B)
+                           (on (message 'dummy)))
+                    (stop-current-facet)))
+         (spawn (on (asserted (observe (list 'X $supplier)))
+                    (printf "Supply ~v asserted.\n" supplier)
+                    (assert! (list 'X supplier)))
+                (on (retracted (observe (list 'X $supplier)))
+                    (printf "Supply ~v retracted.\n" supplier)))]
+      no-crashes
+      (expected-output "Supply 1 asserted."
+                       "Supply 1 retracted."))
+
     )
 
-        #;(lambda ()
+  (test-case
       ;; See .../syndicate/examples/actor/example-responsibility-transfer-1.rkt
-
+      [(spawn #:name 'demand-watcher
-          (spawn #:name 'demand-watcher
               (during/spawn 'demand
                 #:name (gensym 'intermediate-demand-asserter)
                 (assert 'intermediate-demand)))
@@ -706,60 +733,62 @@
                 (assert 'supply)))
 
        (spawn* #:name 'driver
-                  (react (on (asserted 'supply) (log-info "Supply asserted."))
+               (react (on (asserted 'supply) (displayln "Supply asserted."))
-                         (on (retracted 'supply) (log-info "Supply retracted.")))
+                      (on (retracted 'supply) (displayln "Supply retracted.")))
                (until (asserted (observe 'demand)))
-                  (log-info "Asserting demand.")
+               (displayln "Asserting demand.")
                (assert! 'demand)
                (until (asserted 'supply))
-                  (log-info "Glitching demand.")
+               (displayln "Glitching demand.")
                (retract! 'demand)
                (flush!)
                (assert! 'demand)
-                  (log-info "Demand now steady."))
+               (displayln "Demand now steady."))]
-          )
+    no-crashes
-
+    (expected-output "Asserting demand."
-        #;(lambda ()
+                     "Supply asserted."
-          ;; Trivial example program to demonstrate tracing
+                     "Glitching demand."
-
+                     "Demand now steady."
-          (assertion-struct one-plus (n m))
+                     "Supply retracted."
+                     "Supply asserted."))
 
+  (test-case
+      [(assertion-struct one-plus (n m))
        (spawn #:name 'add1-server
               (during/spawn (observe (one-plus $n _))
                 #:name (list 'solving 'one-plus n)
                 (assert (one-plus n (+ n 1)))))
-
        (spawn #:name 'client-process
               (stop-when (asserted (one-plus 3 $value))
-                   (printf "1 + 3 = ~a\n" value)))
+                (printf "1 + 3 = ~a\n" value)))]
-          )
+    no-crashes
+    (expected-output "1 + 3 = 4"))
 
-        #;(lambda ()
+  (test-case
       ;; .../racket/syndicate/examples/actor/example-partial-retraction.rkt
-          ;;
+      [(struct ready (what) #:prefab)
-          (struct ready (what) #:prefab)
        (struct entry (key val) #:prefab)
 
        (spawn (assert (ready 'listener))
               (on (asserted (entry $key _))
-                     (log-info "key ~v asserted" key)
+                  (printf "key ~v asserted\n" key)
                   (until (retracted (entry key _))
                     (on (asserted (entry key $value))
-                           (log-info "add binding: ~v -> ~v" key value))
+                        (printf "add binding: ~v -> ~v\n" key value))
                     (on (retracted (entry key $value))
-                           (log-info "del binding: ~v -> ~v" key value)))
+                        (printf "del binding: ~v -> ~v\n" key value)))
-                     (log-info "key ~v retracted" key)))
+                  (printf "key ~v retracted\n" key)))
 
        (spawn (assert (ready 'other-listener))
               (during (entry $key _)
-                   (log-info "(other-listener) key ~v asserted" key)
+                (printf "(other-listener) key ~v asserted\n" key)
-                   (on-stop (log-info "(other-listener) key ~v retracted" key))
+                (on-stop (printf "(other-listener) key ~v retracted\n" key))
                 (during (entry key $value)
-                     (log-info "(other-listener) ~v ---> ~v" key value)
+                  (printf "(other-listener) ~v ---> ~v\n" key value)
-                     (on-stop (log-info "(other-listener) ~v -/-> ~v" key value)))))
+                  (on-stop (printf "(other-listener) ~v -/-> ~v\n" key value)))))
 
        (define (pause)
-            (log-info "pause")
+         (displayln "pause")
          (define token (gensym 'pause)) ;; FIXME:: If we use the same token every time, need epochs!
          (until (asserted (ready token))
            (assert (ready token))))
@@ -784,20 +813,73 @@
                    [(entry 'a _) (retract! a)]
                    [_ (void)]))
                ;; ^ (retract! (entry 'a ?))
-                  (pause))
+               (pause))]
-          )
+    no-crashes
+    ;; Within the following, some permutations are acceptable:
+    #;(expected-output
+     "pause"
+     "pause"
+     "(other-listener) key 'a asserted"
+     "(other-listener) key 'c asserted"
+     "(other-listener) key 'b asserted"
+     "(other-listener) 'a ---> 4"
+     "(other-listener) 'a ---> 1"
+     "(other-listener) 'a ---> 2"
+     "(other-listener) 'a ---> 5"
+     "(other-listener) 'c ---> 33"
+     "(other-listener) 'b ---> 3"
+     "key 'a asserted"
+     "key 'c asserted"
+     "key 'b asserted"
+     "add binding: 'a -> 4"
+     "add binding: 'a -> 1"
+     "add binding: 'a -> 2"
+     "add binding: 'a -> 5"
+     "add binding: 'c -> 33"
+     "add binding: 'b -> 3"
+     "pause"
+     "del binding: 'a -> 2"
+     "del binding: 'c -> 33"
+     "add binding: 'a -> 9"
+     "key 'c retracted"
+     "(other-listener) 'a ---> 9"
+     "(other-listener) 'a -/-> 2"
+     "(other-listener) 'c -/-> 33"
+     "(other-listener) key 'c retracted"
+     "del binding: 'a -> 1"
+     "del binding: 'a -> 9"
+     "del binding: 'a -> 5"
+     "del binding: 'a -> 4"
+     "key 'a retracted"
+     "(other-listener) 'a -/-> 1"
+     "(other-listener) 'a -/-> 9"
+     "(other-listener) 'a -/-> 5"
+     "(other-listener) 'a -/-> 4"
+     "(other-listener) key 'a retracted"
+     "del binding: 'b -> 3"
+     "key 'b retracted"
+     "(other-listener) 'b -/-> 3"
+     "(other-listener) key 'b retracted"
+     ))
 
-        #;(lambda ()
+  (let ((N 100000))
-          (spawn (on (message $v)
+    (test-case
-                     (if (= v 10000000)
+        ;; Rough message send speed test
+        [(spawn (on (message $v)
+                    (if (= v N)
                         (stop-current-facet)
                         (send! (+ v 1))))
-                 (on-start (send! 0)))
+                (on-start (send! 0)))]
-          )
+      no-crashes
+      (it "should be fairly quick"
+          (log-info "Rough message send speed: ~a msgs in ~a ms = ~a Hz"
+                    N
+                    (test-run-time)
+                    (/ N (/ (test-run-time) 1000.0))))))
 
-        #;(lambda ()
+  (test-case
-
+      ;; Tests that pending actions are abandoned during a turn in which there is an exception
-          (message-struct stage (n))
+      [(message-struct stage (n))
 
        (spawn #:name 'actor0
               (on (message (stage 0))
@@ -815,33 +897,38 @@
                (until (asserted (observe (stage 0))))
                (send! (stage 0))
                (until (message (stage 1)))
-                  (send! (stage 2))))
+               (send! (stage 2))))]
-          )
+    (it "should involve one crash" (actor-died? 'actor0 "division by zero"))
+    (expected-output "Got message 0"
+                     "Got message 1"
+                     "Got message 2"))
+
+  (test-case
+      ;; Box-and-client
+      [(message-struct set-box (new-value))
+       (assertion-struct box-state (value))
 
-        (lambda ()
        (spawn (field [current-value 0])
               (assert (box-state (current-value)))
-                 (stop-when-true (= (current-value) 10)
+              (stop-when-true (= (current-value) 3)
-                                 (log-info "box: terminating"))
+                              (displayln "box: terminating"))
               (on (message (set-box $new-value))
-                     (log-info "box: taking on new-value ~v" new-value)
+                  (printf "box: taking on new-value ~v\n" new-value)
                   (current-value new-value)))
 
        (spawn (stop-when (retracted (observe (set-box _)))
-                   (log-info "client: box has gone"))
+                (displayln "client: box has gone"))
               (on (asserted (box-state $v))
-                     (log-info "client: learned that box's value is now ~v" v)
+                  (printf "client: learned that box's value is now ~v\n" v)
-                     (send! (set-box (+ v 1)))))
+                  (send! (set-box (+ v 1)))))]
-          )
+    no-crashes
-          ))))
+    (expected-output "client: learned that box's value is now 0"
+                     "box: taking on new-value 1"
+                     "client: learned that box's value is now 1"
+                     "box: taking on new-value 2"
+                     "client: learned that box's value is now 2"
+                     "box: taking on new-value 3"
+                     "box: terminating"
+                     "client: box has gone"))
 
-  (require racket/pretty)
-  ;; (pretty-print ds)
-  (#;time values
-   (let loop ((i 0))
-     ;; (printf "--- i = ~v\n" i)
-     (when (run-scripts! ds)
-       ;; (pretty-print ds)
-       (loop (+ i 1)))))
-  ;; (pretty-print ds)
   )

syndicate/test.rkt

@@ -0,0 +1,196 @@
+#lang racket/base
+;; Test drivers for Syndicate implementation.
+
+(provide collected-events
+         collected-output
+         collected-lines
+         final-dataspace
+         final-assertions
+         test-run-time
+         test-gc-time
+
+         asserted?
+         emitted?
+         actor-died?
+         emit!
+         test-case
+         it
+
+         no-crashes
+         expected-output
+
+         run-syndicate-test!
+         log-test-result!)
+
+(require racket/exn)
+(require racket/match)
+(require (only-in racket/string string-split string-join string-contains?))
+
+(require "bag.rkt")
+(require "dataspace.rkt")
+
+(require (for-syntax racket/base))
+(require (for-syntax syntax/srcloc))
+
+(define-logger syndicate/test)
+
+(define event-accumulator (make-parameter #f))
+(define exn-accumulator (make-parameter #f))
+(define failure-detected? (make-parameter #f))
+
+(define collected-events (make-parameter '()))
+(define collected-exns (make-parameter '()))
+(define collected-output (make-parameter ""))
+(define collected-lines (make-parameter '()))
+(define final-dataspace (make-parameter #f))
+(define test-run-time (make-parameter 0))
+(define test-gc-time (make-parameter 0))
+
+(define (asserted? v)
+  (bag-member? (dataspace-assertions (final-dataspace)) v))
+
+(define (final-assertions)
+  (bag->set (dataspace-assertions (final-dataspace))))
+
+(define (emitted? v)
+  (member v (collected-events)))
+
+(define (actor-died? name [substr-or-regex ""])
+  (define entry (findf (lambda (e) (equal? name (actor-name (car e)))) (collected-exns)))
+  (and entry
+       (let ((message (exn-message (cadr entry))))
+         (match substr-or-regex
+           [(? string? substr) (string-contains? message substr)]
+           [(? regexp? re) (regexp-match? re message)]))))
+
+(define (emit! event)
+  (define b (event-accumulator))
+  (set-box! b (cons event (unbox b))))
+
+(define-syntax (test-case stx)
+  (syntax-case stx ()
+    [(_ [body ...] checks ...)
+     (quasisyntax/loc stx
+       (run-syndicate-test!
+        #,(source-location->string stx)
+        (lambda () body ...)
+        (list checks ...)))]))
+
+(define (not-break? e)
+  (not (exn:break? e)))
+
+(struct check (location description thunk) #:prefab)
+
+(define (run-syndicate-test! location-str body-thunk list-of-checks)
+  (parameterize ((failure-detected? #f))
+    (define events-box (box '()))
+    (define exns-box (box '()))
+    (define (get-items b) (reverse (unbox b)))
+    (define op (open-output-string))
+    (with-handlers ([not-break? (lambda (e) (log-test-result! location-str #f e))])
+      (log-syndicate/test-info "~a--- Running test at ~a~a"
+                               (color YELLOW)
+                               location-str
+                               (color NORMAL))
+      (define ds (make-dataspace
+                  (lambda ()
+                    (schedule-script! (current-actor) body-thunk))))
+      (define-values (_results cpu-ms _wall-ms gc-ms)
+        (parameterize ((current-output-port op)
+                       (current-actor-crash-logger
+                        (lambda (a e)
+                          (set-box! exns-box (cons (list a e) (unbox exns-box)))))
+                       (event-accumulator events-box))
+          (time-apply (lambda () (let loop () (when (run-scripts! ds) (loop))))
+                      '())))
+      (define op-string (get-output-string op))
+      (parameterize ((collected-events (get-items events-box))
+                     (collected-exns (get-items exns-box))
+                     (collected-output op-string)
+                     (collected-lines (string-split op-string "\n"))
+                     (final-dataspace ds)
+                     (test-run-time cpu-ms)
+                     (test-gc-time gc-ms))
+        (for [(check (in-list list-of-checks))]
+          (with-handlers ([not-break? (lambda (e) (log-test-result! location-str check e))])
+            (match check
+              [(? procedure?)
+               (log-test-result! location-str check (check))]
+              [(? check?)
+               (log-test-result! location-str check ((check-thunk check)))])))))
+    (when (failure-detected?)
+      (log-syndicate/test-debug "Collected events:")
+      (for [(e (get-items events-box))]
+        (log-syndicate/test-debug "  ~v" e))
+      (log-syndicate/test-debug "Collected output:")
+      (for [(l (string-split (get-output-string op) "\n"))]
+        (log-syndicate/test-debug "  ~a" l))
+      (log-syndicate/test-debug "Crashed actors:")
+      (for [(entry (get-items exns-box))]
+        (match-define (list a e) entry)
+        (log-syndicate/test-debug "  ~a\n    ~a"
+                                  a
+                                  (string-join (string-split (exn->string e) "\n")
+                                               "    \n"))))))
+
+(define-syntax (it stx)
+  (syntax-case stx ()
+    [(_ description body ...)
+     (quasisyntax/loc stx
+       (check #,(source-location->string stx)
+              description
+              (lambda ()
+                (and body ...))))]))
+
+(define no-crashes (it "shouldn't involve any crashing actors"
+                       (null? (collected-exns))))
+
+(define-syntax (expected-output stx)
+  (syntax-case stx ()
+    [(_ line ...)
+     (quasisyntax/loc stx
+       (it "should produce correct output"
+           (equal? (collected-lines)
+                   (list line ...))))]))
+
+(define RED ";31")
+(define BRIGHT-RED ";1;31")
+(define GREEN ";32")
+(define BRIGHT-GREEN ";1;32")
+(define YELLOW ";33")
+(define NORMAL "")
+
+(define (color c) (format "\e[0~am" c))
+
+(define (log-test-result! test-loc maybe-check result)
+  (if (not maybe-check)
+      (begin
+        (failure-detected? #t)
+        (log-syndicate/test-error "~a  ✗ Exception running program under test:\n~a~a"
+                                  (color BRIGHT-RED)
+                                  (exn->string result)
+                                  (color NORMAL)))
+      (let ((description
+             (match maybe-check
+               [(? procedure?) (format "~a" check)]
+               [(check #f description _thunk) (format "~a" description)]
+               [(check check-loc description _thunk) (format "~a (~a)" description check-loc)])))
+        (match result
+          [(? exn?)
+           (failure-detected? #t)
+           (log-syndicate/test-error "~a  ✗ ... ~a:\n~a~a"
+                                     (color RED)
+                                     description
+                                     (exn->string result)
+                                     (color NORMAL))]
+          [#f
+           (failure-detected? #t)
+           (log-syndicate/test-error "~a  ✗ ... ~a~a"
+                                     (color RED)
+                                     description
+                                     (color NORMAL))]
+          [_
+           (log-syndicate/test-info "~a  ✓ ... ~a~a"
+                                    (color GREEN)
+                                    description
+                                    (color NORMAL))]))))