Added test suite tools

d-/test.scm

@@ -0,0 +1,37 @@
+(define-module (d- test)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 control)
+  #:export (define-test-suite assert))
+
+(define (assert expected actual eq? fail)
+  (when (not (eq? expected actual))
+    (format #t "fail - expected ~a but got ~a" expected actual)
+    (newline)
+    (fail)))
+
+(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-equal e a) #'(assert e a equal? fail)]
+	  [(assert-not-equal e a) #'(assert e a (compose not equal?) 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))]))))

test.scm

@@ -1,98 +1,64 @@
 (use-modules (d-)
-	     (rnrs base)
+	     (d- test)
 	     (srfi srfi-1))
 
-;; TODO eventually these will be cool prompt thingies
+(define-test-suite "~>"
+  (define-test "unwrapped"
+    (define value (~> 1 1+ 1+))
+    (assert-equal 3 value))
+  (define-test "wrapped"
+    (define value (~> 1 (/ 2) (/ 2)))
+    (assert-equal 1/4 value)))
 
-(define (assert-equal a b)
-  (display "... ")
-  (if (equal? a b)
-      (display "OK")
-      (begin
-	(display "expected ")
-	(display b)
-	(display " but instead got ")
-	(display a))))
+(define-test-suite "~>>"
+  (define-test "unwrapped"
+    (define value (~>> 1 1+ 1+))
+    (assert-equal 3 value))
+  (define-test "wrapped"
+    (define value (~>> 1 (/ 2) (/ 2)))
+    (assert-equal 1 value)))
 
-(define (assert-unspecified a)
-  (display "... ")
-  (if (unspecified? a)
-      (display "OK")
-      (begin
-	(display "expected unspecifed but instead got ")
-	(display a))))
+(define-test-suite "if-not"
+  (define-test "test"
+    (assert-equal 'a (if-not #f 'a 'b))))
 
-(define-syntax-rule (define-unit-test (test-name body ...))
-  (let ()
-    (display "<  ")
-    (display (symbol->string 'test-name))
-    body ...
-    (newline)))
+(define-test-suite "when-not"
+  (define-test "positive-case"
+    (assert-equal 'return (when-not #f 'do-some-stuff 'return)))
+  (define-test "negative-case"
+    (assert-unspecified (when-not #t 'do-some-stuff 'return))))
 
-(define-syntax-rule (define-test module-name tests ...)
-  (begin
-    (display "> ")
-    (display (symbol->string 'module-name))
-    (newline)
-    (define-unit-test tests) ...))
+(define-test-suite "for"
+  (define-test "permutation"
+    (define value (for ([i (iota 2)]
+			[j (iota 2)])
+		       (cons i j)))
+    (assert-equal '((0 . 0) (0 . 1) (1 . 0) (1 . 1)) value)))
 
-(define-test ~>
-  (unwrapped
-   (define value (~> 1 1+ 1+))
-   (assert-equal value 3))
-  (wrapped
-   (define value (~> 1 (/ 2) (/ 2)))
-   (assert-equal value 1/4)))
+(define-test-suite "if-let"
+  (define-test "positive-case"
+    (assert-equal 2 (if-let ([v (or #f 1)]) (+ v 1))))
+  (define-test "negative-case"
+    (assert-equal #f (if-let ([v (and #f 1)]) (+ v 1)))))
 
-(define-test ~>>
-  (unwrapped
-   (define value (~>> 1 1+ 1+))
-   (assert-equal value 3))
-  (wrapped
-   (define value (~>> 1 (/ 2) (/ 2)))
-   (assert-equal value 1)))
+(define-test-suite "partial"
+  (define-test "test"
+    (define value (partial / 2))
+    (assert-equal 1/2 (value 4))
+    (assert-equal 2 (value 1))))
 
-(define-test if-not
-  (test
-   (assert-equal (if-not #f 'a 'b) 'a)))
+(define-test-suite "argmin"
+  (define-test "test"
+    (assert-equal '(b . 2) (argmin cdr < '(a . 5) '(b . 2) '(c . 3)))))
 
-(define-test when-not
-  (positive-case
-   (assert-equal (when-not #f 'do-some-stuff 'return) 'return))
-  (negative-case
-   (assert-unspecified (when-not #t 'do-some-stuff 'return))))
-
-(define-test for
-  (permutation
-   (define value (for ([i (iota 2)]
-		       [j (iota 2)])
-		      (cons i j)))
-   (assert-equal value '((0 . 0) (0 . 1) (1 . 0) (1 . 1)))))
-
-(define-test if-let
-  (positive-case
-   (assert-equal (if-let ([v (or #f 1)]) (+ v 1)) 2))
-  (negative-case
-   (assert-equal (if-let ([v (and #f 1)]) (+ v 1)) #f)))
-
-(define-test partial
-  (test
-   (define value (partial / 2))
-   (assert-equal (value 4) 1/2)
-   (assert-equal (value 1) 2)))
-
-(define-test argmin
-  (test
-   (assert-equal (argmin cdr < '(a . 5) '(b . 2) '(c . 3)) '(b . 2))))
-
-(define-test generator
-  (test
-   (define number-generator
-     (generator
-      (let loop ([i 1])
-	(yield i)
-	(loop (1+ i)))))
-   (assert-equal (number-generator) 1)
-   (assert-equal (number-generator) 2)
-   (assert-equal (number-generator) 3)
-   (assert-equal (number-generator) 4)))
+(define-test-suite "generator"
+  (define-test "test"
+    (define number-generator
+      (generator
+       (let loop ([i 1])
+	 (yield i)
+	 (loop (1+ i)))))
+    (assert-equal 1 (number-generator))
+    (assert-equal 2 (number-generator))
+    (assert-equal 3 (number-generator))
+    (assert-equal 4 (number-generator))))