Skip to content

Commit a4809bc

Browse files
mikesperbermikesperber
committed
Blame the correct check-* form upon exceptions.
Fixes #245.
1 parent 3944db1 commit a4809bc

File tree

4 files changed

+126
-13
lines changed

4 files changed

+126
-13
lines changed

‎htdp-doc/test-engine/test-engine.scrbl

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -231,6 +231,38 @@ An error happened instead of regular termination. This also contains markup
231231
describing the error.
232232
}
233233

234+
@defstruct*[(unexpected-error/check-* unexpected-error/markup)
235+
((srcloc srcloc?)
236+
(expected any/c)
237+
(exn exn?)
238+
(error-markup markup?)
239+
(form-name (or/c symbol? string?)))]{
240+
An error happened instead of regular termination. This also contains markup
241+
describing the error and the name of the check form.
242+
}
243+
244+
@defstruct*[(unexpected-error/range unexpected-error/markup)
245+
((srcloc srcloc?)
246+
(expected any/c)
247+
(exn exn?)
248+
(error-markup markup?)
249+
(min real?)
250+
(max real?))]{
251+
An error happened instead of regular termination in a @racket[check-range] form.
252+
This also contains markup describing the error.
253+
}
254+
255+
@defstruct*[(unexpected-error/member unexpected-error/markup)
256+
((srcloc srcloc?)
257+
(expected any/c)
258+
(exn exn?)
259+
(error-markup markup?)
260+
(set any/c))]{
261+
An error happened instead of regular termination in a @racket[check-member-of] form.
262+
This also contains markup describing the error.
263+
}
264+
265+
234266
@defstruct*[(unequal fail-reason)
235267
((srcloc srcloc?)
236268
(actual any/c)

‎htdp-lib/test-engine/racket-tests.rkt

Lines changed: 15 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -100,10 +100,6 @@
100100
((error-display-handler) (exn-message exn) exn)
101101
(get-markup))))
102102

103-
(define (make-exn->unexpected-error src expected)
104-
(lambda (exn)
105-
(unexpected-error/markup src expected exn (exn->markup exn))))
106-
107103
(define-syntax (check-expect stx)
108104
(check-context! 'check-expect CHECK-EXPECT-DEFN-STR stx)
109105
(syntax-case stx ()
@@ -123,7 +119,8 @@
123119
(if (teach-equal? actual expected)
124120
#t
125121
(unequal src actual expected))))
126-
(make-exn->unexpected-error src expected)))
122+
(lambda (exn)
123+
(unexpected-error/check-* src expected exn (exn->markup exn) 'check-expect))))
127124

128125
(define-syntax (check-random stx)
129126
(syntax-case stx ()
@@ -150,7 +147,8 @@
150147
(if (teach-equal? actual expected)
151148
#t
152149
(unequal src actual expected))))
153-
(make-exn->unexpected-error src expected)))))
150+
(lambda (exn)
151+
(unexpected-error/check-* src expected exn (exn->markup exn) 'check-random))))))
154152

155153
(define-syntax (check-satisfied stx)
156154
(syntax-case stx ()
@@ -234,7 +232,8 @@
234232
(if (beginner-equal~? actual expected within)
235233
#t
236234
(not-within src actual expected within))))
237-
(make-exn->unexpected-error src expected)))
235+
(lambda (exn)
236+
(unexpected-error/check-* src expected exn (exn->markup exn) 'check-within))))
238237

239238
(define-syntax (check-error stx)
240239
(check-context! 'check-error CHECK-ERROR-DEFN-STR stx)
@@ -263,7 +262,8 @@
263262
(incorrect-error/markup src error exn (exn->markup exn)))))])
264263
(let ([actual (test)])
265264
(expected-error src error actual))))
266-
(make-exn->unexpected-error src error))) ; probably can't happen
265+
(lambda (exn)
266+
(unexpected-error/check-* src error exn (exn->markup exn) 'check-error)))) ; probably can't happen
267267

268268
(define (do-check-error/no-message test src)
269269
(execute-test
@@ -273,7 +273,8 @@
273273
(lambda (exn) #t)])
274274
(let ([actual (test)])
275275
(expected-error src #f actual))))
276-
(make-exn->unexpected-error src "any error"))) ; probably can't happen
276+
(lambda (exn)
277+
(unexpected-error/check-* src "any error" exn (exn->markup exn) 'check-error)))) ; probably can't happen
277278

278279
(define-syntax (check-member-of stx)
279280
(check-context! 'check-member-of CHECK-EXPECT-DEFN-STR stx)
@@ -298,10 +299,11 @@
298299
(if (memf (lambda (expected) (teach-equal? actual expected)) expecteds)
299300
#t
300301
(not-mem src actual expecteds))))
301-
(make-exn->unexpected-error src expecteds)))
302+
(lambda (exn)
303+
(unexpected-error/member src #f exn (exn->markup exn) expecteds))))
302304

303305
(define-syntax (check-range stx)
304-
(check-context! 'check-member-of CHECK-EXPECT-DEFN-STR stx)
306+
(check-context! 'check-range CHECK-EXPECT-DEFN-STR stx)
305307
(syntax-case stx ()
306308
[(_ test min max)
307309
(check-expect-maker stx #'do-check-range #`test (list #`min #`max)
@@ -321,7 +323,8 @@
321323
(<= min val max))
322324
#t
323325
(not-range src val min max))))
324-
(make-exn->unexpected-error src (format "[~a, ~a]" min max))))
326+
(lambda (exn)
327+
(unexpected-error/range src #f exn (exn->markup exn) min max))))
325328

326329
(define (error-check pred? actual fmt fmt-act?)
327330
(unless (pred? actual)

‎htdp-lib/test-engine/test-engine.rkt

Lines changed: 35 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,12 +32,35 @@
3232
(expected any/c)
3333
(exn exn?)))
3434

35+
; deprecated
3536
(struct (unexpected-error/markup unexpected-error)
3637
((srcloc srcloc?)
3738
(expected any/c)
3839
(exn exn?)
3940
(error-markup markup?)))
4041

42+
(struct (unexpected-error/check-* unexpected-error/markup)
43+
((srcloc srcloc?)
44+
(expected any/c)
45+
(exn exn?)
46+
(error-markup markup?)
47+
(form-name (or/c symbol? string?))))
48+
49+
(struct (unexpected-error/range unexpected-error/markup)
50+
((srcloc srcloc?)
51+
(expected any/c)
52+
(exn exn?)
53+
(error-markup markup?)
54+
(min real?)
55+
(max real?)))
56+
57+
(struct (unexpected-error/member unexpected-error/markup)
58+
((srcloc srcloc?)
59+
(expected any/c)
60+
(exn exn?)
61+
(error-markup markup?)
62+
(set any/c)))
63+
4164
; wanted to satisfy a predicate, but error happend
4265
(struct (unsatisfied-error fail-reason)
4366
((srcloc srcloc?)
@@ -207,9 +230,21 @@
207230
(struct unexpected-error fail-reason (expected exn)
208231
#:transparent)
209232

233+
; deprecated
210234
(struct unexpected-error/markup unexpected-error (error-markup)
211235
#:transparent)
212236

237+
(struct unexpected-error/check-* unexpected-error/markup (form-name)
238+
#:transparent)
239+
240+
; in this case, the expected field from unexpected-error is #f
241+
; for historical reasons
242+
(struct unexpected-error/range unexpected-error/markup (min max)
243+
#:transparent)
244+
245+
(struct unexpected-error/member unexpected-error/markup (set)
246+
#:transparent)
247+
213248
(struct unsatisfied-error fail-reason (name exn)
214249
#:transparent)
215250

‎htdp-lib/test-engine/test-markup.rkt

Lines changed: 44 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -195,6 +195,14 @@
195195
(cdr vals)
196196
(cons (framed-markup (value->markup (car vals))) rev-markups)
197197
rev-lines))
198+
((#\L #\l)
199+
(loop (cddr chars)
200+
(cdr vals)
201+
(append (reverse (cdr (append-map (lambda (val)
202+
(list " " (framed-markup (value->markup val))))
203+
(car vals))))
204+
rev-markups)
205+
rev-lines))
198206
((#\a #\A)
199207
(let ((val (car vals)))
200208
(loop (cddr chars)
@@ -227,11 +235,26 @@
227235

228236
(define (reason->markup fail)
229237
(cond
238+
[(unexpected-error/range? fail)
239+
(format->markup (string-constant test-engine-check-range-encountered-error)
240+
(unexpected-error/range-min fail)
241+
(unexpected-error/range-max fail)
242+
(unexpected-error/markup-error-markup fail))]
243+
[(unexpected-error/member? fail)
244+
(horizontal
245+
(format->markup (string-constant test-engine-check-member-of-encountered-error)
246+
(unexpected-error/member-set fail)
247+
(unexpected-error/markup-error-markup fail)))]
248+
[(unexpected-error/check-*? fail)
249+
(format->markup (string-constant test-engine-check-*-encountered-error)
250+
(unexpected-error/check-*-form-name fail)
251+
(unexpected-error-expected fail)
252+
(unexpected-error/markup-error-markup fail))]
230253
[(unexpected-error/markup? fail)
231254
(format->markup (string-constant test-engine-check-encountered-error)
232255
(unexpected-error-expected fail)
233256
(unexpected-error/markup-error-markup fail))]
234-
257+
235258
[(unexpected-error? fail)
236259
(format->markup (string-constant test-engine-check-encountered-error)
237260
(unexpected-error-expected fail)
@@ -423,6 +446,24 @@
423446
(unexpected-error/markup (srcloc 'source 1 0 10 20) 'expected (exn "not expected" (current-continuation-marks))
424447
(vertical "line1" "line2"))
425448
(srcloc 'exn 2 1 30 40)))
449+
(define fail-unexpected-error/check-*
450+
(failed-check
451+
(unexpected-error/check-* (srcloc 'source 1 0 10 20) 'expected (exn "not expected" (current-continuation-marks))
452+
(vertical "line1" "line2")
453+
'check-something)
454+
(srcloc 'exn 2 1 30 40)))
455+
(define fail-unexpected-error/range
456+
(failed-check
457+
(unexpected-error/range (srcloc 'source 1 0 10 20) #f (exn "not expected" (current-continuation-marks))
458+
(vertical "line1" "line2")
459+
1 5)
460+
(srcloc 'exn 2 1 30 40)))
461+
(define fail-unexpected-error/member
462+
(failed-check
463+
(unexpected-error/member (srcloc 'source 1 0 10 20) #f (exn "not expected" (current-continuation-marks))
464+
(vertical "line1" "line2")
465+
'(1 2 3))
466+
(srcloc 'exn 2 1 30 40)))
426467
(define fail-unsatisfied-error
427468
(failed-check
428469
(unsatisfied-error (srcloc 'source 1 0 10 20) "zero?" (exn "not expected" (current-continuation-marks)))
@@ -520,6 +561,8 @@
520561
(test-object->markup
521562
(make-test-object (list void void)
522563
(list fail-unexpected-error fail-unexpected-error/markup
564+
fail-unexpected-error/check-*
565+
fail-unexpected-error/range fail-unexpected-error/member
523566
fail-unsatisfied-error fail-unsatisfied-error/markup
524567
fail-unequal fail-not-within
525568
fail-incorrect-error fail-incorrect-error/markup

0 commit comments

Comments
 (0)