(module check-test mzscheme
(require (lib "list.ss" "srfi" "1")
"test.ss")
(require "info.ss")
(provide check-tests)
(define (make-failure-test name pred . args)
(test-case
name
(check-exn exn:test:check?
(lambda ()
(apply pred args)))))
(define-check (good)
#t)
(define-check (bad)
(fail-check))
(define check-tests
(test-suite
"Check tests"
(test-case "Simple check-equal? test"
(check-equal? 1 1))
(test-case "Simple check-eq? test"
(check-eq? 'a 'a))
(test-case "Simple check-eqv? test"
(check-eqv? 'a 'a))
(test-case "Simple check test"
(check string=? "hello" "hello"))
(test-case "Simple check-true test"
(check-true (eq? 'a 'a)))
(test-case "Simple check-pred test"
(check-pred null? (list)))
(test-case "Simple check-exn test"
(check-exn exn:test:check?
(lambda ()
(check = 1 2))))
(test-case "Simple check-not-exn test"
(check-not-exn
(lambda ()
(check = 1 1))))
(test-case "Defined check succeeds"
(good))
(test-case "Simple check-not-false test"
(check-not-false 3))
(test-case "Use of check as expression"
(for-each check-false '(#f #f #f)))
(test-case "Use of local check as expression"
(let ()
(define-simple-check (check-symbol? x)
(symbol? x))
(for-each check-symbol? '(a b c))))
(make-failure-test "check-equal? failure"
check-equal?* 1 2)
(make-failure-test "check-eq? failure"
check-eq?* 'a 'b)
(make-failure-test "check-eqv? failure"
check-eqv?* 'a 'b)
(make-failure-test "check failure"
check* string=? "hello" "bye")
(make-failure-test "check-true failure"
check-true* (eq? 'a 'b))
(make-failure-test "check-pred failure"
check-pred* null? (list 1 2 3))
(make-failure-test "check-exn failure"
check-exn* exn:test:check? (lambda () (check = 1 1)))
(make-failure-test "check-exn wrong exception"
check-exn* exn:fail:contract:arity? (lambda () (+ 1 2)))
(make-failure-test "check-not-exn"
check-not-exn* (lambda () (/ 1 0)))
(make-failure-test "fail with message failure"
fail* "With message")
(make-failure-test "fail without message failure"
fail*)
(make-failure-test "Defined check fails"
bad*)
(make-failure-test "check-not-false failure"
check-not-false* #f)
(test-case "check-as-expression failure"
(check-exn exn:test:check?
(lambda ()
(for-each check-false '(#f not-false)))))
(test-case
"Check allows optional message"
(begin
(check* = 1 1 "message")
(check = 1 1 "message")))
(test-case
"Check macro parameters evaluated once (simple-check)"
(let ((counter 0))
(check-true (begin (set! counter (add1 counter))
#t))
(check = counter 1)))
(test-case
"Check macro parameters evaluated once (binary-check)"
(let ((counter 0))
(check-equal? (begin (set! counter (add1 counter))
1)
(begin (set! counter (add1 counter))
1))
(check = counter 2)))
(test-case
"Check function parameters evaluated once (simple-check)"
(let ((counter 0))
(check-true* (begin (set! counter (add1 counter))
#t))
(check = counter 1)))
(test-case
"Check function parameters evaluated once (binary-check)"
(let ((counter 0))
(check-equal?* (begin (set! counter (add1 counter))
1)
(begin (set! counter (add1 counter))
1))
(check = counter 2)))
(test-case
"Macro w/ no message, message is a string"
(let ((exn (with-handlers ([exn? (lambda (exn)
exn)])
(check-true #f))))
(check-pred string? (exn-message exn))))
(test-case
"Function w/ no message, message is a string"
(let ((exn (with-handlers ([exn? (lambda (exn)
exn)])
(check-true* #f))))
(check-pred string? (exn-message exn))))
(test-case
"with-check-info* captures information"
(let ((name (make-check-info 'name "name"))
(info (make-check-info 'info "info")))
(with-handlers
[(exn:test:check?
(lambda (exn)
(let ((stack (exn:test:check-stack exn)))
(check = (length stack) 2)
(let ((actual-name (first stack))
(actual-info (second stack)))
(check-equal? name actual-name)
(check-equal? info actual-info)))))]
(with-check-info*
(list name info)
(lambda ()
(fail-check))))))
(test-case
"with-check-info captures information"
(with-handlers
[(exn:test:check?
(lambda (exn)
(let ((stack (exn:test:check-stack exn)))
(check = (length stack) 2)
(let ((name (first stack))
(info (second stack)))
(check-eq? (check-info-name name) 'name)
(check string=? (check-info-value name) "name")
(check-eq? (check-info-name info) 'info)
(check string=? (check-info-value info) "info")))))]
(with-check-info
(('name "name") ('info "info"))
(fail-check))))
(test-case
"check information stack unwinds"
(with-handlers
[(exn:test:check?
(lambda (exn)
(let ((stack (exn:test:check-stack exn)))
(check = (length stack) 2)
(let ((name (first stack))
(info (second stack)))
(check-eq? (check-info-name name) 'name)
(check string=? (check-info-value name) "name")
(check-eq? (check-info-name info) 'info)
(check string=? (check-info-value info) "info")))))]
(with-check-info
(('name "name") ('info "info"))
(with-check-info
(('name "name") ('info "info"))
#t)
(fail-check))))
(test-case
"check-exn traps exception"
(with-handlers
((exn?
(lambda (exn) (fail "Received exception"))))
(check-exn exn:fail:contract:arity?
(lambda () (= 1)))))
(test-case
"check-exn fails if no exception raised"
(with-handlers
((exn:test:check?
(lambda (exn) #t))
(exn:fail:contract:arity?
(lambda (exn) (fail "check-exn didn't fail"))))
(check-exn exn? (lambda () (= 1 1)))
(= 1)))
(test-case
"Checks are compilable"
(let ((destns (make-namespace))
(cns (current-namespace)))
(parameterize ((current-namespace destns))
(namespace-require '(file "check.ss"))
(let ((ecode
(syntax-object->datum (expand '(check = 1 2)))))
(check-false (and (pair? ecode)
(eq? (car ecode) '#%app)
(pair? (cdr ecode))
(equal? (cadr ecode)
'(#%top . check)))))
(let ((stx-string "(check = 1 2)"))
(write (compile (read-syntax
(string->path "file")
(open-input-string stx-string)))
(open-output-string))))))
))
)