222 lines
9.4 KiB
Racket
222 lines
9.4 KiB
Racket
(module check mzscheme
|
|
(require mzlib/class
|
|
(prefix wx: "kernel.rkt")
|
|
"wx.rkt"
|
|
"const.rkt")
|
|
(provide (protect (all-defined)))
|
|
|
|
(define (key-code-symbol? x)
|
|
(and (member x '(start cancel clear shift rshift control rcontrol
|
|
menu pause capital prior next end home left
|
|
up right down escape select print execute
|
|
snapshot insert help numpad0 numpad1 numpad2
|
|
numpad3 numpad4 numpad5 numpad6 numpad7
|
|
numpad8 numpad9 numpad-enter multiply add
|
|
separator subtract decimal divide f1 f2 f3
|
|
f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15
|
|
f16 f17 f18 f19 f20 f21 f22 f23 f24 numlock
|
|
scroll wheel-up wheel-down wheel-left
|
|
wheel-right release press))
|
|
#t))
|
|
|
|
(define (who->name who)
|
|
(cond
|
|
[(symbol? who) who]
|
|
[(eq? (car who) 'method) (string->symbol (format "~a in ~a" (caddr who) (cadr who)))]
|
|
[(eq? (car who) 'iconstructor) (iconstructor-name (cadr who))]
|
|
[else (constructor-name (cadr who))]))
|
|
|
|
(define (label-string? s)
|
|
(and (string? s)
|
|
(let ([l (string-length s)])
|
|
(and l
|
|
(<= 0 l 200)))))
|
|
|
|
(define (constructor-name who)
|
|
(string->symbol (format "initialization for ~a%" who)))
|
|
|
|
(define (iconstructor-name who)
|
|
(string->symbol (format "initialization for a class that implements ~a<%>" who)))
|
|
|
|
(define (check-orientation cwho l)
|
|
(check-style cwho '(vertical horizontal) '(vertical-label horizontal-label deleted) l))
|
|
|
|
(define (check-container-ready cwho p)
|
|
(when p
|
|
(let ([wx (mred->wx p)])
|
|
(unless wx
|
|
(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-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-argument-error (who->name who) "(or/c string? #f)" str)))
|
|
|
|
(define (check-path who str)
|
|
(unless (path-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-argument-error (who->name who) "(or/c path-string? #f)" str)))
|
|
|
|
(define (check-string who str)
|
|
(unless (string? str)
|
|
(raise-argument-error (who->name who) "string?" str)))
|
|
|
|
(define (check-label-string who str)
|
|
(unless (label-string? 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-argument-error (who->name who) "(or/c label-string? #f)" str)))
|
|
|
|
(define (check-char/false who c)
|
|
(unless (or (not c) (char? 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-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-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-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-slider-integer (check-bounded-integer (- GAUGE-MAX) GAUGE-MAX #f))
|
|
|
|
(define check-margin-integer (check-bounded-integer 0 1000 #f))
|
|
|
|
(define check-gauge-integer (check-bounded-integer 1 GAUGE-MAX #f))
|
|
(define check-gauge-range-integer (check-bounded-integer 0 GAUGE-MAX #f))
|
|
|
|
(define (check-wheel-step cwho wheel-step)
|
|
(when (and wheel-step
|
|
(not (and (integer? wheel-step)
|
|
(exact? wheel-step)
|
|
(<= 1 wheel-step 10000))))
|
|
(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-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-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))
|
|
|
|
(define (check-non-negative-integer/false who i)
|
|
(-check-non-negative-integer who i #t))
|
|
|
|
(define check-init-dimension (check-bounded-integer 0 WIN-SIZE-MAX #t))
|
|
(define check-dimension (check-bounded-integer 0 WIN-SIZE-MAX #f))
|
|
(define check-position (check-bounded-integer (- WIN-SIZE-MAX) WIN-SIZE-MAX #f))
|
|
(define check-init-position (check-bounded-integer (- WIN-SIZE-MAX) WIN-SIZE-MAX #t))
|
|
|
|
(define (check-label-string-or-bitmap who label)
|
|
(unless (or (label-string? label) (is-a? label wx:bitmap%))
|
|
(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%)
|
|
(and (list? label)
|
|
(= 3 (length label))
|
|
(is-a? (car label) wx:bitmap%)
|
|
(label-string? (cadr label))
|
|
(memq (caddr label) '(left right top bottom))))
|
|
(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-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-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-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-argument-error (who->name who) "(listof symbol?)" style))
|
|
(when reqd
|
|
(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-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-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-arguments-error (who->name who)
|
|
"duplicate style in given style list"
|
|
"duplicate" (car l)
|
|
"given" style))
|
|
(loop (cdr l))))))))
|