Commit programmatic API to construct test suites and test cases, in response to popular demand.

The API is make-test-case and make-test-suite. Use should be obvious.

TODO:
 - Document
 - Port to Schematics/Planet release

svn: r14731

collects/schemeunit/test-suite-test.ss

@@ -35,6 +35,35 @@
     (check-exn exn:fail:contract?
                (lambda ()
                  (test-suite (check = 1 1)))))
+
+   (test-case
+    "make-test-suite"
+    (let* ([before? #f]
+           [after? #f]
+           [ran? #f]
+           [results
+            (run-test
+             (make-test-suite
+              "dummy1"
+              (list
+               (make-test-case
+                "dummy-test-1"
+                (lambda () (check-true #t)))
+               (make-test-suite
+                "dummy2"
+                #:before (lambda () (set! before? #t))
+                #:after  (lambda () (set! after? #t))
+                (list
+                 (make-test-case
+                  "dummy-test-2"
+                  (lambda ()
+                    (set! ran? #t)
+                    (check-true #t))))))))])
+      (check-equal? (length results) 2)
+      (map (lambda (r) (check-pred test-success? r)) results)
+      (check-true before?)
+      (check-true after?)
+      (check-true ran?)))
    ))
 
 

collects/schemeunit/test-suite.ss

@@ -10,6 +10,7 @@
          test-suite-test-case-around
          test-suite-check-around
          delay-test
+         make-test-suite
          
          apply-test-suite
          
@@ -124,6 +125,38 @@
                   #:after  void-thunk
                   test ...))]))
 
+(define (tests->test-suite-action tests)
+  (lambda (fdown fup fhere seed)
+    (parameterize
+        ([current-seed seed])
+      (for-each
+       (lambda (t)
+         (cond
+          [(schemeunit-test-suite? t)
+           (current-seed (apply-test-suite t fdown fup fhere (current-seed)))]
+          [(schemeunit-test-case? t)
+           (current-seed
+            (fhere t
+                   (schemeunit-test-case-name t)
+                   (schemeunit-test-case-action t)
+                   (current-seed)))]
+          [else
+           (raise
+            (make-exn:test
+             (format "tests->test-suite-action received ~a in list of tests ~a, which is not a test." t tests)
+             (current-continuation-marks)))]))
+       tests)
+    (current-seed))))
+
+;; make-test-suite : string [#:before thunk] [#:after thunk] (listof test?) -> test-suite?
+;;
+;; Construct a test suite from a list of tests
+(define (make-test-suite name #:before [before void-thunk] #:after [after void-thunk] tests)
+  (make-schemeunit-test-suite name
+                              (tests->test-suite-action tests)
+                              before
+                              after))
+
 ;;
 ;; Shortcut helpers
 ;;

collects/schemeunit/test-test.ss

@@ -281,5 +281,13 @@
     check-info?
     check-info-name
     check-info-value)
+
+   (test-case
+    "make-test-case constructs a test case"
+    (check-pred
+     test-success?
+     (car
+      (run-test
+       (make-test-case "dummy" (lambda () (check-true #t)))))))
    ))
   

collects/schemeunit/test.ss

@@ -41,8 +41,10 @@
          test-begin
          test-case
          test-suite
+         make-test-suite
          delay-test
-         (rename-out [schemeunit-test-case? test-case?]
+         (rename-out [make-schemeunit-test-case make-test-case]
+                     [schemeunit-test-case? test-case?]
                      [schemeunit-test-suite? test-suite?])
          
          define-test-suite