Treat exceptions thrown by arguments to check as test failures (again)

This PR corrects the wrong fix in #123. It restores the functionality
that #109 is meant to implement while correctly reporting test results.

Author: sorawee

rackunit-lib/rackunit/private/check.rkt

@@ -92,7 +92,8 @@
 
 (define-simple-macro (make-check-func (name:id formal:id ...) #:public-name pub:id body:expr ...)
   (λ (#:location [location (list 'unknown #f #f #f #f)]
-      #:expression [expression 'unknown])
+      #:expression [expression 'unknown]
+      #:suppress-check? [suppress-check? #f])
     (procedure-rename
       (λ (formal ... [message #f])
           (define infos
@@ -102,7 +103,11 @@
                      (make-check-params (list formal ...))
                      (and message (make-check-message message))))
           (with-default-check-info* infos
-            (λ () ((current-check-around) (λ () body ... (void))))))
+            (λ ()
+              (define (the-body-thunk) body ... (void))
+              (cond
+                [suppress-check? (the-body-thunk)]
+                [else ((current-check-around) the-body-thunk)]))))
       'pub)))
 
 
@@ -120,9 +125,12 @@
                       (make-check-expression '(chk . args)))
                 #,(syntax/loc #'loc
                     (λ ()
-                      ((check-impl #:location location
-                                   #:expression '(chk . args))
-                       . args)))))]
+                      ((current-check-around)
+                       (λ ()
+                         ((check-impl #:location location
+                                      #:expression '(chk . args)
+                                      #:suppress-check? #t)
+                          . args)))))))]
           [chk:id
            #'(check-impl #:location (syntax->location #'loc)
                          #:expression 'chk)])))))

rackunit-test/tests/rackunit/pr/109+138.rkt

@@ -0,0 +1,51 @@
+#lang racket/base
+
+(require rackunit
+         rackunit/text-ui
+         racket/port
+         tests/eli-tester)
+
+(define output
+  (with-output-to-string
+    (lambda ()
+      (parameterize ([current-error-port (current-output-port)])
+        (run-tests (test-suite "tests"
+                     (check-equal? 1 1)
+                     (check-equal? (1) 1)
+                     (check-equal? 1 2)
+                     (check-equal? 1 1)))
+        (run-tests (test-suite "tests2"
+                     (check-equal? 5 5)
+                     (check-equal? 4 4)
+                     (check-equal? 3 3)
+                     (check-equal? 2 2)
+                     (check-equal? 1 1)))))))
+
+(test
+ (regexp-match
+  (regexp (regexp-quote "2 success(es) 1 failure(s) 1 error(s) 4 test(s) run\n"))
+  output))
+
+(test
+ (regexp-match
+  (regexp (regexp-quote "5 success(es) 0 failure(s) 0 error(s) 5 test(s) run\n"))
+  output))
+
+(test
+ (with-handlers ([exn:fail? (λ (e)
+                              (regexp-match
+                               (regexp (regexp-quote "given: 3"))
+                               (exn-message e)))])
+   (define my-check-equal? check-equal?)
+   (run-tests (test-suite "tests"
+                (my-check-equal? 1 1)
+                (my-check-equal? (3) 1)
+                (my-check-equal? 1 2)))
+   #f))
+
+(module test racket/base
+  (require syntax/location)
+  ;; Use a separate namespace to avoid logging results
+  ;; in this namespace (where `raco test` would see errors).
+  (parameterize ([current-namespace (make-base-namespace)])
+    (dynamic-require (quote-module-path "..") #f)))

rackunit-test/tests/rackunit/standalone-check-higher-order-test.rkt

@@ -0,0 +1,60 @@
+;;;
+;;; Time-stamp: <2008-06-06 15:32:49 noel>
+;;;
+;;; Copyright (C) by Noel Welsh.
+;;;
+
+;;; This library is free software; you can redistribute it
+;;; and/or modify it under the terms of the GNU Lesser
+;;; General Public License as published by the Free Software
+;;; Foundation; either version 2.1 of the License, or (at
+;;; your option) any later version.
+
+;;; This library is distributed in the hope that it will be
+;;; useful, but WITHOUT ANY WARRANTY; without even the
+;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
+;;; PARTICULAR PURPOSE.  See the GNU Lesser General Public
+;;; License for more details.
+
+;;; You should have received a copy of the GNU Lesser
+;;; General Public License along with this library; if not,
+;;; write to the Free Software Foundation, Inc., 59 Temple
+;;; Place, Suite 330, Boston, MA 02111-1307 USA
+
+;;; Author: Noel Welsh <[email protected]>
+
+
+;; Here we check the standalone (not within a test-case or
+;; test-suite) semantics of checks.  These tests are not
+;; part of the standard test suite and must be run
+;; separately.
+
+#lang racket/base
+
+(require rackunit/private/check)
+
+;; Don't run this test automatically:
+(module test racket/base
+  (displayln "run as program for tests"))
+
+(define my-check check)
+
+;; This check should succeed
+(my-check = 1 1 0.0)
+
+;; This check should display an error including the message "Outta here!"
+((values check-pred) (procedure-rename (lambda (x) (error "Outta here!")) 'proc) 'foo)
+
+
+;; This check should display a failure
+(my-check = 1 2 0.0)
+
+;; This check should display "Oh HAI!"
+(parameterize
+    ([current-check-handler (lambda (e) (display "Oh HAI!\n"))])
+  (my-check = 1 2 0.0))
+
+;; This check should display "I didn't run"
+(parameterize
+    ([current-check-around (lambda (t) (display "I didn't run\n"))])
+  (my-check = 1 1 0.0))

rackunit-test/tests/rackunit/standalone.rkt

@@ -56,6 +56,26 @@ message:    0.0
 --------------------
 ")
 
+(test-file "standalone-check-higher-order-test.rkt"
+           #"Oh HAI!\nI didn't run\n"
+           #"\
+--------------------
+ERROR
+name:       check-pred
+location:   standalone-check-higher-order-test.rkt:46:9
+params:     '(#<procedure:proc> foo)
+
+Outta here!
+--------------------
+--------------------
+FAILURE
+name:       check
+location:   standalone-check-higher-order-test.rkt:40:17
+params:     '(#<procedure:=> 1 2)
+message:    0.0
+--------------------
+")
+
 (test-file "standalone-test-case-test.rkt"
            #""
            #"\