(module test mzscheme
(require (lib "include.ss")
(lib "kw.ss")
"keyword.ss"
"check.ss"
"check-info.ss"
"result.ss"
"base.ss")
(provide (struct exn:test:check (stack))
(struct check-info (name value))
(struct test-result (test-case-name))
(struct test-failure (result))
(struct test-error (result))
(struct test-success (result))
(struct schemeunit-test-case (name action))
(struct schemeunit-test-suite (name tests before after))
with-check-info
with-check-info*
make-check-name
make-check-params
make-check-location
make-check-expression
make-check-message
check-name?
check-params?
check-location?
check-expression?
check-message?
test-case
test-suite
before
after
around
define-shortcut
test-check
test-pred
test-equal?
test-eq?
test-eqv?
test-=
test-true
test-false
test-not-false
test-exn
test-not-exn
foldts
fold-test-results
run-test-case
run-test
fail-check
define-check
define-simple-check
define-binary-check
check
check*
check-exn
check-exn*
check-not-exn
check-not-exn*
check-true
check-true*
check-false
check-false*
check-pred
check-pred*
check-eq?
check-eq?*
check-eqv?
check-eqv?*
check-equal?
check-equal?*
check-=
check-=*
check-not-false
check-not-false*
fail
fail*)
(define (void-thunk) (void))
(define-syntax (test-case stx)
(syntax-case stx ()
[(_ name expr ...)
(syntax/loc stx
(make-schemeunit-test-case
name
(lambda () (begin (void) expr ...))))]
[_
(raise-syntax-error
#f
"Correct form is (test-case name expr ...)"
stx)]))
(define/kw (test-suite name
#:key [before void-thunk]
[after void-thunk]
#:body tests)
(make-schemeunit-test-suite name tests before after))
(define-syntax before
(syntax-rules ()
((_ before-e expr1 expr2 ...)
(dynamic-wind
(lambda ()
before-e)
(lambda ()
expr1 expr2 ...)
(lambda ()
(void))))
((before error ...)
(raise-syntax-error
'before
"Incorrect use of before macro. Correct format is (before before-expr expr1 expr2 ...)"
'before
'(error ...)))))
(define-syntax after
(syntax-rules ()
((_ expr1 expr2 ... after-e)
(dynamic-wind
(lambda ()
(void))
(lambda ()
expr1 expr2 ...)
(lambda ()
after-e)))
((after error ...)
(raise-syntax-error
'before
"Incorrect use of after macro. Correct format is (after expr1 expr2 ... after-expr)"
'after
'(error ...)))))
(define-syntax around
(syntax-rules ()
((_ before-e expr1 expr2 ... after-e)
(dynamic-wind
(lambda ()
before-e)
(lambda ()
expr1 expr2 ...)
(lambda ()
after-e)))
((around error ...)
(raise-syntax-error
'around
"Incorrect use of around macro. Correct format is (around before-expr expr1 expr2 ... after-expr)"
'around
'(error ...)))))
(define-syntax (define-shortcut stx)
(syntax-case stx ()
[(_ (name param ...) expr)
(with-syntax ([expected-form (syntax-object->datum
#`(#,(syntax name)
test-desc
#,@(syntax (param ...))))])
(syntax/loc stx
(define-syntax (name name-stx)
(syntax-case name-stx ()
[(name test-desc param ...)
(with-syntax ([name-expr (syntax/loc name-stx expr)])
(syntax/loc name-stx
(test-case test-desc name-expr)))]
[_
(raise-syntax-error
#f
(format "Correct form is ~a" (quote expected-form))
name-stx)]))))]
[_
(raise-syntax-error
#f
"Correct form is (define-shortcut (name param ...) expr)"
stx)]))
(define-shortcut (test-check operator expr1 expr2)
(check operator expr1 expr2))
(define-shortcut (test-pred pred expr)
(check-pred pred expr))
(define-shortcut (test-equal? expr1 expr2)
(check-equal? expr1 expr2))
(define-shortcut (test-eq? expr1 expr2)
(check-eq? expr1 expr2))
(define-shortcut (test-eqv? expr1 expr2)
(check-eqv? expr1 expr2))
(define-shortcut (test-= expr1 expr2 epsilon)
(check-= expr1 expr2 epsilon))
(define-shortcut (test-true expr)
(check-true expr))
(define-shortcut (test-false expr)
(check-false expr))
(define-shortcut (test-not-false expr)
(check-not-false expr))
(define-shortcut (test-exn pred thunk)
(check-exn pred thunk))
(define-shortcut (test-not-exn thunk)
(check-not-exn thunk))
)