check-exn: stop ignoring the message argument (#65)

* check-info: add check-info-ref helpers

Add `check-info-ref` and `check-info-contains-key?`,
 similar to `hash-ref`,
 but you can omit the "hashtable" argument --- by default its `(current-check-info)`

* check-exn: only update check-info message when user did not supply one

Author: bennn

rackunit-lib/rackunit/private/check-info.rkt

@@ -21,12 +21,18 @@
   [struct dynamic-info ([proc (-> any/c)])]
   [info-value->string (-> any/c string?)]
   [current-check-info (parameter/c (listof check-info?))]
+  [check-info-contains-key? (check-info-> symbol? boolean?)]
+  [check-info-ref (check-info-> symbol? (or/c check-info? #f))]
   [with-check-info* ((listof check-info?) (-> any) . -> . any)])
  with-check-info)
 
 (module+ for-test
   (provide trim-current-directory))
 
+(define (check-info-> dom cod)
+  (case-> (-> dom cod)
+          (-> (listof check-info?) dom cod)))
+
 ;; Structures --------------------------------------------------
 
 (struct check-info (name value)
@@ -96,3 +102,17 @@
 (define-check-type message any/c)
 (define-check-type actual any/c #:wrapper pretty-info)
 (define-check-type expected any/c #:wrapper pretty-info)
+
+(define check-info-ref
+  (case-lambda
+   [(k)
+    (check-info-ref (current-check-info) k)]
+   [(info k)
+    (findf (λ (i) (eq? k (check-info-name i))) info)]))
+
+(define check-info-contains-key?
+  (case-lambda
+   [(k)
+    (check-info-contains-key? (current-check-info) k)]
+   [(info k)
+    (and (check-info-ref info k) #t)]))

rackunit-lib/rackunit/private/check.rkt

@@ -164,14 +164,17 @@
            [exn:fail?
             (lambda (exn)
               (with-check-info*
-               (list
-                (make-check-message "Wrong exception raised")
+               (list/if
+                (and (not (check-info-contains-key? 'message))
+                     (make-check-message "Wrong exception raised"))
                 (make-check-info 'exn-message (exn-message exn))
                 (make-check-info 'exn exn))
                (lambda () (fail-check))))])
         (thunk))
       (with-check-info*
-       (list (make-check-message "No exception raised"))
+       (list/if
+         (and (not (check-info-contains-key? 'message))
+              (make-check-message "No exception raised")))
        (lambda () (fail-check))))))
 
 (define-check (check-not-exn thunk)
@@ -181,8 +184,9 @@
        [exn?
         (lambda (exn)
           (with-check-info*
-           (list
-            (make-check-message "Exception raised")
+           (list/if
+            (and (not (check-info-contains-key? 'message))
+                 (make-check-message "Exception raised"))
             (make-check-info 'exception-message (exn-message exn))
             (make-check-info 'exception exn))
            (lambda () (fail-check))))])

rackunit-test/tests/rackunit/check-info-test.rkt

@@ -116,6 +116,22 @@
     (check-equal? (call/info-box call-check-foo/extra-infos)
                   (list 'name 'location 'expression 'params 'custom)))
 
+  (test-case "check-info-ref / check-info-contains-key"
+    (define info0 (list (make-check-name 'my-name)))
+    (define info1 (list (make-check-message 'my-message)))
+
+    (parameterize ([current-check-info info0])
+      (check-not-false (check-info-ref 'name))
+      (check-false (check-info-ref 'message))
+
+      (check-not-false (check-info-ref info1 'message))
+      (check-false (check-info-ref info1 'name))
+
+      (check-true (check-info-contains-key? 'name))
+      (check-false (check-info-contains-key? 'message))
+      (check-true (check-info-contains-key? info1 'message))
+      (check-false (check-info-contains-key? info1 'name))))
+
   (test-case "All tests for trim-current-directory"
     (test-case "trim-current-directory leaves directories outside the current directory alone"
       (check-equal? (trim-current-directory "/foo/bar/") "/foo/bar/"))