(module check mzscheme
(require (lib "include.ss")
(lib "etc.ss")
(lib "list.ss" "srfi" "1")
"base.ss"
"check-info.ss"
"location.ss")
(require-for-syntax "location.ss")
(provide fail-check
define-check
define-binary-check
define-simple-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-syntax fail-check
(syntax-rules ()
((_)
(raise
(make-exn:test:check
"Check failure"
(current-continuation-marks)
(check-stack))))))
(define-syntax fail-internal
(syntax-rules ()
((_)
(raise
(make-exn:test:check:internal
"Internal failure"
(current-continuation-marks)
(check-stack))))))
(define (refail-check exn)
(raise
(make-exn:test:check "Check failure"
(exn-continuation-marks exn)
(exn:test:check-stack exn))))
(define-syntax (define-check stx)
(syntax-case stx ()
((define-check (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/loc stx
(begin
(define function-name
(opt-lambda (formal ... [message ""])
(with-check-info*
(cons*
(make-check-name reported-name)
(make-check-params (list formal ...))
(if (> (string-length message) 0)
(list (make-check-message message))
(list)))
(lambda () expr ...))))
(define-syntax (name stx)
(with-syntax
([location (syntax->location stx)])
(syntax-case stx ()
((name actual ...)
(syntax/loc stx
(let ((args (list actual ...)))
(with-check-info*
(list (make-check-name reported-name)
(make-check-location (quote location))
(make-check-expression
(quote (name actual ...)))
(make-check-params args))
(lambda ()
(apply (lambda (formal ...) expr ...) args))))))
((name actual ... message)
(syntax/loc stx
(let ((args (list actual ...)))
(with-check-info*
(list (make-check-name reported-name)
(make-check-location (quote location))
(make-check-expression
(quote (name actual ...)))
(make-check-params args)
(make-check-message message))
(lambda ()
(apply (lambda (formal ...) expr ...) args))))))
(name
(identifier? #'name)
(syntax/loc stx
(opt-lambda (formal ... [message ""])
(with-check-info*
(list
(make-check-location (quote location)))
(lambda ()
(function-name formal ... message))))))
)))
))))))
(define-syntax define-simple-check
(syntax-rules ()
((_ (name param ...) expr ...)
(define-check (name param ...)
(let ((result (begin expr ...)))
(if result
result
(fail-check)))))))
(define-syntax define-binary-check
(syntax-rules ()
((_ (name expr1 expr2) expr ...)
(define-check (name expr1 expr2)
(with-check-info
(('actual expr1)
('expected expr2))
(let ((result (begin expr ...)))
(if result
result
(fail-check))))))
((_ (name pred expr1 expr2))
(define-check (name expr1 expr2)
(with-check-info
(('actual expr1)
('expected expr2))
(if (pred expr1 expr2)
#t
(fail-check)))))))
(define-check (check-exn pred thunk)
(let/ec succeed
(with-handlers
( [pred
(lambda (exn) (succeed #t))]
[exn:test:check?
(lambda (exn)
(refail-check exn))]
[exn:fail?
(lambda (exn)
(with-check-info*
(list
(make-check-message "Wrong exception raised")
(make-check-info 'exception-message (exn-message exn))
(make-check-info 'exception exn))
(lambda () (fail-check))))])
(thunk))
(with-check-info*
(list (make-check-message "No exception raised"))
(lambda () (fail-check)))))
(define-check (check-not-exn thunk)
(with-handlers
([exn:test:check?
(lambda (exn) (refail-check exn))]
[exn?
(lambda (exn)
(with-check-info*
(list
(make-check-message "Exception raised")
(make-check-info 'exception-message (exn-message exn))
(make-check-info 'exception exn))
(lambda () (fail-check))))])
(thunk)))
(include "../generic/check.ss")
)