Redesign check-fail to provide a tree-based API

Author: jackfirth

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"]}
 

rackunit-lib/rackunit/meta.rkt

@@ -1,105 +1,58 @@
 #lang racket/base
 
-(provide check-fail/error
-         check-fail
-         check-fail*
-         check-fail/info)
+(provide check-fail)
 
 (require (for-syntax racket/base)
          racket/function
          racket/list
          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))))