Add meta checks

rackunit-doc/rackunit/scribblings/check.scrbl

@@ -1,10 +1,12 @@
 #lang scribble/doc
-@(require "base.rkt")
+@(require (except-in "base.rkt" examples)
+          scribble/example)
 
-@(require (for-label racket/match))
+@(require (for-label racket/match
+                     rackunit/meta))
 
 @(define rackunit-eval (make-base-eval))
-@(interaction-eval #:eval rackunit-eval (require rackunit))
+@(interaction-eval #:eval rackunit-eval (require rackunit rackunit/meta))
 @(interaction-eval #:eval rackunit-eval (error-print-context-length 0))
 
 @title{Checks}
@@ -490,4 +492,57 @@ Raises an @racket[exn:test:check] with the contents of the @tech{check-info stac
 The optional message is used as the exception's
 message.}
 
+@section{Testing Custom Checks}
+@defmodule[rackunit/meta]
+
+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 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 @tech{check-info 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] raises a check failure with @racket[fail-check] and
+ that the failure satisfies every assertion value in @racket[assertion-tree].
+ A failure can satisfy an assertion value in one of three ways, depending on the
+ type of assertion value:
+
+ @itemlist[
+ @item{A predicate assertion value @racket[p] is satisfied by a failure
+   @racket[f] if @racket[(p f)] returns a true value.}
+ @item{A regular expression assertion value @racket[r] is satisfied by a failure
+   if @racket[r] matches the failure's message (as returned by
+   @racket[exn-message]).}
+ @item{A @racket[check-info] assertion value @racket[i] is satisfied by a
+   failure if the @tech{check-info stack} returned by
+   @racket[exn:test:check-stack] contains a @racket[check-info] value that is
+   @racket[equal?] to @racket[i].}]
+
+ @examples[#:eval rackunit-eval
+           (check-fail '() (λ () (check-equal? 'foo 'bar)))
+           (check-fail number? (λ () (check-equal? 'foo 'bar)))
+           (check-fail (list string? (check-info 'info 10))
+                       (λ () (check-equal? 'foo 'foo)))]
+
+ In addition, 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
+           (check-fail '() (λ () (raise 'foo)))
+           (check-fail number? (λ () (check-equal? 'foo 'bar)) "my message")]
+
+ Proceed with caution when passing a complex tree to @racket[check-fail].
+ Semantically, a single check expression should assert "one thing"; consider
+ splitting the complex tree into multiple simpler calls to @racket[check-fail].
+
+ @history[#:added "1.9"]}
+
 @close-eval[rackunit-eval]

rackunit-lib/info.rkt

@@ -3,12 +3,12 @@
 (define collection 'multi)
 
 (define deps '("base"
-               "testing-util-lib"))
+               ("testing-util-lib" #:version "1.1")))
 
 (define implies '("testing-util-lib"))
 
 (define pkg-desc "RackUnit testing framework")
 
 (define pkg-authors '(ryanc noel))
 
-(define version "1.8")
+(define version "1.9")

rackunit-lib/rackunit/meta.rkt

@@ -0,0 +1,121 @@
+#lang racket/base
+
+(provide check-fail)
+
+(require (for-syntax racket/base)
+         racket/function
+         racket/list
+         rackunit/log
+         syntax/parse/define
+         rackunit
+         (only-in rackunit/private/check-info
+                  current-check-info
+                  pretty-info)
+         "private/util-list.rkt")
+
+
+(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))
+  (unless (exn:test:check? failure)
+    (with-actual failure
+      (fail-check "Check raised error instead of calling fail-check")))
+  (check-tree-assert tree failure))
+
+;; Shorthands for adding infos
+
+(define-simple-macro (with-actual act:expr body:expr ...)
+  (with-check-info* (error-info act) (λ () body ...)))
+
+(define (error-info raised)
+  (define (exn-info) (make-check-info 'exn (pretty-info raised)))
+  (define (msg-info) (make-check-info 'message (exn-message raised)))
+  (define (info-info)
+    (make-check-info 'info (nested-info (exn:test:check-stack raised))))
+  (define info-value
+    (cond [(exn:test:check? raised)
+           (nested-info (list (exn-info) (msg-info) (info-info)))]
+          [(exn? raised) (nested-info (list (exn-info) (msg-info)))]
+          [else (pretty-info raised)]))
+  (list (make-check-info 'actual info-value)))
+
+;; Pseudo-contract helpers, to be replaced with real check contracts eventually
+
+(define (contract-thunk! name thnk)
+  (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 any/c) regexp? check-info?)")
+      (raise-argument-error name ctrct v))))
+
+;; Extracting raised values from checks
+
+(define (check-raise-value chk-thnk)
+  ;; Checks called inside other checks raise their values normally and don't
+  ;; log test failures, so all we have to do is ensure the check is executed
+  ;; with an info stack that is independent of the outer check.
+  (or (parameterize ([current-check-info (list)])
+        (with-handlers ([(negate exn:break?) values]) (chk-thnk) #f))
+      (fail-check "Check passed unexpectedly")))
+
+;; Assertion helpers
+
+(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-sort-key f)
+  (case (failure-type f) [(predicate) 0] [(message) 1] [(info) 2]))
+
+(define (failure-list->info failures)
+  (define failures* (sort failures < #:key failure-sort-key))
+  (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))))

rackunit-lib/rackunit/private/check.rkt

@@ -10,7 +10,8 @@
          "base.rkt"
          "check-info.rkt"
          "format.rkt"
-         "location.rkt")
+         "location.rkt"
+         "util-list.rkt")
 
 (provide
  (contract-out
@@ -86,8 +87,6 @@
                         (exn-continuation-marks exn)
                         (exn:test:check-stack exn))))
 
-(define (list/if . vs) (filter values vs))
-
 (define-simple-macro
   (define-check-func (name:id formal:id ...) #:public-name pub:id body:expr ...)
   (define (name formal ... [message #f]

rackunit-lib/rackunit/private/test.rkt

@@ -53,7 +53,7 @@
          current-test-case-around
          test-suite-test-case-around
          test-suite-check-around
-         
+
          define-test-suite
          define/provide-test-suite
          test-suite*
@@ -89,7 +89,7 @@
          define-check
          define-simple-check
          define-binary-check
-         
+
          current-check-handler
          current-check-around
 

rackunit-lib/rackunit/private/util-list.rkt

@@ -0,0 +1,5 @@
+#lang racket/base
+
+(provide list/if)
+
+(define (list/if . vs) (filter values vs))

rackunit-test/tests/rackunit/meta-test.rkt

@@ -0,0 +1,53 @@
+#lang racket/base
+
+(module+ test
+  (require rackunit
+           rackunit/meta
+           (only-in rackunit/private/check-info pretty-info))
+
+  (define foo-info (make-check-info 'foo 'foo))
+  (define-check (check-raise) (raise 'foo))
+
+  ;; We test the meta checks using the meta checks themselves (essentially
+  ;; testing them twice). Direct uses of the checks assume they work, while
+  ;; individual test cases verify specific scenarios. This can be a bit
+  ;; confusing, but given the self-referential nature of testing a testing
+  ;; framework we've got to tie the knot somewhere.
+
+  (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 calling fail-check"
+                (λ () (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)))
+    (define (hello-world-exn? e) (equal? (exn-message e) "hello world"))
+    (define-check (fail/hello-world)
+      (with-check-info (['hello 'world])
+        (fail-check "hello world")))
+    (check-fail (list hello-world-exn?
+                      (list '(#rx"hello") '() (make-check-info 'hello 'world))
+                      #rx"world")
+                fail/hello-world)))