test-suite.ss
#lang scheme/base

(require (for-syntax scheme/base))

(require "base.ss"
         "test-case.ss"
         "check.ss")

(provide test-suite
         test-suite-test-case-around
         test-suite-check-around
         delay-test

         define-test-suite
         define/provide-test-suite)

(define (void-thunk) (void))

(define test-suite-test-case-around
  (lambda (thunk)
    (make-schemeunit-test-case
     (current-test-name)
     thunk)))

(define test-suite-check-around
  (lambda (thunk)
    (make-schemeunit-test-case
     #f
     thunk)))

(define-syntax delay-test
  (syntax-rules ()
    [(delay-test test test1 ...)
     (parameterize
         ([current-test-case-around test-suite-test-case-around]
          [current-check-around test-suite-check-around])
       test test1 ...)]))
  
;; test-suite : name [#:before thunk] [#:after thunk] test ...
;;                     -> test-suite
;;
;; Creates a test-suite with the given name and tests.
;; Setup and teardown actions (thunks) may be specified by
;; preceding the actions with the keyword #:before or
;; #:after.
(define-syntax (test-suite stx)
  (syntax-case stx ()
    [(test-suite name
                 #:before before-thunk
                 #:after  after-thunk
                 test ...)
     (syntax
      (let ([the-name name]
            [the-tests
             (parameterize
               ([current-test-case-around test-suite-test-case-around]
                [current-check-around test-suite-check-around])
               (list test ...))])
        (cond
         [(not (string? the-name))
          (raise-type-error 'test-suite "test-suite name as string" the-name)]
         [(not (andmap test? the-tests))
          (raise-type-error 'test-suite "test-suites tests" the-tests)]
         [else
          (make-schemeunit-test-suite
           the-name
           the-tests
           before-thunk
           after-thunk)])))]
    [(test-suite name
                 #:before before-thunk
                 test ...)
     (syntax
      (test-suite name
                  #:before before-thunk
                  #:after  void-thunk
                  test ...))]
    [(test-suite name
                 #:after after-thunk
                 test ...)
     (syntax
      (test-suite name
                  #:before void-thunk
                  #:after  after-thunk
                  test ...))]
    [(test-suite name test ...)
     (syntax
      (test-suite name
                  #:before void-thunk
                  #:after  void-thunk
                  test ...))]))

;;
;; Shortcut helpers
;;

(define-syntax define-test-suite
  (syntax-rules ()
    [(define-test-suite name test ...)
     (define name
       (test-suite (symbol->string (quote name))
                   test ...))]))
  
(define-syntax define/provide-test-suite
  (syntax-rules ()
    [(define/provide-test-suite name test ...)
     (begin
       (define-test-suite name test ...)
       (provide name))]))