diff --git a/rackunit-doc/rackunit/scribblings/check.scrbl b/rackunit-doc/rackunit/scribblings/check.scrbl index 7ed00975..7f4b1ee5 100644 --- a/rackunit-doc/rackunit/scribblings/check.scrbl +++ b/rackunit-doc/rackunit/scribblings/check.scrbl @@ -189,6 +189,24 @@ the check fails. } +@defform[(check-compile-time-exn (exn-predicate (or/c (-> any/c any/c) regexp?)) + (expr (-> any))) + void?]{ + +Similar to @racket[check-exn], but checks that an expression, @racket[expr], +raises a runtime or compile time exception and that either @racket[exn-predicate] +returns a true value if it is a function, or that it matches the +message in the exception if @racket[exn-predicate] is a regexp. +In the latter case, the exception raised must be an @racket[exn:fail?]. +} + +@defform[(check-not-compile-time-exn (expr (-> any))) + void?]{ + +Similar to @racket[check-not-exn], but checks that an expression, @racket[expr], +does not raise a runtime or compile time exception. +} + @defproc[(check-regexp-match (regexp regexp?) (string string?)) void?]{ diff --git a/rackunit-lib/rackunit/private/check.rkt b/rackunit-lib/rackunit/private/check.rkt index 588670f2..5d6035fb 100644 --- a/rackunit-lib/rackunit/private/check.rkt +++ b/rackunit-lib/rackunit/private/check.rkt @@ -7,6 +7,7 @@ racket/match rackunit/log syntax/parse/define + syntax/macro-testing "base.rkt" "equal-within.rkt" "check-info.rkt" @@ -29,6 +30,8 @@ check check-exn check-not-exn + check-compile-time-exn + check-not-compile-time-exn check-true check-false check-pred @@ -147,14 +150,16 @@ (procedure-arity-includes? thunk 0)) (raise-arguments-error name "thunk must be a procedure that accepts 0 arguments" "thunk" thunk))) +(define (get-pred raw-pred) + (cond [(regexp? raw-pred) + (λ (x) (and (exn:fail? x) (regexp-match raw-pred (exn-message x))))] + [(and (procedure? raw-pred) (procedure-arity-includes? raw-pred 1)) + raw-pred] + [else + (raise-argument-error 'check-exn "(or/c (-> any/c any/c) regexp?)" raw-pred)])) + (define-check (check-exn raw-pred thunk) - (let ([pred - (cond [(regexp? raw-pred) - (λ (x) (and (exn:fail? x) (regexp-match raw-pred (exn-message x))))] - [(and (procedure? raw-pred) (procedure-arity-includes? raw-pred 1)) - raw-pred] - [else - (raise-argument-error 'check-exn "(or/c (-> any/c any/c) regexp?)" raw-pred)])]) + (let ([pred (get-pred raw-pred)]) (raise-error-if-not-thunk 'check-exn thunk) (let/ec succeed (with-handlers @@ -196,6 +201,48 @@ (lambda () (fail-check))))]) (thunk))) +(define-syntax (check-compile-time-exn stx) + (syntax-parse stx + [(_ raw-pred expr:expr) + #:with loc (datum->syntax #f 'loc stx) + #'(let ([pred (get-pred raw-pred)] + [location (syntax->location #'loc)]) + (with-check-info (['name 'check-compile-time-exn] + ['location location] + ['params (list raw-pred (syntax->datum #'expr))]) + (let/ec finish + (with-check-info (['message "Wrong exception raised"]) + (with-handlers + ([pred + (lambda (exn) (finish))] + [exn:fail? + (lambda (exn) + (with-check-info (['exn exn]) + (fail) + (finish)))]) + (convert-compile-time-error expr))) + (with-check-info (['message "No exception raised"]) + (fail)))))])) + +(define-syntax (check-not-compile-time-exn stx) + (syntax-parse stx + [(_ expr:expr) + #:with loc (datum->syntax #f 'loc stx) + #'(let ([location (syntax->location #'loc)]) + (with-check-info (['name 'check-not-compile-time-exn] + ['location location] + ['params (list (syntax->datum #'expr))]) + (let/ec finish + (with-check-info (['message "Exception raised"]) + (with-handlers + ([exn:fail? + (lambda (exn) + (with-check-info (['exn exn]) + (fail) + (finish)))]) + (convert-compile-time-error expr))) + (finish))))])) + (define-syntax-rule (define-simple-check-values [header body ...] ...) (begin (define-simple-check header body ...) ...)) diff --git a/rackunit-test/tests/rackunit/check-test.rkt b/rackunit-test/tests/rackunit/check-test.rkt index 6e8126eb..16020734 100644 --- a/rackunit-test/tests/rackunit/check-test.rkt +++ b/rackunit-test/tests/rackunit/check-test.rkt @@ -34,7 +34,8 @@ rackunit rackunit/private/check rackunit/private/result - rackunit/private/test-suite) + rackunit/private/test-suite + syntax/macro-testing) (define (make-failure-test name pred . args) (test-case @@ -434,6 +435,45 @@ (lambda () (check-not-exn (lambda (x) x))))) + ;; Verify compile time exceptions are now + ;; supported by check-compile-time-exn and + ;; check-not-compile-time-exn + (test-case + "check-compile-time-exn converts compile time exceptions to runtime phase" + (check-compile-time-exn exn:fail:syntax? + (lambda () + (if 1 2)))) + + (test-case "check-compile-time-exn should not evaluate its body" + (define evaluated? (box #f)) + (check-compile-time-exn exn:fail? + (lambda () + (set-box! evaluated? #t) + (define kaboom))) + (check-false (unbox evaluated?))) + + (test-case "check-compile-time-exn expression do not need to be thunks" + (check-compile-time-exn exn:fail? (define))) + + (test-case "check-compile-time-exn accepts regular expression" + (check-compile-time-exn #rx"missing an \"else\" expression" (if 1 2))) + + (test-case + "check-not-compile-time-exn does not call any compile time exceptions when none are provided" + (check-not-compile-time-exn (lambda () + (if 1 2 3)))) + + (test-case "check-not-compile-time-exn should not evaluate its body" + (define evaluated? (box #f)) + (check-not-compile-time-exn + (lambda () + (set-box! evaluated? #t) + (define kaboom 7))) + (check-false (unbox evaluated?))) + + (test-case "check-not-compile-time-exn expression do not need to be thunks" + (check-compile-time-exn exn:fail? (define 7))) + ;; Regression test ;; Uses of check (and derived forms) used to be un-compilable! ;; We check that (write (compile --code-using-check--)) works.