From fcf4936592928e7d9987552be5365c0f59a92c56 Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@ccs.neu.edu>
Date: Thu, 1 Sep 2011 12:21:08 -0400
Subject: [PATCH] improved error messages when handlers fail check-with tests

---
 collects/2htdp/private/checked-cell.rkt           |  7 ++++++-
 .../2htdp/private/clauses-spec-and-process.rkt    |  5 ++++-
 .../2htdp/{tests-failed => tests}/key-error.rkt   | 15 +++++++++++++++
 collects/2htdp/xtest                              |  2 ++
 4 files changed, 27 insertions(+), 2 deletions(-)
 rename collects/2htdp/{tests-failed => tests}/key-error.rkt (59%)

diff --git a/collects/2htdp/private/checked-cell.rkt b/collects/2htdp/private/checked-cell.rkt
index 0f69390edc..357dfed519 100644
--- a/collects/2htdp/private/checked-cell.rkt
+++ b/collects/2htdp/private/checked-cell.rkt
@@ -68,9 +68,14 @@
           (tp-error 'check-with "the test function ~a is expected to return a boolean, but it returned ~v" 
                     (object-name ok?) b))
         (unless b
+          (define check-with-name 
+            (let ([n (symbol->string (object-name ok?))])
+              (if (regexp-match "check-with" n)
+                  "handler"
+                  n)))
           (tp-error 'check-with "~a ~a ~v, which fails to pass check-with's ~a test"
                     tag (if say-evaluated-to "evaluated to" "returned") 
-                    nw (object-name ok?)))
+                    nw check-with-name))
         nw))
     
     ;; Symbol Any -> Void 
diff --git a/collects/2htdp/private/clauses-spec-and-process.rkt b/collects/2htdp/private/clauses-spec-and-process.rkt
index 6c281fa338..798b7c8d15 100644
--- a/collects/2htdp/private/clauses-spec-and-process.rkt
+++ b/collects/2htdp/private/clauses-spec-and-process.rkt
@@ -86,7 +86,10 @@
                [(null? spec) #false]
                [(or (free-identifier=? (caar spec) kw)
                     (free-identifier=? (caar spec) kw-alt))
-                (syntax->list (cdar spec))]
+                ; (syntax->list (cdar spec))
+                (for/list ([i (syntax->list (cdar spec))])
+                  (define n  (string->symbol (format "~a handler" (syntax-e (caar spec)))))
+                  (syntax-property  i 'inferred-name n))]
                [else (loop (cdr spec))])))
          (if r ((third s) r) (fourth s)))
        Spec))
diff --git a/collects/2htdp/tests-failed/key-error.rkt b/collects/2htdp/tests/key-error.rkt
similarity index 59%
rename from collects/2htdp/tests-failed/key-error.rkt
rename to collects/2htdp/tests/key-error.rkt
index 805b6dabcd..eae0051257 100644
--- a/collects/2htdp/tests-failed/key-error.rkt
+++ b/collects/2htdp/tests/key-error.rkt
@@ -18,3 +18,18 @@
                              (unless (and hdl (cons? (regexp-match "on-tick" (second hdl))))
                                (error 'test "expected: \"on-tick\", actual: ~e" (second hdl))))))
   (main))
+
+
+(define (my-fun x) "hi")
+
+(with-handlers ((exn:fail? 
+                 (lambda (x) 
+                   (define msg (exn-message x))
+                   (define hdl (regexp-match "check-with's handler test" msg))
+                   (unless hdl
+                     (error 'test "expected: \"check-with's handler test, error says: ~e" msg)))))
+  (big-bang 0 
+            [to-draw (lambda (x) (circle 1 'solid 'red))]
+            [on-tick (lambda (x) (my-fun x))]
+            [check-with (lambda (x) (number? x))])
+  (raise `(bad "must fail")))
diff --git a/collects/2htdp/xtest b/collects/2htdp/xtest
index 9ba11282ef..52553b9325 100755
--- a/collects/2htdp/xtest
+++ b/collects/2htdp/xtest
@@ -10,6 +10,7 @@ run() {
 
 cd tests 
 
+run key-error.rkt
 run bad-draw.rkt
 run error-in-tick.rkt
 run error-in-draw.rkt
@@ -34,3 +35,4 @@ run record-stop-when.rkt
 run stop-when-crash.rkt
 run on-tick-universe-with-limit.rkt
 run on-tick-with-limit.rkt
+