(module assert
mzscheme
(require (lib "etc.ss")
(lib "list.ss" "srfi" "1"))
(require "assert-base.ss"
"assert-util.ss")
(require-for-syntax "assert-util.ss")
(provide (struct exn:test:assertion (stack))
(struct assertion-info (name value))
with-assertion-info
with-assertion-info*
fail-assertion
define-assertion
define-simple-assertion
assert
assert*
assert-exn
assert-exn*
assert-not-exn
assert-not-exn*
assert-true
assert-true*
assert-false
assert-false*
assert-pred
assert-pred*
assert-eq?
assert-eq?*
assert-eqv?
assert-eqv?*
assert-equal?
assert-equal?*
assert-not-false
assert-not-false*
fail
fail*)
(define-syntax define-assertion
(lambda (stx)
(syntax-case stx ()
((define-assertion (name formal ...) expr ...)
(with-syntax (((reported-name function-name)
(let ((reported-name
(symbol->string
(syntax-object->datum (syntax name)))))
(list
reported-name
(datum->syntax-object
(syntax name)
(string->symbol
(string-append reported-name "*"))))))
((actual ...)
(datum->syntax-object
stx
(map gensym
(syntax-object->datum (syntax (formal ...)))))))
(syntax
(begin
(define function-name
(opt-lambda (formal ... [message ""])
(with-assertion-info*
(cons*
(make-assertion-name reported-name)
(make-assertion-params (list formal ...))
(if (> (string-length message) 0)
(list (make-assertion-message message))
(list)))
(lambda () expr ...))))
(define-syntax name
(lambda (stx)
(with-syntax
([location (syntax->location-values stx)])
(syntax-case stx ()
((name actual ...)
(syntax/loc
stx
(let ((args (list actual ...)))
(with-assertion-info*
(list (make-assertion-name reported-name)
(make-assertion-location 'location)
(make-assertion-expression
(quote (name actual ...)))
(make-assertion-params args))
(lambda ()
(apply (lambda (formal ...) expr ...) args))))))
((name actual ... message)
(syntax/loc
stx
(let ((args (list actual ...)))
(with-assertion-info*
(list (make-assertion-name reported-name)
(make-assertion-location 'location)
(make-assertion-expression
(quote (name actual ...)))
(make-assertion-params args)
(make-assertion-message message))
(lambda ()
(apply (lambda (formal ...) expr ...) args))))))
(name
(identifier? #'name)
(syntax/loc stx
(opt-lambda (formal ... [message ""])
(with-assertion-info*
(list
(make-assertion-location 'location))
(lambda ()
(function-name formal ... message))))))
))))
)))))))
(define-syntax define-simple-assertion
(syntax-rules ()
((_ (name param ...) expr ...)
(define-assertion (name param ...)
(let ((result (begin expr ...)))
(if result
result
(fail-assertion)))))))
(define-simple-assertion (assert operator expr1 expr2)
(operator expr1 expr2))
(define-simple-assertion (assert-pred predicate expr)
(predicate expr))
(define-simple-assertion (assert-eq? expr1 expr2)
(eq? expr1 expr2))
(define-simple-assertion (assert-eqv? expr1 expr2)
(eqv? expr1 expr2))
(define-simple-assertion (assert-equal? expr1 expr2)
(equal? expr1 expr2))
(define-simple-assertion (assert-true expr)
(eq? expr #t))
(define-simple-assertion (assert-false expr)
(eq? expr #f))
(define-simple-assertion (fail)
#f)
(define-assertion (assert-exn pred thunk)
(with-handlers
( [exn:test:assertion:internal?
(lambda (exn)
(refail-assertion exn))]
[pred
(lambda (exn) #t)]
[exn:test:assertion?
(lambda (exn)
(refail-assertion exn))]
[exn:fail?
(lambda (exn)
(with-assertion-info*
(list
(make-assertion-message "Wrong exception raised")
(make-assertion-info 'exception-message (exn-message exn))
(make-assertion-info 'exception exn))
(lambda () (fail-assertion))))])
(thunk)
(with-assertion-info*
(list (make-assertion-message "No exception raised"))
(lambda () (fail-internal)))))
(define-assertion (assert-not-exn thunk)
(with-handlers
([exn:test:assertion?
(lambda (exn) (refail-assertion exn))]
[exn?
(lambda (exn)
(with-assertion-info*
(list
(make-assertion-message "Exception raised")
(make-assertion-info 'exception-message (exn-message exn))
(make-assertion-info 'exception exn))
(fail-assertion)))])
(thunk)))
(define-simple-assertion (assert-not-false expr)
expr)
)