suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Updated the error messages of the world and universe teachpacks.

Browse Source
This commit is contained in:
Guillaume Marceau 2011-07-04 16:04:01 -04:00
parent aa9dbd21f5
commit 9706920055
12 changed files with 81 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/2htdp/private/checked-cell.rkt
View File

@ -15,14 +15,13 @@
(define checked-cell%
(class* object% (checked-cell<%>)
(init-field msg ;; String
value0 ;; X
(init-field value0 ;; X
ok?) ;; Any -> Boolean : X
(init [display #f]) ;; (U String #f) ; a string is the name of the state display window
(field
[value (coerce "initial value" value0)]
[value (coerce "the initial expression" value0 #t)]
;; (U False pasteboard%)
[pb (if (boolean? display)
#f
@ -63,10 +62,15 @@
(read-all)))))))
;; Symbol Any -> ok?
(define/private (coerce tag nw)
(define/private (coerce tag nw [say-evaluated-to #f])
(let ([b (ok? nw)])
(check-result "check-with predicate" boolean? "Boolean" b)
(check-result tag (lambda _ b) (format "~a (see check-with)" msg) nw)
(unless (boolean? b)
(tp-error 'check-with "the test function ~a is expected to return a boolean, but it returned ~v"
(object-name ok?) b))
(unless b
(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))
;; Symbol Any -> Void

18
collects/2htdp/private/clauses-spec-and-process.rkt
View File

@ -72,10 +72,9 @@
if anything fails, use the legal keyword to specialize the error message
|#
(define (->args tag stx state0 clauses Spec ->rec? legal)
(define msg (format "not a legal clause in a ~a description" legal))
(define (->args tag stx state0 clauses Spec ->rec?)
(define kwds (map (compose (curry datum->syntax stx) car) Spec))
(define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg kwds))
(define spec (clauses-use-kwd (syntax->list clauses) ->rec? tag kwds))
(duplicates? tag spec)
(not-a-clause tag stx state0 kwds)
(map (lambda (s)
@ -93,20 +92,21 @@
Spec))
;; check whether rec? occurs, produce list of keyword x clause pairs
(define (clauses-use-kwd stx:list ->rec? legal-clause kwds)
(define (clauses-use-kwd stx:list ->rec? tag kwds)
(define kwd-in? (->kwds-in kwds))
(define double (string-append legal-clause ", ~a has been redefined"))
(map (lambda (stx)
(syntax-case stx ()
[(kw . E) (kwd-in? #'kw) (begin (->rec? #'kw #'E) (cons #'kw stx))]
[(kw . E)
(let ([kw (syntax-e #'kw)])
(if (member kw (map syntax-e kwds))
(raise-syntax-error #f (format double kw) stx)
(raise-syntax-error #f legal-clause stx)))]
[_ (raise-syntax-error #f legal-clause stx)]))
(raise-syntax-error tag (format "the ~a clause appears twice" kw) stx)
(raise-syntax-error tag (format "~a clauses are not allowed when using ~a" kw tag)
stx)))]
[_ (raise-syntax-error tag "expected a clause, but found something else" stx)]))
stx:list))
;; [Listof SyntaxIdentifier] -> (Syntax -> Boolean)
(define (->kwds-in kwds)
(lambda (k)
@ -118,7 +118,7 @@
(syntax-case state0 ()
[(kw . E)
((->kwds-in kwds) #'kw)
(raise-syntax-error tag "missing initial state" stx)]
(raise-syntax-error tag "expected an initial state, but found a clause" stx)]
[_ #t]))
;; Symbol [Listof kw] -> true

13
collects/2htdp/private/universe.rkt
View File

@ -67,7 +67,7 @@
(field
[universe
(new checked-cell% [msg "UniSt"] [value0 universe0] [ok? check-with]
(new checked-cell% [value0 universe0] [ok? check-with]
[display (if (string? state) state (and state "your server's state"))])])
;; -----------------------------------------------------------------------
@ -87,7 +87,7 @@
(define n (if (object-name name) (object-name name) name))
(define-values (u mails bad)
(bundle> n (name (send universe get) a ...)))
(send universe set (format "~a callback" 'name) u)
(send universe set (format "value returned from ~a" 'name) u)
(unless (boolean? to-string) (send gui add (to-string u)))
(broadcast mails)
(for-each (lambda (iw)
@ -120,7 +120,7 @@
(kill iworld))
;; tick, tock : deal with a tick event for this world
(def/cback pubment (ptock) (lambda (w) (pptock w)))
(def/cback pubment (ptock) (let ([on-tick (lambda (w) (pptock w))]) on-tick))
(define/public (pptock w) (void))
;; IWorld -> Void
@ -179,7 +179,7 @@
(loop))))
;; --- go universe go ---
(set! iworlds '())
(send universe set "initial value" universe0)
(send universe set "initial expression" universe0)
(send gui add "a new universe is up and running")
(thread loop)))
@ -363,10 +363,7 @@
;; Symbol Any ->* Universe [Listof Mail] [Listof IWorld]
(define (bundle> tag r)
(unless (bundle? r)
(raise
(make-exn
(format "error: bundle expected from ~a, given: ~e" tag r)
(current-continuation-marks))))
(tp-error tag "expected the ~a function to return a bundle, but it returned ~e" tag r))
(values (bundle-state r) (bundle-mails r) (bundle-bad r)))
(define-struct mail (to content) #:transparent)

4
collects/2htdp/private/world.rkt
View File

@ -59,7 +59,7 @@
(field
[to-draw on-draw]
[world
(new checked-cell% [msg "World"] [value0 world0] [ok? check-with]
(new checked-cell% [value0 world0] [ok? check-with]
[display (and state (or name "your world program's state"))])])
@ -256,7 +256,7 @@
(queue-callback
(lambda ()
(with-handlers ([exn? (handler #t)])
(define tag (format "~a callback" 'transform))
(define tag (object-name transform))
(define nw (transform (send world get) arg ...))
(define (d) (pdraw) (set-draw#!))
;; ---

11
collects/2htdp/tests/on-tick-defined.rkt
View File

@ -6,9 +6,9 @@
(error-print-source-location #f)
(define legal "~a: not a legal clause in a world description")
(define legal "big-bang: ~a clauses are not allowed when using big-bang")
(define double
(string-append (format legal 'on-tick) ", on-tick has been redefined"))
"big-bang: the on-tick clause appears twice")
(with-handlers ((exn:fail:syntax?
(lambda (x)
@ -33,7 +33,8 @@
(with-handlers ((exn:fail:syntax?
(lambda (e)
(unless (string=? (exn-message e) (format legal 'stop-when))
(unless (string=? (exn-message e)
"big-bang: expected a clause, but found something else")
(raise e)))))
(eval '(module a scheme
(require 2htdp/universe)
@ -44,7 +45,7 @@
(with-handlers ((exn:fail:syntax?
(lambda (x)
(unless (string=? (exn-message x) "big-bang: missing initial state")
(unless (string=? (exn-message x) "big-bang: expected an initial state, but found a clause")
(raise x)))))
(eval '(module a scheme
(require 2htdp/universe)
@ -52,7 +53,7 @@
(with-handlers ((exn:fail:syntax?
(lambda (x)
(unless (string=? (exn-message x) "universe: missing initial state")
(unless (string=? (exn-message x) "universe: expected an initial state, but found a clause")
(raise x)))))
(eval '(module a scheme
(require 2htdp/universe)

28
collects/2htdp/tests/test-image.rkt
View File

@ -1972,60 +1972,60 @@
(test/exn (rectangle 10 10 "solid" (make-pen "black" 12 "solid" "round" "round"))
=>
#rx"^rectangle: expected <image-color>")
#rx"^rectangle: expects a image-color")
(test/exn (rectangle 10 10 'solid (make-pen "black" 12 "solid" "round" "round"))
=>
#rx"^rectangle: expected <image-color>")
#rx"^rectangle: expects a image-color")
(test/exn (circle 10 'solid (make-pen "black" 12 "solid" "round" "round"))
=>
#rx"^circle: expected <image-color>")
#rx"^circle: expects a image-color")
(test/exn (ellipse 10 10 'solid (make-pen "black" 12 "solid" "round" "round"))
=>
#rx"^ellipse: expected <image-color>")
#rx"^ellipse: expects a image-color")
(test/exn (triangle 10 'solid (make-pen "black" 12 "solid" "round" "round"))
=>
#rx"^triangle: expected <image-color>")
#rx"^triangle: expects a image-color")
(test/exn (right-triangle 10 12 'solid (make-pen "black" 12 "solid" "round" "round"))
=>
#rx"^right-triangle: expected <image-color>")
#rx"^right-triangle: expects a image-color")
(test/exn (isosceles-triangle 10 120 'solid (make-pen "black" 12 "solid" "round" "round"))
=>
#rx"^isosceles-triangle: expected <image-color>")
#rx"^isosceles-triangle: expects a image-color")
(test/exn (square 10 'solid (make-pen "black" 12 "solid" "round" "round"))
=>
#rx"^square: expected <image-color>")
#rx"^square: expects a image-color")
(test/exn (rhombus 40 45 'solid (make-pen "black" 12 "solid" "round" "round"))
=>
#rx"^rhombus: expected <image-color>")
#rx"^rhombus: expects a image-color")
(test/exn (regular-polygon 40 6 'solid (make-pen "black" 12 "solid" "round" "round"))
=>
#rx"^regular-polygon: expected <image-color>")
#rx"^regular-polygon: expects a image-color")
(test/exn (star 40 'solid (make-pen "black" 12 "solid" "round" "round"))
=>
#rx"^star: expected <image-color>")
#rx"^star: expects a image-color")
(test/exn (star-polygon 40 7 3 'solid (make-pen "black" 12 "solid" "round" "round"))
=>
#rx"^star-polygon: expected <image-color>")
#rx"^star-polygon: expects a image-color")
(test/exn (polygon (list (make-posn 0 0) (make-posn 100 0) (make-posn 100 100))
'solid (make-pen "black" 12 "solid" "round" "round"))
=>
#rx"^polygon: expected <image-color>")
#rx"^polygon: expects a image-color")
(test/exn (polygon (list (make-posn 0 0+1i) (make-posn 100 0) (make-posn 100 100))
'solid (make-pen "black" 12 "solid" "round" "round"))
=>
#rx"^polygon: expected <list-of-posns-with-real-valued-x-and-y-coordinates>")
#rx"^polygon: expects a list-of-posns-with-real-valued-x-and-y-coordinates")
(test/exn (save-image "tri.png" (triangle 50 "solid" "purple"))

18
collects/2htdp/universe.rkt
View File

@ -218,7 +218,7 @@
"wheel-down"))
(define-syntax (big-bang stx)
(define world0 "big-bang needs at least an initial world")
(define world0 "expects an expression for the initial world and at least one clause, but nothing's there")
(syntax-case stx ()
[(big-bang) (raise-syntax-error #f world0 stx)]
[(big-bang w clause ...)
@ -230,11 +230,11 @@
[(V) (set! rec? #'V)]
[_ (err '#'record? stx)])))]
[args
(->args 'big-bang stx #'w #'(clause ...) WldSpec ->rec? "world")]
(->args 'big-bang stx #'w #'(clause ...) WldSpec ->rec?)]
[dom (syntax->list #'(clause ...))])
(cond
[(and (not (contains-clause? #'to-draw dom)) (not (contains-clause? #'on-draw dom)))
(raise-syntax-error #f "missing to-draw clause" stx)]
(raise-syntax-error #f "expects at least one clause after the initial world, but nothing's there" stx)]
[else
(stepper-syntax-property
#`(run-it ((new-world (if #,rec? aworld% world%)) w #,@args))
@ -248,7 +248,7 @@
(define (run-movie r m*)
(check-arg 'run-movie (positive? r) "positive number" "first" r)
(check-arg 'run-movie (list? m*) "list (of images)" "second" m*)
(check-arg 'run-movie (list? m*) "list of images" "second" m*)
(for-each (lambda (m) (check-image 'run-movie m "first" "list of images")) m*)
(let* ([fst (car m*)]
[wdt (image-width fst)]
@ -314,16 +314,16 @@
(define-syntax (universe stx)
(syntax-case stx ()
[(universe) (raise-syntax-error #f "not a legal universe description" stx)]
[(universe u) (raise-syntax-error #f "not a legal universe description" stx)]
[(universe) (raise-syntax-error #f "expects an expression for the initial world and at least one clause, but nothing's there" stx)]
[(universe u) (raise-syntax-error #f "expects at least one clause after the initial world, but nothing's there" stx)]
[(universe u bind ...)
(let* ([args (->args 'universe stx #'u #'(bind ...) UniSpec void "universe")]
(let* ([args (->args 'universe stx #'u #'(bind ...) UniSpec void)]
[dom (syntax->list #'(bind ...))])
(cond
[(not (contains-clause? #'on-new dom))
(raise-syntax-error #f "missing on-new clause" stx)]
(raise-syntax-error #f "expects a on-new clause, but found none" stx)]
[(not (contains-clause? #'on-msg dom))
(raise-syntax-error #f "missing on-msg clause" stx)]
(raise-syntax-error #f "expects a on-msg clause, but found none" stx)]
[else ; (and (memq #'on-new dom) (memq #'on-msg dom))
#`(run-it ((new-universe universe%) u #,@args))]))]))

16
collects/htdp/error.rkt
View File

@ -1,12 +1,14 @@
#lang scheme/base
(require scheme/class)
(require scheme/class
lang/private/rewrite-error-message)
;; --------------------------------------------------------------------------
(provide check-arg check-arity check-proc check-result
check-list-list check-color
check-fun-res check-dependencies
natural?
find-non tp-exn? number->ord)
find-non tp-exn? number->ord
tp-error)
(define (natural? w)
(and (number? w) (integer? w) (>= w 0)))
@ -79,7 +81,7 @@
(define (check-result pname pred? expected given . other-given)
(if (pred? given)
given
(tp-error pname "result of type <~a> expected, your function produced ~a" expected
(tp-error pname "is expected to return a ~a, but it returned ~v" expected
(if (pair? other-given)
(car other-given)
given))))
@ -112,7 +114,7 @@
;; check-arg : sym bool str (or/c str non-negative-integer) TST -> void
(define (check-arg pname condition expected arg-posn given)
(unless condition
(tp-error pname "expected <~a> as ~a argument, given: ~e"
(tp-error pname "expects a ~a as ~a argument, given: ~e"
expected
(spell-out arg-posn)
given)))
@ -121,16 +123,16 @@
(define (check-arity name arg# args)
(if (= (length args) arg#)
(void)
(tp-error name "expects ~a arguments, given ~e" arg# (length args))))
(tp-error name (argcount-error-message arg# (length args)))))
;; check-proc :
;; sym (... *->* ...) num (union sym str) (union sym str) -> void
(define (check-proc proc f exp-arity arg# arg-err)
(unless (procedure? f)
(tp-error proc "procedure expected as ~a argument; given ~e" arg# f))
(tp-error proc "expected a function as ~a argument; given ~e" arg# f))
(let ([arity-of-f (procedure-arity f)])
(unless (procedure-arity-includes? f exp-arity) ; (and (number? arity-of-f) (>= arity-of-f exp-arity))
(tp-error proc "procedure of ~a expected as ~a argument; given procedure of ~a "
(tp-error proc "expected function of ~a as ~a argument; given function of ~a "
arg-err arg#
(cond
[(number? arity-of-f)

37
collects/htdp/world.rkt
View File

@ -73,6 +73,7 @@ Matthew
htdp/image
mrlib/cache-image-snip
lang/prim
lang/private/rewrite-error-message
(for-syntax scheme/base))
(require mrlib/gif)
@ -180,13 +181,8 @@ Matthew
(define args (length x))
(if (or (= args 5) (= args 4))
(apply big-bang0 x)
(error 'big-bang msg))))
(define msg
(string-append
"big-bang consumes 4 or 5 arguments:\n"
"-- (big-bang <width> <height> <rate> <world0>)\n"
"-- (big-bang <width> <height> <rate> <world0> <animated-gif>)\n"
"see Help Desk."))
(tp-error 'big-bang "expects 4 or 5 arguments, given ~a" args))))
(define *running?* #f)
(define big-bang0
(case-lambda
@ -199,17 +195,17 @@ Matthew
;; ============================================
(check-arg 'big-bang
(and (number? delta) (<= 0 delta 1000))
"number [of seconds] between 0 and 1000"
"number of seconds between 0 and 1000"
"third"
delta)
(check-arg 'big-bang
(boolean? animated-gif)
"boolean expected"
"boolean"
"fifth"
animated-gif)
(let ([w (coerce w)]
[h (coerce h)])
(when *running?* (error 'big-bang "the world is still running"))
(when *running?* (error 'big-bang "the world is still running, cannot start another world"))
(set! *running?* #t)
(callback-stop!)
;; (when (vw-init?) (error 'big-bang "big-bang already called once"))
@ -288,13 +284,7 @@ Matthew
(define args (length x))
(if (or (= args 5) (= args 4))
(apply run-simulation0 x)
(error 'run-simulation msg-run-simulation))))
(define msg-run-simulation
(string-append
"consumes 4 or 5 arguments:\n"
"-- (run-simulation <width> <height> <rate> <world-to-world-function>)\n"
"-- (run-simulation <width> <height> <rate> <world-to-world-function> <create-animated-gif?>)\n"
"see Help Desk."))
(tp-error 'run-simulation "expects 4 or 5 arguments, given ~a" args))))
(define run-simulation0
@ -343,7 +333,7 @@ Matthew
(define (check-scene tag i rank)
(if (image? i)
(unless (scene? i)
(error tag "scene expected, given image whose pinhole is at (~s,~s) instead of (0,0)"
(tp-error tag "expects a scene, given image whose pinhole is at (~s,~s) instead of (0,0)"
(pinhole-x i) (pinhole-y i)))
(check-arg tag #f "image" rank i)))
@ -415,7 +405,10 @@ Matthew
[(lower-left) (if (number? low) (add low h) (add 0 lft))]
[(upper-right) (if (number? upp) (add upp 0) (add w rgt))]
[(lower-right) (if (number? low) (add low h) (add w rgt))]
[else (error 'dir "contract violation: ~e" dir)])]
[else (tp-error
'dir
"expected a symbol for the direction, such as 'upper-left 'lower-right 'upper-right or 'lower-right, given ~a"
dir)])]
[(and (< 0 x1 w) (< 0 y1 h)) ;; (x1,y1) in interior; symmetry!
(add-line-to-scene0 img x1 y1 x0 y0 c)]
[else
@ -524,7 +517,7 @@ Matthew
(define unique-world (cons 1 1))
(define (check-world tag)
(when (eq? unique-world the-world)
(error tag "evaluate (big-bang Number Number Number World) first")))
(tp-error tag "big-bang has not been called before calling ~a" tag)))
(define the-world unique-world)
(define the-world0 unique-world)
@ -696,7 +689,7 @@ Matthew
[(tick) (timer-callback0 world)]
[(key) (key-callback0 world (cadr fst))]
[(mouse) (mouse-callback0 world (cadr fst) (caddr fst) (cadddr fst))]
[else (error 'play-back "bad type of event: ~s" fst)]))
[else (tp-error 'play-back "bad type of event: ~s" fst)]))
;; --- creating images
(define total (+ (length event-history) 1))
(define image-count 0)
@ -872,7 +865,7 @@ Matthew
[(send e entering?) 'enter]
[(send e leaving?) 'leave]
[else ; (send e get-event-type)
(error 'on-mouse-event
(tp-error 'on-mouse-event
(format
"Unknown event type: ~a"
(send e get-event-type)))]))

1
collects/lang/private/teach.rkt
View File

@ -64,7 +64,6 @@
syntax/stx
syntax/struct
syntax/context
syntax/colored-errors
mzlib/include
scheme/list
(rename racket/base racket:define-struct define-struct)

2
collects/tests/drracket/language-test.rkt
View File

@ -1015,7 +1015,7 @@ the settings above should match r5rs
"(void)"
"qqq: this name was defined previously and cannot be re-defined\n(void)")
(test-expression "(cond [(= 1 2) 3])" "cond: all question results were false")
(test-expression "(cons 1 2)" "cons: second argument must be a list or cyclic list, but received 1 and 2")
(test-expression "(cons 1 2)" "cons: second argument must be a list, but received 1 and 2")
(test-expression "(+ (list 1) 2)" "+: expects a number as 1st argument, given (list 1)")
(test-expression "'(1)"
"(list 1)"

3
collects/tests/drracket/repl-test.rkt
View File

@ -79,7 +79,6 @@ This produces an ACK message
(define test-data
(list
#|
;; basic tests
(mktest "1"
("1"
@ -611,7 +610,7 @@ This produces an ACK message
#f
void
void)
|#
;; error escape handler test
(mktest
"(let ([old (error-escape-handler)])\n(+ (let/ec k\n(dynamic-wind\n(lambda () (error-escape-handler (lambda () (k 5))))\n(lambda () (expt 3 #f))\n(lambda () (error-escape-handler old))))\n10))"