Use parameterized context instead of macro weirdness for tests

d-/test.scm

@@ -2,15 +2,31 @@
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 format)
   #:use-module (ice-9 control)
-  #:export (define-test-suite anything))
+  #:export (define-test-suite
+            assert-equal assert-not-equal assert-unspecified
+            anything))
 
 (define *anysym* (gensym))
 (define (anything) *anysym*)
 
-(define (assert expected actual eq? fail)
-  (when (and (not (eq? expected actual)))
+(define *fail* (make-parameter #f))
+
+(define (assert expected actual eq?)
+  (cond
+   [(not (*fail*)) (error "assertion outside test context")]
+   [(not (eq? expected actual))
     (format #t "fail - expected ~a but got ~a~%" expected actual)
-    (fail)))
+    ((*fail*))]
+   [else #t]))
+
+(define (assert-equal e a)
+  (assert e a equal-or-any?))
+
+(define (assert-not-equal e a)
+  (assert e a (compose not equal-or-any?)))
+
+(define (assert-unspecified v)
+  (assert (when #f '_) v eq?))
 
 (define (equal-or-any? expected actual)
   (cond
@@ -22,27 +38,21 @@
 
 (define-syntax define-test-suite
   (lambda (stx)
-    (with-syntax ([fail (datum->syntax stx 'fail)])
-      (define (assert-stx expr)
-        (syntax-case expr (assert-equal assert-not-equal assert-unspecified)
-          [(assert-equal e a) #'(assert e a equal-or-any? fail)]
-          [(assert-not-equal e a) #'(assert e a (compose not equal-or-any?) fail)]
-          [(assert-unspecified v) #'(assert (when #f 'a) v eq? fail)]
-          [else #'else]))
-      (define (define-test-stx test)
-        (syntax-case test (define-test)
-          [(define-test test-name e ...)
-           #`(call/ec (lambda (fail)
-                        (format #t "~a: " test-name)
-                        (begin
-                          #,@(map assert-stx #'(e ...)))
-                        (display "ok")
-                        (newline)))]))
-      (syntax-case stx ()
-        [(define-test-suite name test ...)
-         #`(begin
-             (format #t "Suite ~a:" name)
-             (newline)
-             #,@(map define-test-stx
-                     #'(test ...))
-             (newline))]))))
+    (define (define-test-stx test)
+      (syntax-case test (define-test)
+        [(define-test test-name e ...)
+         #`(call/ec
+            (lambda (fail)
+              (parameterize ([*fail* fail])
+                (format #t "~a: " test-name)
+                e ...
+                (display "ok")
+                (newline))))]))
+    (syntax-case stx ()
+      [(define-test-suite name test ...)
+       #`(begin
+           (format #t "Suite ~a:" name)
+           (newline)
+           #,@(map define-test-stx
+                   #'(test ...))
+           (newline))])))

test.scm

@@ -200,16 +200,19 @@
     (define solution (get-solution))
     (assert-equal 'norwegian (assq-ref solution '?water-drinker))
     (assert-equal 'japanese (assq-ref solution '?zebra-owner)))
+
   (define-test "with-db"
     (define my-db '())
     (define get-solution #f)
     (define solution #f)
     (with-db my-db
              (<- (foo bar)))
+    ;; Outside context
     (set! get-solution (?- (foo ?x)))
     (set! solution (get-solution))
     (assert-equal #f (assq-ref solution '?x))
+    ;; Inside context
     (with-db my-db
       (set! get-solution (?- (foo ?x)))
-      (set! solution (get-solution)))
-    (assert-equal 'bar (assq-ref solution '?x))))
+      (set! solution (get-solution))
+      (assert-equal 'bar (assq-ref solution '?x)))))