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

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

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

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

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

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

@ -61,8 +61,8 @@
(define (check-format who format) (define (check-format who format)
(unless (memq format '(guess standard text text-force-cr same copy)) (unless (memq format '(guess standard text text-force-cr same copy))
(raise-type-error (who->name who) (raise-argument-error (who->name who)
"'guess, 'standard, 'text, 'text-force-cr, 'same, or 'copy" "(or/c 'guess 'standard 'text 'text-force-cr 'same 'copy)"
format))) format)))
(define-syntax (augmentize stx) (define-syntax (augmentize stx)
@ -378,7 +378,7 @@
(entry-point (entry-point
(lambda (type) (lambda (type)
(unless (memq type '(text pasteboard)) (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% (make-object editor-snip%
(let ([e (make-object (cond (let ([e (make-object (cond
[(eq? type 'pasteboard) pasteboard%] [(eq? type 'pasteboard) pasteboard%]
@ -557,8 +557,8 @@
(lambda (p) (lambda (p)
(unless (and (procedure? p) (unless (and (procedure? p)
(procedure-arity-includes? p 1)) (procedure-arity-includes? p 1))
(raise-type-error who (raise-argument-error who
"procedure of arity 1" "(procedure-arity-includes/c 1)"
p)) p))
p)) p))

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

@ -37,7 +37,7 @@
(string? (car p)) (string? (car p))
(string? (cadr p)))) (string? (cadr p))))
filters)) 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)] (let* ([std? (memq 'common style)]
[style (if std? (remq 'common style) style)]) [style (if std? (remq 'common style) style)])
(if std? (if std?

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

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

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

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

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

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

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

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

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

@ -160,7 +160,7 @@
(define (find-graphical-system-path what) (define (find-graphical-system-path what)
(unless (memq what '(init-file x-display)) (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) (or (wx:find-graphical-system-path what)
(case what (case what
[(init-file) [(init-file)

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

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

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

@ -185,7 +185,8 @@
(char? c) (char? c)
(and (symbol? c) (and (symbol? c)
(wx:key-symbol-to-menu-key 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) (define (check-shortcut-prefix who p)
(unless (and (list? p) (unless (and (list? p)
@ -197,25 +198,28 @@
[(null? p) #t] [(null? p) #t]
[(memq (car p) (cdr p)) #f] [(memq (car p) (cdr p)) #f]
[else (loop (cdr p))]))) [else (loop (cdr p))])))
(raise-type-error (who->name who) (raise-arguments-error (who->name who)
"list of unique symbols: 'shift, 'meta, 'alt, 'cmd, 'option, and 'ctl" (string-append
p)) "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) (let ([disallowed (case (system-type)
[(unix) '(cmd option)] [(unix) '(cmd option)]
[(windows) '(cmd option meta)] [(windows) '(cmd option meta)]
[(macosx) '(meta alt)])]) [(macosx) '(meta alt)])])
(for-each (lambda (i) (for-each (lambda (i)
(when (memq i p) (when (memq i p)
(raise-mismatch-error (who->name who) (raise-arguments-error (who->name who)
"prefix not supported for the current platform: " "prefix not supported for the current platform"
i))) "prefix" i)))
disallowed) disallowed)
(when (eq? 'unix (system-type)) (when (eq? 'unix (system-type))
(when (and (memq 'meta p) (when (and (memq 'meta p)
(memq 'alt p)) (memq 'alt p))
(raise-mismatch-error (who->name who) (raise-arguments-error (who->name who)
"prefix contains both 'meta and 'alt: " "given prefix contains both 'meta and 'alt"
p))))) "given" p)))))
(define default-prefix (define default-prefix
(case (system-type) (case (system-type)
@ -414,13 +418,13 @@
(class* mred% (menu-item-container<%>) (class* mred% (menu-item-container<%>)
(init parent [demand-callback void]) (init parent [demand-callback void])
(unless (or (is-a? parent frame%) (eq? parent 'root)) (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) (check-callback1 '(constructor menu-bar) demand-callback)
(if (eq? parent 'root) (if (eq? parent 'root)
(unless (current-eventspace-has-menu-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))) (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 callback demand-callback)
(define prnt (define prnt
(if (eq? parent 'root) (if (eq? parent 'root)
@ -428,7 +432,8 @@
(as-entry (as-entry
(lambda () (lambda ()
(when root-menu-frame-used? (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))) (set! root-menu-frame-used? #t)))
root-menu-frame) root-menu-frame)
parent)) parent))
@ -455,8 +460,11 @@
(define (menu-parent-only who p) (define (menu-parent-only who p)
(unless (is-a? p internal-menu<%>) (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) (define (menu-or-bar-parent who p)
(unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%)) (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)]) (let ([cwho '(constructor tab-panel)])
(unless (and (list? choices) (andmap label-string? 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) "label-string?" choices))
(check-callback cwho callback) (check-callback cwho callback)
(check-container-parent cwho parent) (check-container-parent cwho parent)
(check-style cwho #f '(deleted no-border) style) (check-style cwho #f '(deleted no-border) style)
@ -367,8 +367,8 @@
[set [set
(entry-point (lambda (l) (entry-point (lambda (l)
(unless (and (list? l) (andmap label-string? l)) (unless (and (list? l) (andmap label-string? l))
(raise-type-error (who->name '(method tab-panel% set)) (raise-argument-error (who->name '(method tab-panel% set))
"list of strings (up to 200 characters)" l)) "(listof label-string?)" l))
(set! save-choices (map string->immutable-string l)) (set! save-choices (map string->immutable-string l))
(send (mred->wx this) set l)))] (send (mred->wx this) set l)))]
[get-item-label (entry-point [get-item-label (entry-point
@ -382,12 +382,13 @@
(check-non-negative-integer `(method tab-panel% ,method) n) (check-non-negative-integer `(method tab-panel% ,method) n)
(let ([m (length save-choices)]) (let ([m (length save-choices)])
(unless (< n m) (unless (< n m)
(raise-mismatch-error (who->name `(method tab-panel% ,method)) (raise-range-error (who->name `(method tab-panel% ,method))
(if (zero? m) "panel" "tab "
"panel has no tabs; given index: " n
(format "panel has only ~a tabs, indexed 0 to ~a; given out-of-range index: " this
m (sub1 m))) 0
n))))]))) (sub1 m)
#f))))])))
(define group-box-panel% (define group-box-panel%
(class vertical-panel% (class vertical-panel%

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

@ -29,7 +29,7 @@
(check-label-string/false cwho label) (check-label-string/false cwho label)
(when choices? (when choices?
(unless (and (list? choices) (andmap label-string? 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-container-parent cwho parent)
(check-callback cwho callback) (check-callback cwho callback)
(check-string cwho init-value) (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) (define (check-top-level-parent/false who p)
(unless (or (not p) (is-a? p frame%) (is-a? p dialog%)) (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) (define (check-frame-parent/false who p)
(unless (or (not p) (is-a? p frame%)) (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 (define root-menu-frame
(and (current-eventspace-has-menu-root?) (and (current-eventspace-has-menu-root?)

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

@ -148,7 +148,7 @@
#f)] #f)]
[on-drop-file (lambda (s) [on-drop-file (lambda (s)
(unless (path-string? 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)))] [focus (entry-point (lambda () (send wx set-focus)))]
[has-focus? (entry-point (lambda () (send wx has-focus?)))] [has-focus? (entry-point (lambda () (send wx has-focus?)))]
@ -212,10 +212,10 @@
(when on? (when on?
(unless top? (unless top?
(unless (memq wx (send (send wx area-parent) get-children)) (unless (memq wx (send (send wx area-parent) get-children))
(raise-mismatch-error (raise-arguments-error
(who->name '(method window<%> show)) (who->name '(method window<%> show))
"cannot show a subwindow that is not active in its parent: " "cannot show a subwindow that is not active in its parent"
this)))) "subwindow" this))))
(send wx show on?)))] (send wx show on?)))]
[is-shown? (entry-point (lambda () (send wx is-shown?)))] [is-shown? (entry-point (lambda () (send wx is-shown?)))]
[on-superwindow-show (lambda (visible?) (void))] [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))] (graphical-read-eval-print-loop esp (not esp))]
[(esp override-ports?) [(esp override-ports?)
(unless (or (not esp) (wx:eventspace? esp)) (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?)])) (-graphical-read-eval-print-loop esp override-ports?)]))
(define (textual-read-eval-print-loop) (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]) #:lock-while-reading? [lock-while-reading? #f])
;; Check arguments: ;; Check arguments:
(unless (text . is-a? . text%) (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) (check-non-negative-integer 'open-input-text-editor start)
(unless (or (eq? end 'end) (unless (or (eq? end 'end)
(and (integer? end) (exact? end) (not (negative? 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)]) (let ([last (send text last-position)])
(when (start . > . last) (when (start . > . last)
(raise-mismatch-error 'open-input-text-editor (raise-range-error 'open-input-text-editor "editor" "starting "
(format "start index outside the range [0,~a]: " last) start text 0 last #f))
start))
(unless (eq? end 'end) (unless (eq? end 'end)
(unless (<= start end last) (unless (<= start end last)
(raise-mismatch-error 'open-input-text-editor (raise-range-error 'open-input-text-editor "editor" "ending "
(format "end index outside the range [~a,~a]: " start last) end text start last 0))))
end))))
(let ([end (if (eq? end 'end) (send text last-position) end)] (let ([end (if (eq? end 'end) (send text last-position) end)]
[snip (send text find-snip start 'after-or-none)]) [snip (send text find-snip start 'after-or-none)])
;; If the region is small enough, and if the editor contains ;; If the region is small enough, and if the editor contains
@ -123,10 +121,10 @@
[next-snip [next-snip
(lambda (to-str) (lambda (to-str)
(unless (= revision (grn)) (unless (= revision (grn))
(raise-mismatch-error (raise-arguments-error
'text-input-port 'text-input-port
"editor has changed since port was opened: " "editor has changed since port was opened"
text)) "editor" text))
(set! snip (send-generic snip next-generic)) (set! snip (send-generic snip next-generic))
(update-str-to-snip to-str))] (update-str-to-snip to-str))]
[read-chars (lambda (to-str) [read-chars (lambda (to-str)

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

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