Blame the correct check-* form upon exceptions.

mikesperber · mikesperber · commit a4809bca0895 · 2025-05-23T13:40:58.000+02:00
Fixes #245.
diff --git a/htdp-doc/test-engine/test-engine.scrbl b/htdp-doc/test-engine/test-engine.scrbl
@@ -231,6 +231,38 @@ An error happened instead of regular termination.  This also contains markup
 describing the error.
 }
 
+@defstruct*[(unexpected-error/check-* unexpected-error/markup)
+            ((srcloc srcloc?)
+             (expected any/c)
+             (exn exn?)
+	     (error-markup markup?)
+             (form-name (or/c symbol? string?)))]{
+An error happened instead of regular termination.  This also contains markup
+describing the error and the name of the check form.
+}
+
+@defstruct*[(unexpected-error/range unexpected-error/markup)
+            ((srcloc srcloc?)
+             (expected any/c)
+             (exn exn?)
+	     (error-markup markup?)
+             (min real?)
+             (max real?))]{
+An error happened instead of regular termination in a @racket[check-range] form.
+This also contains markup describing the error.
+}
+
+@defstruct*[(unexpected-error/member unexpected-error/markup)
+            ((srcloc srcloc?)
+             (expected any/c)
+             (exn exn?)
+	     (error-markup markup?)
+             (set any/c))]{
+An error happened instead of regular termination in a @racket[check-member-of] form.
+This also contains markup describing the error.
+}
+
+
 @defstruct*[(unequal fail-reason)
             ((srcloc srcloc?)
              (actual any/c)
diff --git a/htdp-lib/test-engine/racket-tests.rkt b/htdp-lib/test-engine/racket-tests.rkt
@@ -100,10 +100,6 @@
         ((error-display-handler) (exn-message exn) exn)
         (get-markup))))
 
-(define (make-exn->unexpected-error src expected)
-  (lambda (exn)
-    (unexpected-error/markup src expected exn (exn->markup exn))))
-
 (define-syntax (check-expect stx)
   (check-context! 'check-expect CHECK-EXPECT-DEFN-STR stx)
   (syntax-case stx ()
@@ -123,7 +119,8 @@
        (if (teach-equal? actual expected)
            #t
            (unequal src actual expected))))
-   (make-exn->unexpected-error src expected)))
+   (lambda (exn)
+     (unexpected-error/check-* src expected exn (exn->markup exn) 'check-expect))))
 
 (define-syntax (check-random stx)
   (syntax-case stx ()
@@ -150,7 +147,8 @@
            (if (teach-equal? actual expected)
                #t
                (unequal src actual expected))))
-       (make-exn->unexpected-error src expected)))))
+       (lambda (exn)
+         (unexpected-error/check-* src expected exn (exn->markup exn) 'check-random))))))
 
 (define-syntax (check-satisfied stx)
   (syntax-case stx ()
@@ -234,7 +232,8 @@
        (if (beginner-equal~? actual expected within)
            #t
            (not-within src actual expected within))))
-   (make-exn->unexpected-error src expected)))
+   (lambda (exn)
+     (unexpected-error/check-* src expected exn (exn->markup exn) 'check-within))))
 
 (define-syntax (check-error stx)
   (check-context! 'check-error CHECK-ERROR-DEFN-STR stx)
@@ -263,7 +262,8 @@
                               (incorrect-error/markup src error exn (exn->markup exn)))))])
        (let ([actual (test)])
          (expected-error src error actual))))
-   (make-exn->unexpected-error src error))) ; probably can't happen
+    (lambda (exn)
+      (unexpected-error/check-* src error exn (exn->markup exn) 'check-error))))  ; probably can't happen
 
 (define (do-check-error/no-message test src)
   (execute-test
@@ -273,7 +273,8 @@
                       (lambda (exn) #t)])
        (let ([actual (test)])
          (expected-error src #f actual))))
-   (make-exn->unexpected-error src "any error"))) ; probably can't happen
+   (lambda (exn)
+     (unexpected-error/check-* src "any error" exn (exn->markup exn) 'check-error))))  ; probably can't happen
 
 (define-syntax (check-member-of stx)
   (check-context! 'check-member-of CHECK-EXPECT-DEFN-STR stx)
@@ -298,10 +299,11 @@
        (if (memf (lambda (expected) (teach-equal? actual expected)) expecteds)
            #t
            (not-mem src actual expecteds))))
-   (make-exn->unexpected-error src expecteds)))
+   (lambda (exn)
+     (unexpected-error/member src #f exn (exn->markup exn) expecteds))))
        
 (define-syntax (check-range stx)
-  (check-context! 'check-member-of CHECK-EXPECT-DEFN-STR stx)
+  (check-context! 'check-range CHECK-EXPECT-DEFN-STR stx)
   (syntax-case stx ()
     [(_ test min max)
      (check-expect-maker stx #'do-check-range #`test (list #`min #`max)
@@ -321,7 +323,8 @@
                 (<= min val max))
            #t
            (not-range src val min max))))
-   (make-exn->unexpected-error src (format "[~a, ~a]" min max))))
+   (lambda (exn)
+     (unexpected-error/range src #f exn (exn->markup exn) min max))))
 
 (define (error-check pred? actual fmt fmt-act?)
   (unless (pred? actual)
diff --git a/htdp-lib/test-engine/test-engine.rkt b/htdp-lib/test-engine/test-engine.rkt
@@ -32,12 +32,35 @@
              (expected any/c)
              (exn exn?)))
 
+          ; deprecated
           (struct (unexpected-error/markup unexpected-error)
             ((srcloc srcloc?)
              (expected any/c)
              (exn exn?)
              (error-markup markup?)))
 
+          (struct (unexpected-error/check-* unexpected-error/markup)
+            ((srcloc srcloc?)
+             (expected any/c)
+             (exn exn?)
+             (error-markup markup?)
+             (form-name (or/c symbol? string?))))
+
+          (struct (unexpected-error/range unexpected-error/markup)
+            ((srcloc srcloc?)
+             (expected any/c)
+             (exn exn?)
+             (error-markup markup?)
+             (min real?)
+             (max real?)))
+
+          (struct (unexpected-error/member unexpected-error/markup)
+            ((srcloc srcloc?)
+             (expected any/c)
+             (exn exn?)
+             (error-markup markup?)
+             (set any/c)))
+
           ; wanted to satisfy a predicate, but error happend
           (struct (unsatisfied-error fail-reason)
             ((srcloc srcloc?)
@@ -207,9 +230,21 @@
 (struct unexpected-error fail-reason (expected exn)
   #:transparent)
 
+; deprecated
 (struct unexpected-error/markup unexpected-error (error-markup)
   #:transparent)
 
+(struct unexpected-error/check-* unexpected-error/markup (form-name)
+  #:transparent)
+
+; in this case, the expected field from unexpected-error is #f
+; for historical reasons
+(struct unexpected-error/range unexpected-error/markup (min max)
+  #:transparent)
+
+(struct unexpected-error/member unexpected-error/markup (set)
+  #:transparent)
+
 (struct unsatisfied-error fail-reason (name exn)
   #:transparent)
 
diff --git a/htdp-lib/test-engine/test-markup.rkt b/htdp-lib/test-engine/test-markup.rkt
@@ -195,6 +195,14 @@
                 (cdr vals)
                 (cons (framed-markup (value->markup (car vals))) rev-markups)
                 rev-lines))
+         ((#\L #\l)
+          (loop (cddr chars)
+                (cdr vals)
+                (append (reverse (cdr (append-map (lambda (val)
+                                                    (list " " (framed-markup (value->markup val))))
+                                                  (car vals))))
+                        rev-markups)
+                rev-lines))
          ((#\a #\A)
           (let ((val (car vals)))
             (loop (cddr chars)
@@ -227,11 +235,26 @@
 
 (define (reason->markup fail)
   (cond
+    [(unexpected-error/range? fail)
+     (format->markup (string-constant test-engine-check-range-encountered-error)
+                     (unexpected-error/range-min fail)
+                     (unexpected-error/range-max fail)
+                     (unexpected-error/markup-error-markup fail))]
+    [(unexpected-error/member? fail)
+     (horizontal
+      (format->markup (string-constant test-engine-check-member-of-encountered-error)
+                      (unexpected-error/member-set fail)
+                      (unexpected-error/markup-error-markup fail)))]
+    [(unexpected-error/check-*? fail)
+     (format->markup (string-constant test-engine-check-*-encountered-error)
+                     (unexpected-error/check-*-form-name fail)
+                     (unexpected-error-expected fail)
+                     (unexpected-error/markup-error-markup fail))]
     [(unexpected-error/markup? fail)
      (format->markup (string-constant test-engine-check-encountered-error)
                      (unexpected-error-expected fail)
                      (unexpected-error/markup-error-markup fail))]
-     
+
     [(unexpected-error? fail)
      (format->markup (string-constant test-engine-check-encountered-error)
                      (unexpected-error-expected fail)
@@ -423,6 +446,24 @@
      (unexpected-error/markup (srcloc 'source 1 0 10 20) 'expected (exn "not expected" (current-continuation-marks))
                               (vertical "line1" "line2"))
      (srcloc 'exn 2 1 30 40)))
+  (define fail-unexpected-error/check-*
+    (failed-check
+     (unexpected-error/check-* (srcloc 'source 1 0 10 20) 'expected (exn "not expected" (current-continuation-marks))
+                               (vertical "line1" "line2")
+                               'check-something)
+     (srcloc 'exn 2 1 30 40)))
+  (define fail-unexpected-error/range
+    (failed-check
+     (unexpected-error/range (srcloc 'source 1 0 10 20) #f (exn "not expected" (current-continuation-marks))
+                             (vertical "line1" "line2")
+                             1 5)
+     (srcloc 'exn 2 1 30 40)))
+  (define fail-unexpected-error/member
+    (failed-check
+     (unexpected-error/member (srcloc 'source 1 0 10 20) #f (exn "not expected" (current-continuation-marks))
+                              (vertical "line1" "line2")
+                              '(1 2 3))
+     (srcloc 'exn 2 1 30 40)))
   (define fail-unsatisfied-error
     (failed-check
      (unsatisfied-error (srcloc 'source 1 0 10 20) "zero?" (exn "not expected" (current-continuation-marks)))
@@ -520,6 +561,8 @@
    (test-object->markup
     (make-test-object (list void void)
                       (list fail-unexpected-error fail-unexpected-error/markup
+                            fail-unexpected-error/check-*
+                            fail-unexpected-error/range fail-unexpected-error/member
                             fail-unsatisfied-error fail-unsatisfied-error/markup
                             fail-unequal fail-not-within
                             fail-incorrect-error fail-incorrect-error/markup
