(module test mzscheme
(require "keyword.ss"
(all-except
"schemeunit.ss"
make-test-case
make-test-suite)
(rename
"schemeunit.ss"
raw:make-test-case make-test-case)
(rename
"schemeunit.ss"
raw:make-test-suite make-test-suite)
"assert.ss")
(provide (all-from "assert.ss")
make-test-case
make-test-suite
(all-from-except "schemeunit.ss" raw:make-test-case raw:make-test-suite))
(define void-thunk (lambda () (void)))
(define-syntax (make-test-case stx)
(syntax-case stx ()
[(_ name form ...)
(let loop ([forms (syntax->list #'(form ...))]
[setups null]
[teardowns null]
[exprs null])
(cond [(pair? forms)
(let ((form0 (car forms))
(forms (cdr forms)))
(syntax-case form0 (setup teardown)
[setup
(unless (pair? forms)
(raise-syntax-error
'make-test-case
"expected subsequent expression"
form0))
(loop (cdr forms) (cons (car forms) setups) teardowns exprs)]
[teardown
(unless (pair? forms)
(raise-syntax-error
'make-test-case
"expected subsequent expression"
form0))
(loop (cdr forms) setups (cons (car forms) teardowns) exprs)]
[else
(loop forms setups teardowns (cons form0 exprs))]))]
[else
(with-syntax ([(setup ...) (reverse setups)]
[(teardown ...) (reverse teardowns)]
[(expr ...) (reverse exprs)])
(syntax/loc stx
(raw:make-test-case
name
(lambda () (begin (void) expr ...))
(lambda () setup ... (void))
(lambda () teardown ... (void)))))]))]))
(define (make-test-suite name . tests)
(let ((setup (get-keyword-arg 'setup tests void-thunk))
(teardown (get-keyword-arg 'teardown tests void-thunk))
(rest (get-positional-args '(setup teardown) tests)))
(raw:make-test-suite name rest setup teardown)))
)