#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 ...)]))
(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 ...))]))
(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))]))