diff --git a/rackunit-doc/rackunit/scribblings/check.scrbl b/rackunit-doc/rackunit/scribblings/check.scrbl index 5add46d..229aaf9 100644 --- a/rackunit-doc/rackunit/scribblings/check.scrbl +++ b/rackunit-doc/rackunit/scribblings/check.scrbl @@ -462,84 +462,45 @@ message.} Custom checks such as those created by @racket[define-check] can contain a fair amount of logic. Consequently, custom checks can be buggy and should be tested. -RackUnit provides a handful of checks explicitly designed for testing the -behavior of other checks; they allow verifying checks pass and fail when -expected or that checks add certain information to the check information stack. -These bindings are provided by @racketmodname[rackunit/meta], not -@racketmodname[rackunit]. - -@defproc[(check-fail [fail-exn-predicate - (or/c (-> exn:test:check? any/c) regexp?)] +RackUnit provides a few checks explicitly designed for testing the behavior of +other checks; they allow verifying checks pass and fail when expected or that +checks add certain information to the check information stack. These bindings +are provided by @racketmodname[rackunit/meta], not @racketmodname[rackunit]. + +@defproc[(check-fail [assertion-tree + (treeof (or/c (-> exn:test:check? any/c) + regexp? + check-info?))] [thunk (-> any)] [message string? ""]) void?]{ - Checks that @racket[thunk] evaluates a failing check and that - @racket[fail-exn-predicate], if it's a function, returns a true value when - given the check failure exception. If @racket[fail-exn-predicate] is a regexp, - instead checks that the regexp matches the check failure exception's message. - Note that a check failure exception's message is the message given to - @racket[fail-check], not the optional @racket[message] argument that all checks - accept. See also @racket[check-exn] and @racket[check-fail/error]. + Checks that @racket[thunk] raises a check failure and that the failure + satisfies @racket[assertion-tree]. The tree is checked in the following manner: + + @(itemlist + @item{If the tree is a predicate, it must return a true value when applied to + the raised check failure.} + @item{If the tree is a regexp, it must match the check failure's message (as + provided by @racket[fail-check]).} + @item{If the tree is a @racket[check-info] value, the check failure's + @racket[exn:test:check-stack] value must contain the expected info value.} + @item{If the tree is a list, every assertion in the list is checked.}) @(examples #:eval rackunit-eval - (check-fail values (λ () (check-equal? 'foo 'bar))) + (check-fail '() (λ () (check-equal? 'foo 'bar))) (check-fail number? (λ () (check-equal? 'foo 'bar))) - (check-fail values (λ () (check-equal? 'foo 'foo)))) + (check-fail (list string? (check-info 'info 10)) + (λ () (check-equal? 'foo 'foo)))) - @history[#:added "1.8"]} - -@defproc[(check-fail* [thunk (-> any)] [message string? ""]) void?]{ - Like @racket[check-fail], but only checks that @racket[thunk] evaluates a - failing check without testing the failure against a predicate or regexp. - - @(examples - #:eval rackunit-eval - (check-fail* (λ () (check-equal? 'foo 'bar))) - (check-fail* (λ () (check-equal? 'foo 'foo)))) - - @history[#:added "1.8"]} - -@defproc[(check-fail/info [info check-info?] - [thunk (-> any)] - [message string? ""]) - void?]{ - Like @racket[check-fail], but instead of checking that the failure matches a - predicate or regexp checks that the failure contains a check info value equal - to @racket[info]. Note that the check info stack of the failure may contain - multiple infos with the same name as @racket[info] but different values; in - that case the check passes as long as at least one info is equal to the - expected info. - - @(examples - #:eval rackunit-eval - (define foo-info (make-check-info 'foo 'foo)) - (define-check (fail-foo) (with-heck-info* (list foo-info) fail-check)) - (check-fail/info foo-info fail-foo) - (check-fail/info foo-info void) - (check-fail/info foo-info fail)) - - @history[#:added "1.8"]} - -@defproc[(check-fail/error [fail-exn-predicate - (or/c (-> exn:test:check? any/c) regexp?)] - [thunk (-> any)] - [message string? ""]) - void?]{ - Checks that @racket[thunk] evaluates a check that raises an error value instead - of passing or failing, and checks that the raised value satisfies - @racket[fail-exn-predicate]. Satisfies means that @racket[fail-exn-predicate] - return true when given the raised value if @racket[fail-exn-predicate] is a - function. If it's a predicate, satisfies means that the raised value is an - exception whose message matches the regexp. See also @racket[check-fail] and - @racket[check-exn]. + Additionally, a failure is reported if @racket[thunk] raises something other + than an @racket[exn:test:check] value. The optional @racket[message] argument + is included in the output if the check fails. @(examples #:eval rackunit-eval - (define-check (error-check) - (raise (make-exn:fail "Kaboom!!!" (current-continuation-marks))) - (fail-check "Doesn't get here")) - (check-fail/error #rx"boom" error-check)) + (check-fail '() (λ () (raise 'foo))) + (check-fail number? (λ () (check-equal? 'foo 'bar)) "my message")) @history[#:added "1.8"]} diff --git a/rackunit-lib/rackunit/meta.rkt b/rackunit-lib/rackunit/meta.rkt index b4cea14..7c0e8d6 100644 --- a/rackunit-lib/rackunit/meta.rkt +++ b/rackunit-lib/rackunit/meta.rkt @@ -1,9 +1,6 @@ #lang racket/base -(provide check-fail/error - check-fail - check-fail* - check-fail/info) +(provide check-fail) (require (for-syntax racket/base) racket/function @@ -11,95 +8,51 @@ rackunit/log syntax/parse/define rackunit - rackunit/private/check-info) + (only-in rackunit/private/check-info + current-check-info + pretty-info)) -(define-check (check-fail pred-or-msg chk-thnk) - (contract-pred-or-msg! 'check-fail pred-or-msg) +(define-check (check-fail tree chk-thnk) + (contract-tree! 'check-fail tree) (contract-thunk! 'check-fail chk-thnk) (define failure (check-raise-value chk-thnk)) - (with-expected pred-or-msg - (assert-failure failure) - (assert-check-failure failure) - (if (procedure? pred-or-msg) - (unless (pred-or-msg failure) - (with-actual failure - (fail-check "Wrong exception raised"))) - (let ([msg (exn-message failure)]) - (unless (regexp-match? pred-or-msg msg) - (with-actual failure - (with-check-info (['actual-msg msg]) - (fail-check "Wrong exception raised")))))))) - -(define-check (check-fail/info expected-info chk-thnk) - (contract-info! 'check-fail/info expected-info) - (contract-thunk! 'check-fail/info chk-thnk) - (define failure (check-raise-value chk-thnk)) - (with-expected expected-info - (assert-failure failure) - (assert-check-failure failure) - (define (has-expected-name? info) - (equal? (check-info-name info) (check-info-name expected-info))) - (define infos (exn:test:check-stack failure)) - (define info-names (map check-info-name infos)) - (define matching-infos (filter has-expected-name? infos)) - (when (empty? matching-infos) - (with-check-info (['actual-info-names info-names]) - (fail-check "Check failure did not contain the expected info"))) - (unless (member expected-info matching-infos) - (with-check-info* (map make-check-actual matching-infos) - (λ () (fail-check "Check failure contained info(s) with matching name but unexpected value")))))) - -(define-check (check-fail* chk-thnk) - (contract-thunk! 'check-fail* chk-thnk) - (define failure (check-raise-value chk-thnk)) - (assert-failure failure) - (assert-check-failure failure)) - -(define-check (check-fail/error pred-or-msg chk-thnk) - (contract-pred-or-msg! 'check-fail/error pred-or-msg) - (contract-thunk! 'check-fail/error chk-thnk) - (define failure (check-raise-value chk-thnk)) - (with-expected pred-or-msg - (assert-failure failure) - (assert-not-check-failure failure) - (cond - [(procedure? pred-or-msg) - (unless (pred-or-msg failure) - (with-actual failure - (fail-check "Wrong error raised")))] - [(exn? failure) - (define msg (exn-message failure)) - (unless (regexp-match? pred-or-msg msg) - (with-actual failure - (with-check-info (['actual-msg msg]) - (fail-check "Wrong error raised"))))] - [else - (with-actual failure - (fail-check "Wrong error raised"))]))) + (unless (exn:test:check? failure) + (with-actual failure + (fail-check "Check raised error instead of failing"))) + (check-tree-assert tree failure)) ;; Shorthands for adding infos (define-simple-macro (with-actual act:expr body:expr ...) - (with-check-info* (list (make-check-actual act)) (λ () body ...))) + (with-check-info* (error-info act) (λ () body ...))) -(define-simple-macro (with-expected exp:expr body:expr ...) - (with-check-info* (list (make-check-expected exp)) (λ () body ...))) +(define (list/if . vs) (filter values vs)) -;; Pseudo-contract helpers, to be replaced with real check contracts eventually +(define (error-info raised) + (list/if (make-check-actual raised) + (and (exn? raised) + (make-check-info 'actual-message (exn-message raised))) + (and (exn:test:check? raised) + (make-check-info 'actual-info + (nested-info + (exn:test:check-stack raised)))))) -(define (contract-pred-or-msg! name pred-or-msg) - (unless (or (and (procedure? pred-or-msg) - (procedure-arity-includes? pred-or-msg 1)) - (regexp? pred-or-msg)) - (define ctrct "(or/c (-> any/c boolean?) regexp?)") - (raise-argument-error name ctrct pred-or-msg))) +;; Pseudo-contract helpers, to be replaced with real check contracts eventually (define (contract-thunk! name thnk) - (unless (procedure? thnk) (raise-argument-error name "(-> any)" thnk))) - -(define (contract-info! name info) - (unless (check-info? info) (raise-argument-error name "check-info?" info))) + (unless (and (procedure? thnk) + (procedure-arity-includes? thnk 0)) + (raise-argument-error name "(-> any)" thnk))) + +(define (contract-tree! name tree) + (for ([v (in-list (flatten tree))]) + (unless (or (and (procedure? v) + (procedure-arity-includes? v 1)) + (regexp? v) + (check-info? v)) + (define ctrct "(or/c (-> any/c boolean?) regexp? check-info?)") + (raise-argument-error name ctrct v)))) ;; Extracting raised values from checks @@ -109,22 +62,58 @@ ;; instead of writing to stdout / stderr, 2) the inner check doesn't log ;; any pass or fail information to rackunit/log, and 3) the inner check's info ;; stack is independent of the outer check's info stack. - (parameterize ([current-check-handler raise] - [test-log-enabled? #f] - [current-check-info (list)]) - (with-handlers ([(negate exn:break?) values]) (chk-thnk) #f))) + (or (parameterize ([current-check-handler raise] + [test-log-enabled? #f] + [current-check-info (list)]) + (with-handlers ([(negate exn:break?) values]) (chk-thnk) #f)) + (fail-check "Check passed unexpectedly"))) ;; Assertion helpers -(define (assert-failure maybe-failure) - (unless maybe-failure (fail-check "No check failure occurred"))) - -(define (assert-check-failure failure) - (unless (exn:test:check? failure) - (with-actual failure - (fail-check "A value other than a check failure was raised")))) - -(define (assert-not-check-failure failure) - (when (exn:test:check? failure) - (with-actual failure - (fail-check "Wrong error raised")))) +(struct failure (type expected) #:transparent) + +(define (assert-pred raised pred) + (and (not (pred raised)) + (failure 'predicate pred))) + +(define (assert-regexp exn rx) + (and (not (regexp-match? rx (exn-message exn))) + (failure 'message rx))) + +(define (assert-info exn info) + (and (not (member info (exn:test:check-stack exn))) + (failure 'info info))) + +(define (assert assertion raised) + ((cond [(procedure? assertion) assert-pred] + [(regexp? assertion) assert-regexp] + [(check-info? assertion) assert-info]) + raised assertion)) + +(define (assertions-adjust assertions raised) + (define is-exn? (exn? raised)) + (define has-regexps? (ormap regexp? assertions)) + (define adjust-regexps? (and has-regexps? (not is-exn?))) + (if adjust-regexps? + (cons exn? (filter-not regexp? assertions)) + assertions)) + +(define (assertion-tree-apply tree raised) + (define assertions (assertions-adjust (flatten tree) raised)) + (filter-map (λ (a) (assert a raised)) assertions)) + +(define (failure-list->info failures) + (define vs + (if (equal? (length failures) 1) + (pretty-info (failure-expected (first failures))) + (nested-info (for/list ([f (in-list failures)]) + (make-check-info (failure-type f) + (pretty-info (failure-expected f))))))) + (make-check-info 'expected vs)) + +(define (check-tree-assert tree raised) + (with-actual raised + (define failures (assertion-tree-apply tree raised)) + (unless (empty? failures) + (with-check-info* (list (failure-list->info failures)) + fail-check)))) diff --git a/rackunit-test/tests/rackunit/meta-test.rkt b/rackunit-test/tests/rackunit/meta-test.rkt index 77db7d9..fe21bea 100644 --- a/rackunit-test/tests/rackunit/meta-test.rkt +++ b/rackunit-test/tests/rackunit/meta-test.rkt @@ -2,7 +2,8 @@ (module+ test (require rackunit - rackunit/meta) + rackunit/meta + (only-in rackunit/private/check-info pretty-info)) (define foo-info (make-check-info 'foo 'foo)) (define-check (check-raise) (raise 'foo)) @@ -13,105 +14,32 @@ ;; confusing, but given the self-referential nature of testing a testing ;; framework we've got to tie the knot somewhere. - (test-case "meta checks fail on non-failing thunks" - (check-fail #rx"No check failure occurred" - (λ () (check-fail (λ (_) #t) void))) - (check-fail #rx"No check failure occurred" (λ () (check-fail* void))) - (check-fail #rx"No check failure occurred" - (λ () (check-fail/info foo-info void))) - (check-fail #rx"No check failure occurred" - (λ () (check-fail/error (λ (_) #t) void)))) - - (test-case "non-error meta checks fail on non-failure raised values" - (check-fail #rx"A value other than a check failure was raised" - (λ () (check-fail (λ (_) #t) check-raise))) - (check-fail #rx"A value other than a check failure was raised" - (λ () (check-fail* check-raise))) - (check-fail #rx"A value other than a check failure was raised" - (λ () (check-fail/info foo-info check-raise)))) - - (test-case "non-error meta checks add info for non-failure raised values" - (define actual-info (make-check-actual 'foo)) - (check-fail/info actual-info (λ () (check-fail (λ (_) #t) check-raise))) - (check-fail/info actual-info (λ () (check-fail* check-raise))) - (check-fail/info actual-info (λ () (check-fail/info foo-info check-raise)))) - - (test-case "check-fail adds an expected info" - (check-fail/info (make-check-expected #rx"bar") - (λ () (check-fail #rx"bar" void)))) - - (test-case "check-fail/info adds an expected info" - (check-fail/info (make-check-expected foo-info) - (λ () (check-fail/info foo-info void)))) - - (test-case "check-fail* passes for any check failure" - (check-fail* fail)) - - (test-case "check-fail asserts failure matches predicate or regexp" - (define-check (fail/msg) (fail-check "Message!")) - (check-fail #rx"sage" fail/msg) - (check-fail #rx"Wrong exception raised" - (λ () (check-fail #rx"notinmessage" fail/msg))) - (check-fail (λ (e) (equal? (exn-message e) "Message!")) fail/msg) - (check-fail #rx"Wrong exception raised" - (λ () - (check-fail (λ (e) (equal? (exn-message e) "Not message!")) - fail/msg)))) - - (test-case "check-fail/info passes on failures with matching info" - (define-check (fail/foo-info) (with-check-info* (list foo-info) fail-check)) - (check-fail/info foo-info fail/foo-info) - (check-fail* (λ () (check-fail/info foo-info fail))) - (define-check (fail/multiple-foo-info) - (with-check-info* (list (make-check-info 'foo 'foo2) foo-info) - fail-check)) - (check-fail/info foo-info fail/multiple-foo-info)) - - (test-case "check-fail/info adds info names on failure without expected info" - (define info-names (list 'name 'location 'expression 'params)) - (check-fail/info (make-check-info 'actual-info-names info-names) - (λ () (check-fail/info foo-info fail)))) - - (test-case "check-fail/info adds info value on failure with not-equal info" - (define-check (fail/foo-bar) (with-check-info (['foo 'bar]) (fail-check))) - (check-fail/info (make-check-actual (make-check-info 'foo 'bar)) - (λ () (check-fail/info foo-info fail/foo-bar)))) - - (test-case "check-fail/error asserts check raises non-failure error matching predicate or regexp" - (define-check (raise-foo) (raise 'foo)) - (check-fail/error (λ (v) (equal? v 'foo)) raise-foo) - (check-fail #rx"Wrong error raised" - (λ () (check-fail/error (λ (v) (equal? v 'bar)) raise-foo))) - (define-check (raise-exn) - (raise (make-exn "Message!" (current-continuation-marks)))) - (check-fail/error #rx"sage" raise-exn) - (check-fail #rx"Wrong error raised" - (λ () (check-fail/error #rx"notinmessage" raise-exn))) - (check-fail #rx"Wrong error raised" - (λ () (check-fail/error #rx"foo" raise-foo))) - (check-fail #rx"Wrong error raised" - (λ () (check-fail/error (λ (_) #t) fail)))) - - (test-case "meta checks raise contract errors on invalid arguments" - (define ((contract-exn/source source) v) - (and (exn:fail:contract? v) - (regexp-match? (regexp source) (exn-message v)))) - (define (not-a-pred v extra) #t) - (check-fail/error (contract-exn/source "check-fail") - (λ () (check-fail 'not-pred-or-regexp fail))) - (check-fail/error (contract-exn/source "check-fail") - (λ () (check-fail #rx"foo" 'not-a-thunk))) - (check-fail/error (contract-exn/source "check-fail") - (λ () (check-fail not-a-pred fail))) - (check-fail/error (contract-exn/source "check-fail*") - (λ () (check-fail* 'not-a-thunk))) - (check-fail/error (contract-exn/source "check-fail/info") - (λ () (check-fail/info 'not-info fail))) - (check-fail/error (contract-exn/source "check-fail/info") - (λ () (check-fail/info foo-info 'not-a-thunk))) - (check-fail/error (contract-exn/source "check-fail/error") - (λ () (check-fail/error 'not-pred-or-regexp fail))) - (check-fail/error (contract-exn/source "check-fail/error") - (λ () (check-fail/error #rx"foo" 'not-a-thunk))) - (check-fail/error (contract-exn/source "check-fail/error") - (λ () (check-fail/error not-a-pred fail))))) + (define (accepts-no-args) (void)) + (define-check (fail/raise) (raise 'foo)) + (define-check (fail-foo) (fail-check "foo")) + (define-check (fail-not-foo) (fail-check "bar")) + (define some-info (make-check-info 'random 'info)) + (define-check (fail/info) (with-check-info* (list some-info) fail-check)) + (define (foo-fail? e) (equal? (exn-message e) "foo")) + + (test-case "check-fail" + (check-fail '() fail-check) + (check-fail foo-fail? fail-foo) + (check-fail #rx"foo" fail-foo) + (check-fail some-info fail/info) + (check-fail #rx"Check passed unexpectedly" (λ () (check-fail '() void))) + (check-fail #rx"Check raised error instead of failing" + (λ () (check-fail '() fail/raise))) + (check-fail (make-check-info 'expected (pretty-info foo-fail?)) + (λ () (check-fail foo-fail? fail-not-foo))) + (check-fail (make-check-info 'expected (pretty-info #rx"foo")) + (λ () (check-fail #rx"foo" fail-not-foo))) + (check-fail (make-check-info 'expected (pretty-info some-info)) + (λ () (check-fail some-info fail-check))) + (check-exn exn:fail:contract? + (λ () (check-fail 'nonsense fail-check))) + (check-exn exn:fail:contract? + (λ () (check-fail (list #rx"foo" 'partial-nonsense) + fail-check))) + (check-exn exn:fail:contract? + (λ () (check-fail accepts-no-args fail-check)))))