(module test-compat2 mzscheme (require "test.ss" "keyword.ss") (provide make-test-case make-test-suite (rename with-check-info with-assertion-info) (rename with-check-info* with-assertion-info*) (rename fail-check fail-assertion) (rename define-check define-assertion) (rename define-simple-check define-simple-assertion) (rename check assert) (rename check* assert*) (rename check-exn assert-exn) (rename check-exn* assert-exn*) (rename check-not-exn assert-not-exn) (rename check-not-exn* assert-not-exn*) (rename check-true assert-true) (rename check-true* assert-true*) (rename check-false assert-false) (rename check-false* assert-false*) (rename check-pred assert-pred) (rename check-pred* assert-pred*) (rename check-eq? assert-eq?) (rename check-eq?* assert-eq?*) (rename check-eqv? assert-eqv?) (rename check-eqv?* assert-eqv?*) (rename check-equal? assert-equal?) (rename check-equal?* assert-equal?*) (rename check-not-false assert-not-false) (rename check-not-false* assert-not-false*) fail fail*) (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)]) (if (or (pair? setups) (pair? teardowns)) (syntax/loc stx (test-case name (around (begin (void) setup ...) (begin (void) expr ...) (begin (void teardown ...))))) (syntax/loc stx (test-case name (begin expr ...)))))]))])) (define (make-test-suite name . tests) (let ((setup (get-keyword-arg 'setup tests void)) (teardown (get-keyword-arg 'teardown tests void)) (rest (get-positional-args '(setup teardown) tests))) (apply test-suite name #:before setup #:after teardown rest))) )