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

racket/gui: new-style error messages

Browse Source 
original commit: 69d2adce4d7561b3ba4b1c06c3fccba17e11ad05
This commit is contained in:
Matthew Flatt 2012-09-02 16:38:43 -06:00
parent e098fa417b
commit d296dbde10
19 changed files with 331 additions and 298 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/mred/private/app.rkt
View File

@ -55,9 +55,9 @@
(when proc
(unless (and (procedure? proc)
(procedure-arity-includes? proc arity))
(raise-type-error who
(format "procedure (arity ~a) or #f" arity)
proc)))
(raise-argument-error who
(format "(or/c (procedure-arity-includes/c ~a) #f)" arity)
proc)))
(let ([e (wx:current-eventspace)])
(when (wx:main-eventspace? e)
(param (make-app-handler
@ -178,9 +178,10 @@
(with-handlers ([exn:fail?
(lambda (x)
(if (wx:eventspace-shutdown? e)
(raise-mismatch-error
(raise-arguments-error
'eventspace-handler-thread
"eventspace is shutdown: "
"eventspace is shutdown"
"eventspace"
e)
(raise x)))])
(let ([done (make-semaphore)]

130
collects/mred/private/check.rkt
View File

@ -45,61 +45,67 @@
(when p
(let ([wx (mred->wx p)])
(unless wx
(raise-mismatch-error (who->name cwho)
"container is not yet fully initialized: "
p)))))
(raise-arguments-error (who->name cwho)
"container is not yet fully initialized"
"container" p)))))
(define (check-instance who class class-name false-ok? v)
(unless (or (and false-ok? (not v)) (is-a? v class))
(raise-type-error (who->name who) (format "~a object~a" class-name (if false-ok? " or #f" "")) v)))
(raise-argument-error (who->name who)
(let ([c (format "(is-a?/c ~a)" class-name)])
(if false-ok?
(format "(or/c ~a #f)" c)
c))
v)))
(define (check-string/false who str)
(unless (or (not str) (string? str))
(raise-type-error (who->name who) "string or #f" str)))
(raise-argument-error (who->name who) "(or/c string? #f)" str)))
(define (check-path who str)
(unless (path-string? str)
(raise-type-error (who->name who) "path or string" str)))
(raise-argument-error (who->name who) "path-string?" str)))
(define (check-path/false who str)
(unless (or (not str) (path-string? str))
(raise-type-error (who->name who) "path, string, or #f" str)))
(raise-argument-error (who->name who) "(or/c path-string? #f)" str)))
(define (check-string who str)
(unless (string? str)
(raise-type-error (who->name who) "string" str)))
(raise-argument-error (who->name who) "string?" str)))
(define (check-label-string who str)
(unless (label-string? str)
(raise-type-error (who->name who) "string (up to 200 characters)" str)))
(raise-argument-error (who->name who) "label-string?" str)))
(define (check-label-string/false who str)
(unless (or (not str) (label-string? str))
(raise-type-error (who->name who) "string (up to 200 characters) or #f" str)))
(raise-argument-error (who->name who) "(or/c label-string? #f)" str)))
(define (check-char/false who c)
(unless (or (not c) (char? c))
(raise-type-error (who->name who) "character or #f" c)))
(raise-argument-error (who->name who) "(or/c char? #f)" c)))
(define (check-callback who callback)
(unless (and (procedure? callback)
(procedure-arity-includes? callback 2))
(raise-type-error (who->name who) "procedure of arity 2" callback)))
(raise-argument-error (who->name who) "(procedure-arity-includes/c 2)" callback)))
(define (check-callback1 who callback)
(unless (and (procedure? callback)
(procedure-arity-includes? callback 1))
(raise-type-error (who->name who) "procedure of arity 1" callback)))
(raise-argument-error (who->name who) "(procedure-arity-includes/c 2)" callback)))
(define (check-bounded-integer min max false-ok?)
(lambda (who range)
(unless (or (and false-ok? (not range))
(and (integer? range) (exact? range) (<= min range max)))
(raise-type-error (who->name who)
(format "exact integer in [~a, ~a]~a"
min max
(if false-ok? " or #f" ""))
range))))
(raise-argument-error (who->name who)
(let ([i (format "(integer-in ~a ~a)" min max)])
(if false-ok?
(format "(or/c ~a #f)" i)
i))
range))))
(define check-range-integer (check-bounded-integer 0 10000 #f))
@ -116,24 +122,24 @@
(not (and (integer? wheel-step)
(exact? wheel-step)
(<= 1 wheel-step 10000))))
(raise-type-error (who->name cwho)
"#f or exact integer in [1,10000]"
wheel-step)))
(raise-argument-error (who->name cwho)
"(or/c #f (integer-in 1 10000))"
wheel-step)))
(define (check-fraction who x)
(unless (and (real? x) (<= 0.0 x 1.0))
(raise-type-error (who->name who)
"real number in [0.0, 1.0]"
x)))
(raise-argument-error (who->name who)
"(real-in 0.0 1.0)"
x)))
(define (-check-non-negative-integer who i false-ok?)
(when (or i (not false-ok?))
(unless (and (integer? i) (exact? i) (not (negative? i)))
(raise-type-error (who->name who)
(if false-ok?
"non-negative exact integer or #f"
"non-negative exact integer" )
i))))
(raise-argument-error (who->name who)
(if false-ok?
"(or/c exact-nonnegative-integer? #f)"
"exact-nonnegative-integer?")
i))))
(define (check-non-negative-integer who i)
(-check-non-negative-integer who i #f))
@ -146,7 +152,7 @@
(define (check-label-string-or-bitmap who label)
(unless (or (label-string? label) (is-a? label wx:bitmap%))
(raise-type-error (who->name who) "string (up to 200 characters) or bitmap% object" label)))
(raise-argument-error (who->name who) "(or/c label-string? (is-a?/c bitmap%))" label)))
(define (check-label-string-or-bitmap-or-both who label)
(unless (or (label-string? label) (is-a? label wx:bitmap%)
@ -155,54 +161,62 @@
(is-a? (car label) wx:bitmap%)
(label-string? (cadr label))
(memq (caddr label) '(left right top bottom))))
(raise-type-error (who->name who)
(string-append
"string (up to 200 characters), bitmap% object, or list of bitmap%, "
"string, and image-placement symbol ('left, 'right, 'top, or 'bottom)")
label)))
(raise-argument-error (who->name who)
(string-append
"(or/c label-string?\n"
" (is-a?/c bitmap%)\n"
" (list/c (is-a?/c bitmap%)\n"
" string\n"
" (or/c 'left 'right 'top 'bottom)))")
label)))
(define (check-label-string-or-bitmap/false who label)
(unless (or (not label) (label-string? label) (is-a? label wx:bitmap%))
(raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or #f" label)))
(raise-argument-error (who->name who) "(or/c label-string? (is-a?/c bitmap%) #f)" label)))
(define (check-label-string/bitmap/iconsym who label)
(unless (or (label-string? label) (is-a? label wx:bitmap%)
(memq label '(app caution stop)))
(raise-type-error (who->name who) "string (up to 200 characters), bitmap% object, or icon symbol" label)))
(raise-argument-error (who->name who) "(or/c label-string? (is-a?/c bitmap%) 'app 'caution 'stop)" label)))
(define (check-font who f)
(unless (or (eq? f no-val) (f . is-a? . wx:font%))
(raise-type-error (who->name who) "font% object" f)))
(raise-argument-error (who->name who) "(is-a?/c font%)" f)))
(define (check-style who reqd other-allowed style)
(unless (and (list? style) (andmap symbol? style))
(raise-type-error (who->name who) "list of style symbols" style))
(raise-argument-error (who->name who) "(listof symbol?)" style))
(when reqd
(letrec ([or-together (lambda (l)
(if (= (length l) 2)
(format "~a or ~a" (car l) (cadr l))
(let loop ([l l])
(if (null? (cdr l))
(format "or ~a" (car l))
(format "~a, ~a" (car l) (loop (cdr l)))))))])
(unless (ormap (lambda (i) (memq i reqd)) style)
(raise-type-error (who->name who)
(format "style list, missing ~a"
(if (= (length reqd) 1)
(car reqd)
(string-append
"one of "
(or-together reqd))))
style))))
(unless (ormap (lambda (i) (memq i reqd)) style)
(letrec ([or-together (lambda (l)
(if (= (length l) 2)
(format "~e or ~e" (car l) (cadr l))
(let loop ([l l])
(if (null? (cdr l))
(format "or ~e" (car l))
(format "~e, ~a" (car l) (loop (cdr l)))))))])
(raise-arguments-error (who->name who)
(string-append
"missing a required option in given style list\n"
" must include: " (or-together reqd))
"given" style))))
(if (and (not reqd) (null? other-allowed))
(unless (null? style)
(raise-type-error (who->name who) "empty style list" style))
(raise-arguments-error (who->name who)
"empty style list required"
"given" style))
(let* ([l (append (or reqd null) other-allowed)]
[bad (ormap (lambda (x) (if (memq x l) #f x)) style)])
(when bad
(raise-type-error (who->name who) (format "style list, ~e not allowed" bad) style))
(raise-arguments-error (who->name who)
"invalid symbol in given style list"
"invalid symbol" bad
"given" style))
(let loop ([l style])
(unless (null? l)
(when (memq (car l) (cdr l))
(raise-type-error (who->name who) (format "style list, ~e allowed only once" (car l)) style))
(raise-arguments-error (who->name who)
"duplicate style in given style list"
"duplicate" (car l)
"given" style))
(loop (cdr l))))))))

14
collects/mred/private/editor.rkt
View File

@ -61,9 +61,9 @@
(define (check-format who format)
(unless (memq format '(guess standard text text-force-cr same copy))
(raise-type-error (who->name who)
"'guess, 'standard, 'text, 'text-force-cr, 'same, or 'copy"
format)))
(raise-argument-error (who->name who)
"(or/c 'guess 'standard 'text 'text-force-cr 'same 'copy)"
format)))
(define-syntax (augmentize stx)
(syntax-case stx ()
@ -378,7 +378,7 @@
(entry-point
(lambda (type)
(unless (memq type '(text pasteboard))
(raise-type-error (who->name '(method editor<%> on-new-box)) "symbol: text or pasteboard" type))
(raise-argument-error (who->name '(method editor<%> on-new-box)) "(or/c 'text 'pasteboard)" type))
(make-object editor-snip%
(let ([e (make-object (cond
[(eq? type 'pasteboard) pasteboard%]
@ -557,9 +557,9 @@
(lambda (p)
(unless (and (procedure? p)
(procedure-arity-includes? p 1))
(raise-type-error who
"procedure of arity 1"
p))
(raise-argument-error who
"(procedure-arity-includes/c 1)"
p))
p))
(define current-text-keymap-initializer

2
collects/mred/private/filedialog.rkt
View File

@ -37,7 +37,7 @@
(string? (car p))
(string? (cadr p))))
filters))
(raise-type-error who "list of 2-string lists" filters))
(raise-argument-error who "(listof (list/c string? string?))" filters))
(let* ([std? (memq 'common style)]
[style (if std? (remq 'common style) style)])
(if std?

6
collects/mred/private/misc.rkt
View File

@ -41,7 +41,7 @@
(define (sleep/yield secs)
(unless (and (real? secs) (not (negative? secs)))
(raise-type-error 'sleep/yield "non-negative real number" secs))
(raise-argument-error 'sleep/yield "(>=/c 0.0)" secs))
(let ([evt (alarm-evt (+ (current-inexact-milliseconds)
(* secs 1000)))])
;; First, allow at least some events to be handled even if
@ -126,8 +126,8 @@
(follow))))))
(define (play-sound f async?)
(unless (or (path? f) (string? f))
(raise-type-error 'play-sound "string-or-path" f))
(unless (path-string? f)
(raise-argument-error 'play-sound "path-string?" f))
(unless (file-exists? f)
(error 'play-sound "file not found: ~e" f))
((if (eq? (system-type) 'unix) (force unix-play-command) wx:play-sound)

23
collects/mred/private/moredialogs.rkt
View File

@ -236,15 +236,15 @@
(check-label-string 'get-choices-from-user title)
(check-label-string/false 'get-choices-from-user message)
(unless (and (list? choices) (andmap label-string? choices))
(raise-type-error 'get-choices-from-user "list of strings (up to 200 characters)" choices))
(raise-argument-error 'get-choices-from-user "(listof label-string?)" choices))
(check-top-level-parent/false 'get-choices-from-user parent)
(unless (and (list? init-vals) (andmap (lambda (x) (and (integer? x) (exact? x) (not (negative? x)))) init-vals))
(raise-type-error 'get-choices-from-user "list of exact non-negative integers" init-vals))
(unless (and (list? init-vals) (andmap exact-nonnegative-integer? init-vals))
(raise-argument-error 'get-choices-from-user "(listof exact-nonnegative-integer?)" init-vals))
(check-style 'get-choices-from-user '(single multiple extended) null style)
(when (and (memq 'single style) (> (length init-vals) 1))
(raise-mismatch-error 'get-choices-from-user
(format "multiple initial-selection indices provided with ~e style: " 'single)
init-vals))
(raise-arguments-error 'get-choices-from-user
"multiple initial-selection indices provided with 'single style"
"indices" init-vals))
(let* ([f (make-object dialog% title parent box-width (min 300 (max 150 (* 14 (length choices)))))]
[ok-button #f]
[update-ok (lambda (l) (send ok-button enable (not (null? (send l get-selections)))))]
@ -259,11 +259,12 @@
[p (make-object horizontal-pane% f)])
(for-each (lambda (i)
(when (>= i (send l get-number))
(raise-mismatch-error
'get-choices-from-user
(format "inital-selection list specifies an out-of-range index (~e choices provided): "
(send l get-number))
i))
(raise-arguments-error
'get-choices-from-user
"out of range;\n inital-selection list specifies an out-of-range index"
"index" i
"provided choices" (send l get-number)
"list..." init-vals))
(send l select i #t)) init-vals)
(send p set-alignment 'right 'center)
(send p stretchable-height #f)

46
collects/mred/private/mrcanvas.rkt
View File

@ -50,13 +50,13 @@
(public get-dc)
(define/public (make-bitmap w h)
(unless (exact-positive-integer? w)
(raise-type-error (who->name '(method canvas% make-bitmap))
"exact positive integer"
w))
(raise-argument-error (who->name '(method canvas% make-bitmap))
"exact-positive-integer?"
w))
(unless (exact-positive-integer? h)
(raise-type-error (who->name '(method canvas% make-bitmap))
"exact positive integer"
h))
(raise-argument-error (who->name '(method canvas% make-bitmap))
"exact-positive-integer?"
h))
(send wx make-compatible-bitmap w h))
(define/public (suspend-flush)
@ -69,13 +69,13 @@
(entry-point
(lambda (c)
(unless (c . is-a? . wx:color%)
(raise-type-error (who->name '(method canvas<%> set-canvas-background))
"color% object"
c))
(unless (send wx get-canvas-background)
(raise-mismatch-error (who->name '(method canvas<%> set-canvas-background))
"cannot set a transparent canvas's background color: "
(raise-argument-error (who->name '(method canvas<%> set-canvas-background))
"(is-a?/c color%)"
c))
(unless (send wx get-canvas-background)
(raise-arguments-error (who->name '(method canvas<%> set-canvas-background))
"cannot set a transparent canvas's background color"
"given color" c))
(send wx set-canvas-background c))))
(public set-canvas-background)
(define get-canvas-background
@ -179,27 +179,27 @@
(check-range-integer who x-val)
(check-range-integer who y-val)
(when (and x-len (< x-len x-val))
(raise-mismatch-error (who->name who)
(format "horizontal value: ~e larger than the horizontal range: "
x-val)
x-len))
(raise-arguments-error (who->name who)
"horizontal value is larger than the horizontal range"
"value" x-val
"range" x-len))
(when (and y-len (< y-len y-val))
(raise-mismatch-error (who->name who)
(format "vertical value: ~e larger than the vertical range: "
y-val)
y-len)))
(raise-arguments-error (who->name who)
"vertical value is larger than the vertical range"
"value" y-val
"range" y-len)))
(send wx set-scrollbars (if x-len 1 0) (if y-len 1 0)
(or x-len 0) (or y-len 0) x-page y-page x-val y-val #f))
(define/public (show-scrollbars x-on? y-on?)
(let ([bad (lambda (which what)
(raise-mismatch-error
(raise-arguments-error
(who->name '(method canvas% show-scrollbars))
(format
"cannot show ~a scrollbars, because the canvas style did not include ~a: "
"cannot show ~a scrollbars;\n the canvas style did not include ~a"
which
what)
this))])
"canvas" this))])
(when x-on? (unless has-x? (bad "horizontal" 'hscroll)))
(when y-on? (unless has-y? (bad "vertical" 'vscroll)))
(send wx show-scrollbars x-on? y-on?)))

41
collects/mred/private/mrcontainer.rkt
View File

@ -33,7 +33,10 @@
(define (check-container-parent who p)
(unless (is-a? p internal-container<%>)
(raise-type-error (who->name who) "built-in container<%> object" p)))
(unless (is-a? p area-container<%>)
(raise-argument-error (who->name who) "(is-a?/c area-container<%>)" p))
(raise-arguments-error (who->name who) "invalid container;\n given container is not an instance of a built-in container class"
"given container" p)))
(define-local-member-name
has-wx-child?
@ -54,7 +57,7 @@
(= 2 (length alignment))
(memq (car alignment) '(left center right))
(memq (cadr alignment) '(top center bottom)))
(raise-type-error (who->name cwho) "alignment list" alignment))))
(raise-argument-error (who->name cwho) "(list/c (or/c 'left center right) (or/c 'top 'center 'bottom))" alignment))))
(define get-wx-panel get-wx-pan)
(define bdr (param get-wx-panel border))
@ -81,9 +84,9 @@
(lambda (f)
(unless (and (procedure? f)
(procedure-arity-includes? f 1))
(raise-type-error (who->name '(method container<%> change-children))
"procedure of arity 1"
f))
(raise-argument-error (who->name '(method container<%> change-children))
"(procedure-arity-includes/c 1)"
f))
(send (get-wx-panel) change-children
(lambda (kids)
(let* ([hidden (send (get-wx-panel) get-hidden-child)]
@ -91,9 +94,10 @@
[l (as-exit (lambda () (f mred-kids)))])
(unless (and (list? l)
(andmap (lambda (x) (is-a? x internal-subarea<%>)) l))
(raise-mismatch-error 'change-children
"result of given procedure was not a list of subareas: "
l))
(raise-arguments-error 'change-children
"result of given procedure was not a list of subareas"
"procedure" f
"result" l))
(append
(if hidden (list hidden) null)
(map mred->wx l)))))))]
@ -107,9 +111,9 @@
(integer? (car l)) (exact? (car l)) (<= 0 (car l) 10000)
(integer? (cadr l)) (exact? (cadr l)) (<= 0 (cadr l) 10000)))
l))
(raise-type-error (who->name '(method area-container<%> container-size))
"list of lists containing two exact integers in [0, 10000] and two booleans"
l))
(raise-argument-error (who->name '(method area-container<%> container-size))
"(listof (list/c (integer-in 0 10000) (integer-in 0 10000) any/c any/c))"
l))
(let ([l (send (get-wx-panel) do-get-graphical-min-size)])
(apply values l))))]
[place-children (entry-point (lambda (l w h) (send (get-wx-panel) do-place-children l w h)))]
@ -155,19 +159,20 @@
(let ([p1 (send (mred->wx this) get-top-level)]
[p2 (send (mred->wx new-parent) get-top-level)])
(eq? (send p1 get-eventspace) (send p1 get-eventspace)))))
(raise-mismatch-error
(raise-arguments-error
(who->name '(subwindow<%> reparent))
"current parent's eventspace is not the same as the eventspace of the new parent: "
new-parent))
"current parent's eventspace is not the same as the eventspace of the new parent"
"subwindow" this
"new parent" new-parent))
(let loop ([p new-parent])
(when p
(when (eq? p this)
(raise-mismatch-error
(raise-arguments-error
(who->name '(subwindow<%> reparent))
(if (eq? new-parent this)
"cannot set parent to self: "
"cannot set parent to a descedant: ")
new-parent))
"cannot set parent to self"
"cannot set parent to a descedant")
"subwindow" this))
(loop (send p get-parent))))
(let* ([added? (memq this (send (get-parent) get-children))]
[shown? (and added? (is-shown?))])

2
collects/mred/private/mred.rkt
View File

@ -160,7 +160,7 @@
(define (find-graphical-system-path what)
(unless (memq what '(init-file x-display))
(raise-type-error 'find-graphical-system-path "'init-file or 'x-display" what))
(raise-argument-error 'find-graphical-system-path "(or/c 'init-file 'x-display)" what))
(or (wx:find-graphical-system-path what)
(case what
[(init-file)

195
collects/mred/private/mritem.rkt
View File

@ -340,7 +340,7 @@
(unless (and (list? chcs) (pair? chcs)
(or (andmap label-string? chcs)
(andmap (lambda (x) (is-a? x wx:bitmap%)) chcs)))
(raise-type-error (who->name cwho) "non-empty list of strings (up to 200 characters) or bitmap% objects" chcs))
(raise-argument-error (who->name cwho) "(or/c (non-empty-listof label-string?) (non-empty-listof (is-a?/c bitmap%)))" chcs))
(check-container-parent cwho parent)
(check-callback cwho callback)
(check-orientation cwho style)
@ -355,7 +355,8 @@
`(method radio-box% ,method) n)
(when n
(unless (< n (length chcs))
(raise-mismatch-error (who->name `(method radio-box% ,method)) "no such button: " n))))])
(raise-arguments-error (who->name `(method radio-box% ,method)) "no such button"
"index" n))))])
(override*
[enable (entry-point
(case-lambda
@ -398,11 +399,7 @@
(let ([cwho '(constructor radio-box)])
(check-container-ready cwho parent)
(when selection
(unless (< selection (length choices))
(raise-mismatch-error (who->name cwho)
(format "initial selection is too large, given only ~a choices: "
(length choices))
selection)))))
(check-list-control-selection cwho choices selection))))
label parent callback #f)
[font font]
[enabled enabled]
@ -440,15 +437,16 @@
(check-style cwho '(vertical horizontal) '(plain vertical-label horizontal-label deleted) style)
(check-font cwho font)
(unless (<= minv maxv)
(raise-mismatch-error (who->name cwho)
(format "minumum value: ~e is greater than maximum value: " minv)
maxv))
(raise-arguments-error (who->name cwho)
"minumum value is greater than maximum value"
"minimum" minv
"maximum" maxv))
(unless (<= minv init-value maxv)
(raise-mismatch-error (who->name cwho)
(format "minumum value: ~e and maximum value: ~e do no bound initial value: "
minv
maxv)
init-value)))
(raise-arguments-error (who->name cwho)
"range error;\n initial value is not between minumum value and maximum value inclusive"
"initial value" init-value
"minimum" minv
"maximum" maxv)))
(define wx #f)
(public*
[get-value (entry-point (lambda () (send wx get-value)))]
@ -456,10 +454,11 @@
(lambda (v)
(check-slider-integer '(method slider% set-value) v)
(unless (<= minv v maxv)
(raise-mismatch-error (who->name '(method slider% set-value))
(format "slider's range is ~a to ~a; cannot set the value to: "
minv maxv)
v))
(raise-arguments-error (who->name '(method slider% set-value))
"out of range;\n given value is not between minimum and maximum values"
"given" v
"minimum" minv
"maximum" maxv))
(send wx set-value v)))])
(as-entry
(lambda ()
@ -512,10 +511,10 @@
(lambda (v)
(check-range-integer '(method gauge% set-value) v)
(when (> v (send wx get-range))
(raise-mismatch-error (who->name '(method gauge% set-value))
(format "gauge's range is 0 to ~a; cannot set the value to: "
(send wx get-range))
v))
(raise-arguments-error (who->name '(method gauge% set-value))
"out of range;\n given value is not between 0 and maximum value"
"given" v
"maximum" (send wx get-range)))
(send wx set-value v)))]
[get-range (entry-point (lambda () (send wx get-range)))]
[set-range (entry-point
@ -595,8 +594,9 @@
(let ([pos (do-find-string s)])
(if pos
(send wx set-selection pos)
(raise-mismatch-error (who->name '(method list-control<%> set-string-selection))
"no item matching the given string: " s)))))]
(raise-arguments-error (who->name '(method list-control<%> set-string-selection))
"no item matching the given string"
"given" s)))))]
[find-string (entry-point (lambda (x)
(check-label-string '(method list-control<%> find-string) x)
(do-find-string x)))]
@ -629,12 +629,13 @@
(check-non-negative-integer `(method list-control<%> ,method) n)
(let ([m (send wx number)])
(unless (< n m)
(raise-mismatch-error (who->name `(method list-control<%> ,method))
(if (zero? m)
"control has no items; given index: "
(format "control has only ~a items, indexed 0 to ~a; given out-of-range index: "
m (sub1 m)))
n))))])
(raise-range-error (who->name `(method list-control<%> ,method))
"control" "item "
n
this
0
(sub1 m)
#f))))])
(as-entry
(lambda ()
(super-make-object (lambda () (set! wx (mk-wx)) wx) mismatches label parent callback #f)))
@ -644,16 +645,16 @@
(define (check-list-control-args cwho label choices parent callback)
(check-label-string/false cwho label)
(unless (and (list? choices) (andmap label-string? choices))
(raise-type-error (who->name cwho) "list of strings (up to 200 characters)" choices))
(raise-argument-error (who->name cwho) "(listof label-string?)" choices))
(check-container-parent cwho parent)
(check-callback cwho callback))
(define (check-list-control-selection cwho choices selection)
(unless (< selection (length choices))
(raise-mismatch-error (who->name cwho)
(format "initial selection is too large, given only ~a choices: "
(length choices))
selection)))
(raise-arguments-error (who->name cwho)
"given initial selection is too large"
"given" selection
"choice count" (length choices))))
(define choice%
(class basic-list-control%
@ -725,34 +726,36 @@
(unless (and (list? columns)
(not (null? columns))
(andmap label-string? columns))
(raise-type-error (who->name cwho) "non-empty list of strings (up to 200 characters)" columns))
(raise-argument-error (who->name cwho) "(non-empty-listof label-string?)" columns))
(when column-order
(check-column-order cwho column-order (length columns))))
(private*
[check-column-order
(lambda (cwho column-order count)
(unless (and (list? column-order)
(andmap exact-integer? column-order)
(equal? (sort column-order <)
(for/list ([i (in-range (length column-order))]) i)))
(raise-type-error (who->name cwho)
"#f or list of distinct exact integers from 0 to one less than the list length"
column-order))
(andmap exact-nonnegative-integer? column-order))
(raise-argument-error (who->name cwho)
"(listof exact-nonnegative-integer?)"
column-order))
(unless (equal? (sort column-order <)
(for/list ([i (in-range (length column-order))]) i))
(raise-arguments-error (who->name cwho)
"bad column-order list;\n not a permutation of integers from 0 to one less than the list length"
"list" column-order))
(unless (= (length column-order) count)
(raise-mismatch-error (who->name cwho)
(format "column count ~a does not match length of column-order list: "
count)
column-order)))]
(raise-arguments-error (who->name cwho)
"column count does not match length of column-order list"
"count" count
"list" column-order)))]
[check-column-number
(lambda (who i)
(unless (exact-nonnegative-integer? i)
(raise-type-error (who->name who) "exact nonnegative integer" i))
(raise-argument-error (who->name who) "exact-nonnegative-integer?" i))
(unless (i . < . num-columns)
(raise-mismatch-error (who->name who)
(format
"index is too large for ~a-column list box: "
num-columns)
i)))])
(raise-arguments-error (who->name who)
"given column index is too large"
"given" i
"column count" num-columns)))])
(define column-labels (map string->immutable-string columns))
(define num-columns (length columns))
(define variable-columns? (memq 'variable-columns style))
@ -790,17 +793,15 @@
(check-dimension who min-size)
(check-dimension who max-size)
(unless (<= min-size w)
(raise-mismatch-error (who->name who)
(format
"size ~a is less than mininum size: "
w)
min-size))
(raise-arguments-error (who->name who)
"given size is less than mininum size"
"given" w
"minimum" min-size))
(unless (>= max-size w)
(raise-mismatch-error (who->name who)
(format
"size ~a is less than maximum size: "
w)
max-size)))
(raise-arguments-error (who->name who)
"given size is greater than maximum size"
"given" w
"maximum" max-size)))
(send wx set-column-size i w min-size max-size))]
[get-column-width (lambda (i)
(check-column-number '(method list-box% get-column-width) i)
@ -809,14 +810,16 @@
(let ([who '(method list-box% delete-column)])
(check-column-number who i)
(unless variable-columns?
(raise-mismatch-error
(raise-arguments-error
(who->name who)
"list box without 'variable-columns style cannot delete column: "
i))
"cannot delete column;\n list box was created without 'variable-columns style"
"column" i
"list box" this))
(unless (num-columns . > . 1)
(raise-mismatch-error (who->name who)
"cannot delete only column: "
i)))
(raise-arguments-error (who->name who)
"cannot delete column;\n list box has only one column"
"column" i
"list box" this)))
(as-entry
(lambda ()
(set! num-columns (sub1 num-columns))
@ -829,10 +832,11 @@
(let ([who '(method list-box% append-column)])
(check-label-string who label)
(unless variable-columns?
(raise-mismatch-error
(raise-arguments-error
(who->name who)
"list box without 'variable-columns style cannot add column: "
label)))
"cannot add column;\n list box created without 'variable-columns style"
"list box" this
"new column" label)))
(as-entry
(lambda ()
(set! num-columns (add1 num-columns))
@ -851,22 +855,20 @@
[set (entry-point (lambda (l . more)
(let ([cwho '(method list-box% set)])
(unless (= num-columns (+ 1 (length more)))
(raise-mismatch-error (who->name cwho)
(format
"column count ~a doesn't match number of arguments: "
num-columns)
(add1 (length more))))
(raise-arguments-error (who->name cwho)
"column count doesn't match argument count"
"column count" num-columns
"argument count" (add1 (length more))))
(for ([l (in-list (cons l more))])
(unless (and (list? l) (andmap label-string? l))
(raise-type-error (who->name cwho)
"list of strings (up to 200 characters)" l)))
(raise-argument-error (who->name cwho) "(listof label-string?)" l)))
(for ([more-l (in-list more)])
(unless (= (length more-l) (length l))
(raise-mismatch-error
(raise-arguments-error
(who->name cwho)
(format "first list length ~a does not match length of later argument: "
(length l))
more-l))))
"first list length does not match length of later argument"
"first list length" (length l)
"larger argument length" (length more-l)))))
(send this -set-list-strings l)
(send wx set l . more)))]
[set-string (entry-point
@ -875,13 +877,15 @@
(check-non-negative-integer cwho n) ; int error before string
(check-label-string cwho d) ; string error before range mismatch
(unless (exact-nonnegative-integer? col)
(raise-type-error (who->name cwho) "exact nonnegative integer" col))
(raise-argument-error (who->name cwho) "exact-nonnegative-integer?" col))
(unless (< -1 col num-columns)
(raise-mismatch-error (who->name cwho)
(format
"column number is not in the list box's allowed range [0, ~a]: "
(sub1 num-columns))
col)))
(raise-range-error (who->name cwho)
"list box" "column "
col
this
0
(sub1 num-columns)
#f)))
(check-item 'set-string n)
(send this -set-list-string n d)
(send wx set-string n d col)))]
@ -902,12 +906,13 @@
(check-non-negative-integer `(method list-box% ,method) n)
(let ([m (send wx number)])
(unless (< n m)
(raise-mismatch-error (who->name `(method list-box% ,method))
(if (zero? m)
"list has no items; given index: "
(format "list has only ~a items, indexed 0 to ~a; given out-of-range index: "
m (sub1 m)))
n)))))])
(raise-range-error (who->name `(method list-box% ,method))
"list box" "item "
n
this
0
(sub1 m)
#f)))))])
(super-new
[mk-wx
(lambda ()

40
collects/mred/private/mrmenu.rkt
View File

@ -185,7 +185,8 @@
(char? c)
(and (symbol? c)
(wx:key-symbol-to-menu-key c)))
(raise-type-error (who->name who) "character, key-code symbol, or #f" c)))
;; FIXME: `key-code-symbol?' is not exported
(raise-argument-error (who->name who) "(or/c char? key-code-symbol? #f)" c)))
(define (check-shortcut-prefix who p)
(unless (and (list? p)
@ -197,25 +198,28 @@
[(null? p) #t]
[(memq (car p) (cdr p)) #f]
[else (loop (cdr p))])))
(raise-type-error (who->name who)
"list of unique symbols: 'shift, 'meta, 'alt, 'cmd, 'option, and 'ctl"
p))
(raise-arguments-error (who->name who)
(string-append
"bad prefix;\n"
" given prefix is not a list of unique prefix symbols\n"
" allowed symbols: 'shift, 'meta, 'alt, 'cmd, 'option, and 'ctl")
"given prefix" p))
(let ([disallowed (case (system-type)
[(unix) '(cmd option)]
[(windows) '(cmd option meta)]
[(macosx) '(meta alt)])])
(for-each (lambda (i)
(when (memq i p)
(raise-mismatch-error (who->name who)
"prefix not supported for the current platform: "
i)))
(raise-arguments-error (who->name who)
"prefix not supported for the current platform"
"prefix" i)))
disallowed)
(when (eq? 'unix (system-type))
(when (and (memq 'meta p)
(memq 'alt p))
(raise-mismatch-error (who->name who)
"prefix contains both 'meta and 'alt: "
p)))))
(raise-arguments-error (who->name who)
"given prefix contains both 'meta and 'alt"
"given" p)))))
(define default-prefix
(case (system-type)
@ -414,13 +418,13 @@
(class* mred% (menu-item-container<%>)
(init parent [demand-callback void])
(unless (or (is-a? parent frame%) (eq? parent 'root))
(raise-type-error (constructor-name 'menu-bar) "frame% object or 'root" parent))
(raise-argument-error (constructor-name 'menu-bar) "(or/c (is-a?/c frame%) 'root)" parent))
(check-callback1 '(constructor menu-bar) demand-callback)
(if (eq? parent 'root)
(unless (current-eventspace-has-menu-root?)
(raise-mismatch-error (constructor-name 'menu-bar) "no menu bar allowed in the current eventspace for: " parent))
(raise-arguments-error (constructor-name 'menu-bar) "no 'root menu bar allowed in the current eventspace"))
(when (as-entry (lambda () (send (mred->wx parent) get-the-menu-bar)))
(raise-mismatch-error (constructor-name 'menu-bar) "the specified frame already has a menu bar: " parent)))
(raise-arguments-error (constructor-name 'menu-bar) "given frame already has a menu bar" "given" parent)))
(define callback demand-callback)
(define prnt
(if (eq? parent 'root)
@ -428,7 +432,8 @@
(as-entry
(lambda ()
(when root-menu-frame-used?
(raise-mismatch-error (constructor-name 'menu-bar) "already has a menu bar: " parent))
(raise-arguments-error (constructor-name 'menu-bar) "given parent already has a menu bar"
"given" parent))
(set! root-menu-frame-used? #t)))
root-menu-frame)
parent))
@ -455,8 +460,11 @@
(define (menu-parent-only who p)
(unless (is-a? p internal-menu<%>)
(raise-type-error (constructor-name who) "parent menu% or popup-menu% object" p)))
(raise-argument-error (constructor-name who) "(or/c (is-a?/c menu%) (is-a?/c popup-menu%))" p)))
(define (menu-or-bar-parent who p)
(unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%))
(raise-type-error (constructor-name who) "built-in menu-item-container<%> object" p)))
(unless (is-a? p menu-item-container<%>)
(raise-arguments-error (constructor-name who) "(is-a?/c menu-item-container<%>)" p))
(raise-arguments-error (who->name who) "invalid parent;\n given parent is not an instance of a built-in menu item container class"
"given parent" p)))

19
collects/mred/private/mrpanel.rkt
View File

@ -308,7 +308,7 @@
(let ([cwho '(constructor tab-panel)])
(unless (and (list? choices) (andmap label-string? choices))
(raise-type-error (who->name cwho) "list of strings (up to 200 characters)" choices))
(raise-argument-error (who->name cwho) "label-string?" choices))
(check-callback cwho callback)
(check-container-parent cwho parent)
(check-style cwho #f '(deleted no-border) style)
@ -367,8 +367,8 @@
[set
(entry-point (lambda (l)
(unless (and (list? l) (andmap label-string? l))
(raise-type-error (who->name '(method tab-panel% set))
"list of strings (up to 200 characters)" l))
(raise-argument-error (who->name '(method tab-panel% set))
"(listof label-string?)" l))
(set! save-choices (map string->immutable-string l))
(send (mred->wx this) set l)))]
[get-item-label (entry-point
@ -382,12 +382,13 @@
(check-non-negative-integer `(method tab-panel% ,method) n)
(let ([m (length save-choices)])
(unless (< n m)
(raise-mismatch-error (who->name `(method tab-panel% ,method))
(if (zero? m)
"panel has no tabs; given index: "
(format "panel has only ~a tabs, indexed 0 to ~a; given out-of-range index: "
m (sub1 m)))
n))))])))
(raise-range-error (who->name `(method tab-panel% ,method))
"panel" "tab "
n
this
0
(sub1 m)
#f))))])))
(define group-box-panel%
(class vertical-panel%

2
collects/mred/private/mrtextfield.rkt
View File

@ -29,7 +29,7 @@
(check-label-string/false cwho label)
(when choices?
(unless (and (list? choices) (andmap label-string? choices))
(raise-type-error (who->name cwho) "list of strings (up to 200 characters)" choices)))
(raise-argument-error (who->name cwho) "(listof label-string?)" choices)))
(check-container-parent cwho parent)
(check-callback cwho callback)
(check-string cwho init-value)

4
collects/mred/private/mrtop.rkt
View File

@ -323,11 +323,11 @@
(define (check-top-level-parent/false who p)
(unless (or (not p) (is-a? p frame%) (is-a? p dialog%))
(raise-type-error (who->name who) "frame% or dialog% object or #f" p)))
(raise-argument-error (who->name who) "(or/c (is-a?/c frame%) (is-a?/c dialog%) #f)" p)))
(define (check-frame-parent/false who p)
(unless (or (not p) (is-a? p frame%))
(raise-type-error (who->name who) "frame% object or #f" p)))
(raise-argument-error (who->name who) "(or/c (is-a?/c frame%) #f)" p)))
(define root-menu-frame
(and (current-eventspace-has-menu-root?)

8
collects/mred/private/mrwindow.rkt
View File

@ -148,7 +148,7 @@
#f)]
[on-drop-file (lambda (s)
(unless (path-string? s)
(raise-type-error (who->name '(method window<%> on-drop-file)) "pathname string" s)))]
(raise-argument-error (who->name '(method window<%> on-drop-file)) "path-string?" s)))]
[focus (entry-point (lambda () (send wx set-focus)))]
[has-focus? (entry-point (lambda () (send wx has-focus?)))]
@ -212,10 +212,10 @@
(when on?
(unless top?
(unless (memq wx (send (send wx area-parent) get-children))
(raise-mismatch-error
(raise-arguments-error
(who->name '(method window<%> show))
"cannot show a subwindow that is not active in its parent: "
this))))
"cannot show a subwindow that is not active in its parent"
"subwindow" this))))
(send wx show on?)))]
[is-shown? (entry-point (lambda () (send wx is-shown?)))]
[on-superwindow-show (lambda (visible?) (void))]

2
collects/mred/private/repl.rkt
View File

@ -184,7 +184,7 @@
(graphical-read-eval-print-loop esp (not esp))]
[(esp override-ports?)
(unless (or (not esp) (wx:eventspace? esp))
(raise-type-error 'graphical-read-eval-print-loop "eventspace or #f" esp))
(raise-argument-error 'graphical-read-eval-print-loop "(or/c eventspace? #f)" esp))
(-graphical-read-eval-print-loop esp override-ports?)]))
(define (textual-read-eval-print-loop)

20
collects/mred/private/snipfile.rkt
View File

@ -25,21 +25,19 @@
#:lock-while-reading? [lock-while-reading? #f])
;; Check arguments:
(unless (text . is-a? . text%)
(raise-type-error 'open-input-text-editor "text% object" text))
(raise-argument-error 'open-input-text-editor "(is-a?/c text%)" text))
(check-non-negative-integer 'open-input-text-editor start)
(unless (or (eq? end 'end)
(and (integer? end) (exact? end) (not (negative? end))))
(raise-type-error 'open-input-text-editor "non-negative exact integer or 'end" end))
(raise-argument-error 'open-input-text-editor "(or/c exact-nonnegative-integer? 'end)" end))
(let ([last (send text last-position)])
(when (start . > . last)
(raise-mismatch-error 'open-input-text-editor
(format "start index outside the range [0,~a]: " last)
start))
(raise-range-error 'open-input-text-editor "editor" "starting "
start text 0 last #f))
(unless (eq? end 'end)
(unless (<= start end last)
(raise-mismatch-error 'open-input-text-editor
(format "end index outside the range [~a,~a]: " start last)
end))))
(raise-range-error 'open-input-text-editor "editor" "ending "
end text start last 0))))
(let ([end (if (eq? end 'end) (send text last-position) end)]
[snip (send text find-snip start 'after-or-none)])
;; If the region is small enough, and if the editor contains
@ -123,10 +121,10 @@
[next-snip
(lambda (to-str)
(unless (= revision (grn))
(raise-mismatch-error
(raise-arguments-error
'text-input-port
"editor has changed since port was opened: "
text))
"editor has changed since port was opened"
"editor" text))
(set! snip (send-generic snip next-generic))
(update-str-to-snip to-str))]
[read-chars (lambda (to-str)

56
collects/mred/private/wxpanel.rkt
View File

@ -159,12 +159,12 @@
[add-child
(lambda (new-child)
(unless (eq? this (send new-child area-parent))
(raise-mismatch-error 'add-child
"not a child of this container: "
(wx->proxy new-child)))
(raise-arguments-error 'add-child
"subwindow is not a child of this container"
"subwindow" (wx->proxy new-child)))
(when (memq new-child children)
(raise-mismatch-error 'add-child "child already active: "
(wx->proxy new-child)))
(raise-arguments-error 'add-child "subwindow area is already active"
"subwindow" (wx->proxy new-child)))
(change-children
(lambda (l)
(append l (list new-child)))))]
@ -180,19 +180,19 @@
(unless (andmap (lambda (child)
(eq? this (send child area-parent)))
new-children)
(raise-mismatch-error 'change-children
(format
(raise-arguments-error 'change-children
(string-append
"not all members of the returned list are "
"children of the container ~e; list: ")
(wx->proxy this))
(map wx->proxy (remq hidden-child new-children))))
"children of the container")
"container" (wx->proxy this)
"list" (map wx->proxy (remq hidden-child new-children))))
(let loop ([l new-children])
(unless (null? l)
(if (memq (car l) (cdr l))
(raise-mismatch-error 'change-children
"child in the returned list twice: "
(wx->proxy (car l)))
(raise-arguments-error 'change-children
"child appears multiple times in the returned list"
"child" (wx->proxy (car l))
"list" (map wx->proxy (remq hidden-child new-children)))
(loop (cdr l)))))
;; show all new children, hide all deleted children.
(let ([added-children (list-diff new-children children)]
@ -202,10 +202,10 @@
child))
removed-children)])
(when non-window
(raise-mismatch-error 'change-children
(format "cannot delete non-window area in ~e: "
(wx->proxy this))
non-window)))
(raise-arguments-error 'change-children
"cannot delete non-window area"
"area" non-window
"container" (wx->proxy this))))
;; Newly-added children may have been removed when
;; disabled, or now added into a disabled panel:
@ -227,9 +227,9 @@
[delete-child
(lambda (child)
(unless (memq child children)
(raise-mismatch-error 'delete-child
"not a child of this container or child is not active: "
(wx->proxy child)))
(raise-arguments-error 'delete-child
"subwindow is not a child of this container or child is not active"
"subwindow" (wx->proxy child)))
(change-children (lambda (child-list)
(remq child child-list))))]
@ -372,9 +372,9 @@
(integer? (car x)) (not (negative? (car x))) (exact? (car x))
(integer? (cadr x)) (not (negative? (cadr x))) (exact? (cadr x))))
children-info))
(raise-type-error (who->name '(method area-container-window<%> place-children))
"list of (list of non-negative-integer non-negative-integer boolean boolean)"
children-info))
(raise-argument-error (who->name '(method area-container-window<%> place-children))
"(listof (list/c exact-nonnegative-integer? exact-nonnegative-integer? any/c any/c))"
children-info))
(check-non-negative-integer '(method area-container-window<%> place-children) width)
(check-non-negative-integer '(method area-container-window<%> place-children) height))]
[do-place-children
@ -403,9 +403,9 @@
[do-align (lambda (h v set-h set-v)
(unless (memq h '(left center right))
(raise-type-error 'set-alignment "horizontal alignment symbol: left, center, or right" h))
(raise-argument-error 'set-alignment "(or/c 'left 'center 'right)" h))
(unless (memq v '(top center bottom))
(raise-type-error 'set-alignment "vertical alignment symbol: top, center, or bottom" v))
(raise-argument-error 'set-alignment "(or/c 'top 'center 'bottom)" v))
(set-h h)
(set-v (case v [(top) 'left] [(center) 'center] [(bottom) 'right])))]
[alignment (lambda (h v)
@ -472,9 +472,9 @@
(= 4 (length x))
(andmap (lambda (x) (and (integer? x) (exact? x))) x)))
l))
(raise-mismatch-error 'container-redraw
"result from place-children is not a list of 4-integer lists with the correct length: "
l))
(raise-arguments-error 'container-redraw
"result from place-children is not a list of 4-integer lists with the correct length"
"result" l))
(panel-redraw children children-info (if hidden-child
(cons (list 0 0 width height)
(let ([dy (child-info-y-min (car children-info))])

4
collects/mred/private/wxtop.rkt
View File

@ -32,7 +32,7 @@
(define get-display-size
(lambda ([full-screen? #f] #:monitor [monitor 0])
(unless (exact-nonnegative-integer? monitor)
(raise-type-error 'get-display-size "exact non-negative integer" monitor))
(raise-argument-error 'get-display-size "exact-nonnegative-integer?" monitor))
(let/ec esc
(let ([xb (box 0)]
[yb (box 0)])
@ -43,7 +43,7 @@
(define get-display-left-top-inset
(lambda ([advisory? #f] #:monitor [monitor 0])
(unless (exact-nonnegative-integer? monitor)
(raise-type-error 'get-display-left-top-inset "exact non-negative integer" monitor))
(raise-argument-error 'get-display-left-top-inset "exact-nonnegative-integer?" monitor))
(let/ec esc
(let ([xb (box 0)]
[yb (box 0)])