racket/gui: fixed by-position widget initialization
This was broken in the class100 port. The init arguments previously handled by the class100*/kw macro need to be explicitly passed down. Also, an (init-rest) is needed at the leaves of the class hierarchy to ensure that internal super init args don't leak via error messages. (the class100 macro always inserts these) Added a test file so similar breakage is detectable in the future.
This commit is contained in:
Asumu Takikawa
parent
2c19677358
commit
0e4f9fcd97
|
|
@ -1061,6 +1061,7 @@ path/s is either such a string or a list of them.
|
|||
"collects/tests/gracket/testing.rktl" drdr:command-line (racket "-f" *)
|
||||
"collects/tests/gracket/text-scale.rktl" drdr:command-line #f
|
||||
"collects/tests/gracket/unflushed-circle.rkt" drdr:command-line #f
|
||||
"collects/tests/gracket/widget-init.rktl" drdr:command-line (racket "-f" *)
|
||||
"collects/tests/gracket/windowing.rktl" drdr:command-line (gracket "-f" *)
|
||||
"collects/tests/gracket/wxme-doc-random.rkt" drdr:command-line (mzc *)
|
||||
"collects/tests/gracket/wxme-random.rkt" drdr:command-line #f
|
||||
|
|
|
|||
|
|
@ -95,7 +95,16 @@
|
|||
|
||||
(define canvas%
|
||||
(class basic-canvas%
|
||||
(init parent [style null] [paint-callback default-paint-cb] [label #f] [gl-config #f])
|
||||
(init parent [style null] [paint-callback default-paint-cb] [label #f] [gl-config #f]
|
||||
;; inherited inits
|
||||
[enabled #t]
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(define paint-cb paint-callback)
|
||||
(define has-x? (and (list? style) (memq 'hscroll style)))
|
||||
(define has-y? (and (list? style) (memq 'vscroll style)))
|
||||
|
|
@ -231,26 +240,35 @@
|
|||
(resume-flush)))
|
||||
(when flush? (flush))))
|
||||
(define wx #f)
|
||||
(super-make-object
|
||||
(lambda ()
|
||||
(let ([ds (+ (cond
|
||||
[(memq 'control-border style) (+ 4 canvas-control-border-extra)]
|
||||
[(memq 'border style) 4]
|
||||
[else 0])
|
||||
(if (or has-x? has-y?)
|
||||
canvas-default-size
|
||||
1))])
|
||||
(set! wx (make-object wx-canvas% this this
|
||||
(mred->wx-container parent)
|
||||
-1 -1
|
||||
(+ ds (if (memq 'combo style) side-combo-width 0)) ds
|
||||
style
|
||||
gl-config)))
|
||||
wx)
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor canvas)])
|
||||
(check-container-ready cwho parent)))
|
||||
parent)
|
||||
(super-new
|
||||
[mk-wx
|
||||
(lambda ()
|
||||
(let ([ds (+ (cond
|
||||
[(memq 'control-border style) (+ 4 canvas-control-border-extra)]
|
||||
[(memq 'border style) 4]
|
||||
[else 0])
|
||||
(if (or has-x? has-y?)
|
||||
canvas-default-size
|
||||
1))])
|
||||
(set! wx (make-object wx-canvas% this this
|
||||
(mred->wx-container parent)
|
||||
-1 -1
|
||||
(+ ds (if (memq 'combo style) side-combo-width 0)) ds
|
||||
style
|
||||
gl-config)))
|
||||
wx)]
|
||||
[mismatches
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor canvas)])
|
||||
(check-container-ready cwho parent)))]
|
||||
[parent parent]
|
||||
[enabled enabled]
|
||||
[horiz-margin horiz-margin]
|
||||
[vert-margin vert-margin]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])
|
||||
(when label
|
||||
(set-label label))
|
||||
(send parent after-new-child this)))
|
||||
|
|
@ -259,7 +277,16 @@
|
|||
(class basic-canvas%
|
||||
(init parent [editor #f] [style null] [scrolls-per-page 100] [label #f]
|
||||
[wheel-step no-val] [line-count no-val]
|
||||
[horizontal-inset 5] [vertical-inset 5])
|
||||
[horizontal-inset 5] [vertical-inset 5]
|
||||
;; inherited inits
|
||||
[enabled #t]
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(let ([cwho '(constructor editor-canvas)])
|
||||
(check-container-parent cwho parent)
|
||||
(check-instance cwho internal-editor<%> "text% or pasteboard%" #t editor)
|
||||
|
|
@ -372,36 +399,45 @@
|
|||
(as-exit (lambda () (send wx set-x-margin m)))])))
|
||||
(public [hi horizontal-inset])
|
||||
(define wx #f)
|
||||
(super-make-object
|
||||
(lambda ()
|
||||
(let* ([no-h? (or (memq 'no-vscroll style)
|
||||
(memq 'hide-vscroll style))]
|
||||
[no-v? (or (memq 'no-hscroll style)
|
||||
(memq 'hide-hscroll style))]
|
||||
[get-ds (lambda (no-this? no-other?)
|
||||
(+ (if (memq 'control-border style)
|
||||
canvas-control-border-extra
|
||||
0)
|
||||
(cond
|
||||
[(and no-this? no-other?) 14]
|
||||
[no-this? canvas-default-size]
|
||||
[else (+ canvas-scroll-size canvas-default-size)])))])
|
||||
(set! wx (make-object wx-editor-canvas% this this
|
||||
(mred->wx-container parent) -1 -1
|
||||
(+ (get-ds no-h? no-v?) (if (memq 'combo style) side-combo-width 0))
|
||||
(get-ds no-v? no-h?)
|
||||
#f
|
||||
(append
|
||||
(if (memq 'no-border style)
|
||||
null
|
||||
'(border))
|
||||
(remq 'no-border style))
|
||||
scrolls-per-page #f))
|
||||
wx))
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor editor-canvas)])
|
||||
(check-container-ready cwho parent)))
|
||||
parent)
|
||||
(super-new
|
||||
[mk-wx
|
||||
(lambda ()
|
||||
(let* ([no-h? (or (memq 'no-vscroll style)
|
||||
(memq 'hide-vscroll style))]
|
||||
[no-v? (or (memq 'no-hscroll style)
|
||||
(memq 'hide-hscroll style))]
|
||||
[get-ds (lambda (no-this? no-other?)
|
||||
(+ (if (memq 'control-border style)
|
||||
canvas-control-border-extra
|
||||
0)
|
||||
(cond
|
||||
[(and no-this? no-other?) 14]
|
||||
[no-this? canvas-default-size]
|
||||
[else (+ canvas-scroll-size canvas-default-size)])))])
|
||||
(set! wx (make-object wx-editor-canvas% this this
|
||||
(mred->wx-container parent) -1 -1
|
||||
(+ (get-ds no-h? no-v?) (if (memq 'combo style) side-combo-width 0))
|
||||
(get-ds no-v? no-h?)
|
||||
#f
|
||||
(append
|
||||
(if (memq 'no-border style)
|
||||
null
|
||||
'(border))
|
||||
(remq 'no-border style))
|
||||
scrolls-per-page #f))
|
||||
wx))]
|
||||
[mismatches
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor editor-canvas)])
|
||||
(check-container-ready cwho parent)))]
|
||||
[parent parent]
|
||||
[enabled enabled]
|
||||
[horiz-margin horiz-margin]
|
||||
[vert-margin vert-margin]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])
|
||||
(unless (eq? wheel-step no-val)
|
||||
(ws wheel-step))
|
||||
(when label
|
||||
|
|
|
|||
|
|
@ -109,13 +109,14 @@
|
|||
;; normally can't happen.
|
||||
[font no-val]
|
||||
[enabled #t]
|
||||
[horiz-margin no-val]
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val]
|
||||
[auto-resize #f])
|
||||
(init-rest)
|
||||
(rename-super [super-min-width min-width]
|
||||
[super-min-height min-height]
|
||||
[super-get-label get-label])
|
||||
|
|
@ -228,7 +229,14 @@
|
|||
(class* basic-control% ()
|
||||
(init label parent [callback (lambda (b e) (void))] [style null]
|
||||
;; This is a vestige of the old class100 keyword macro
|
||||
[font no-val])
|
||||
[font no-val]
|
||||
[enabled #t]
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(override*
|
||||
[label-checker (lambda () check-label-string-or-bitmap)]) ; module-local method
|
||||
(let ([cwho '(constructor button)])
|
||||
|
|
@ -239,21 +247,41 @@
|
|||
(check-font cwho font))
|
||||
(as-entry
|
||||
(lambda ()
|
||||
(super-instantiate
|
||||
((lambda () (make-object wx-button% this this
|
||||
(super-new
|
||||
[mk-wx
|
||||
(lambda () (make-object wx-button% this this
|
||||
(mred->wx-container parent) (wrap-callback callback)
|
||||
label -1 -1 -1 -1 style (no-val->#f font)))
|
||||
label -1 -1 -1 -1 style (no-val->#f font)))]
|
||||
[mismatches
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor button)])
|
||||
(check-container-ready cwho parent)))
|
||||
label parent callback #f)
|
||||
[font font])))))
|
||||
(check-container-ready cwho parent)))]
|
||||
[cursor #f]
|
||||
[lbl label]
|
||||
[parent parent]
|
||||
[cb callback]
|
||||
[font font]
|
||||
[enabled enabled]
|
||||
[horiz-margin horiz-margin]
|
||||
[vert-margin vert-margin]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])))))
|
||||
|
||||
(define check-box%
|
||||
(class basic-control%
|
||||
(init label parent [callback (lambda (b e) (void))] [style null] [value #f]
|
||||
;; This is a vestige of the old class100 keyword macro
|
||||
[font no-val])
|
||||
[font no-val]
|
||||
[enabled #t]
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(let ([cwho '(constructor check-box)])
|
||||
(check-label-string-or-bitmap cwho label)
|
||||
(check-container-parent cwho parent)
|
||||
|
|
@ -268,24 +296,44 @@
|
|||
[set-value (entry-point (lambda (v) (send wx set-value v)))])
|
||||
(as-entry
|
||||
(lambda ()
|
||||
(super-instantiate
|
||||
((lambda ()
|
||||
(super-new
|
||||
[mk-wx
|
||||
(lambda ()
|
||||
(set! wx (make-object wx-check-box% this this
|
||||
(mred->wx-container parent) (wrap-callback callback)
|
||||
label -1 -1 -1 -1 style (no-val->#f font)))
|
||||
wx)
|
||||
wx)]
|
||||
[mismatches
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor check-box)])
|
||||
(check-container-ready cwho parent)))
|
||||
label parent callback #f)
|
||||
[font font])))
|
||||
(check-container-ready cwho parent)))]
|
||||
[lbl label]
|
||||
[parent parent]
|
||||
[cb callback]
|
||||
[cursor #f]
|
||||
[font font]
|
||||
[enabled enabled]
|
||||
[horiz-margin horiz-margin]
|
||||
[vert-margin vert-margin]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])))
|
||||
(when value (set-value #t))))
|
||||
|
||||
(define radio-box%
|
||||
(class basic-control%
|
||||
(init label choices parent [callback (lambda (b e) (void))] [style '(vertical)] [selection 0]
|
||||
;; This is a vestige of the old class100 keyword macro
|
||||
[font no-val])
|
||||
[font no-val]
|
||||
[enabled #t]
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(define chcs choices)
|
||||
(let ([cwho '(constructor radio-box)])
|
||||
(check-label-string/false cwho label)
|
||||
|
|
@ -356,7 +404,14 @@
|
|||
(length choices))
|
||||
selection)))))
|
||||
label parent callback #f)
|
||||
[font font])))
|
||||
[font font]
|
||||
[enabled enabled]
|
||||
[horiz-margin horiz-margin]
|
||||
[vert-margin vert-margin]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])))
|
||||
(when (or (not selection) (positive? selection))
|
||||
(set-selection selection))))
|
||||
|
||||
|
|
@ -364,7 +419,15 @@
|
|||
(class basic-control%
|
||||
(init label min-value max-value parent [callback (lambda (b e) (void))] [init-value min-value] [style '(horizontal)]
|
||||
;; This is a vestige of the old class100 keyword macro
|
||||
[font no-val])
|
||||
[font no-val]
|
||||
[enabled #t]
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(define minv min-value)
|
||||
(define maxv max-value)
|
||||
(let ([cwho '(constructor slider)])
|
||||
|
|
@ -400,23 +463,43 @@
|
|||
(send wx set-value v)))])
|
||||
(as-entry
|
||||
(lambda ()
|
||||
(super-instantiate
|
||||
((lambda ()
|
||||
(super-new
|
||||
[mk-wx
|
||||
(lambda ()
|
||||
(set! wx (make-object wx-slider% this this
|
||||
(mred->wx-container parent) (wrap-callback callback)
|
||||
label init-value minv maxv style (no-val->#f font)))
|
||||
wx)
|
||||
wx)]
|
||||
[mismatches
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor slider)])
|
||||
(check-container-ready cwho parent)))
|
||||
label parent callback #f)
|
||||
[font font])))))
|
||||
(check-container-ready cwho parent)))]
|
||||
[lbl label]
|
||||
[parent parent]
|
||||
[cb callback]
|
||||
[cursor #f]
|
||||
[font font]
|
||||
[enabled enabled]
|
||||
[horiz-margin horiz-margin]
|
||||
[vert-margin vert-margin]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])))))
|
||||
|
||||
(define gauge%
|
||||
(class basic-control%
|
||||
(init label range parent [style '(horizontal)]
|
||||
;; This is a vestige of the old class100 keyword macro
|
||||
[font no-val])
|
||||
[font no-val]
|
||||
[enabled #t]
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(let ([cwho '(constructor gauge)])
|
||||
(check-label-string/false cwho label)
|
||||
(check-container-parent cwho parent)
|
||||
|
|
@ -441,17 +524,29 @@
|
|||
(send wx set-range v)))])
|
||||
(as-entry
|
||||
(lambda ()
|
||||
(super-instantiate
|
||||
((lambda ()
|
||||
(super-new
|
||||
[mk-wx
|
||||
(lambda ()
|
||||
(set! wx (make-object wx-gauge% this this
|
||||
(mred->wx-container parent)
|
||||
label range style (no-val->#f font)))
|
||||
wx)
|
||||
wx)]
|
||||
[mismatches
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor gauge)])
|
||||
(check-container-ready cwho parent)))
|
||||
label parent void #f)
|
||||
[font font])))))
|
||||
(check-container-ready cwho parent)))]
|
||||
[lbl label]
|
||||
[parent parent]
|
||||
[cb void]
|
||||
[cursor #f]
|
||||
[font font]
|
||||
[enabled enabled]
|
||||
[horiz-margin horiz-margin]
|
||||
[vert-margin vert-margin]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])))))
|
||||
|
||||
;; List controls ----------------------------------------
|
||||
|
||||
|
|
@ -564,32 +659,60 @@
|
|||
(class basic-list-control%
|
||||
(init label choices parent [callback (lambda (b e) (void))] [style null] [selection 0]
|
||||
;; This is a vestige of the old class100 keyword macro
|
||||
[font no-val])
|
||||
[font no-val]
|
||||
[enabled #t]
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(let ([cwho '(constructor choice)])
|
||||
(check-list-control-args cwho label choices parent callback)
|
||||
(check-style cwho #f '(vertical-label horizontal-label deleted) style)
|
||||
(check-non-negative-integer cwho selection)
|
||||
(check-font cwho font))
|
||||
(super-instantiate
|
||||
((lambda () (make-object wx-choice% this this
|
||||
(mred->wx-container parent) (wrap-callback callback)
|
||||
label -1 -1 -1 -1 choices style (no-val->#f font)))
|
||||
(super-new
|
||||
[mk-wx
|
||||
(lambda () (make-object wx-choice% this this
|
||||
(mred->wx-container parent) (wrap-callback callback)
|
||||
label -1 -1 -1 -1 choices style (no-val->#f font)))]
|
||||
[mismatches
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor choice)])
|
||||
(check-container-ready cwho parent)
|
||||
(unless (= 0 selection)
|
||||
(check-list-control-selection cwho choices selection))))
|
||||
label parent
|
||||
(and (positive? selection) selection)
|
||||
callback
|
||||
choices)
|
||||
[font font])))
|
||||
(let ([cwho '(constructor choice)])
|
||||
(check-container-ready cwho parent)
|
||||
(unless (= 0 selection)
|
||||
(check-list-control-selection cwho choices selection))))]
|
||||
[label label]
|
||||
[parent parent]
|
||||
[selection (and (positive? selection) selection)]
|
||||
[callback callback]
|
||||
[init-choices choices]
|
||||
[font font]
|
||||
[enabled enabled]
|
||||
[horiz-margin horiz-margin]
|
||||
[vert-margin vert-margin]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])))
|
||||
|
||||
(define list-box%
|
||||
(class basic-list-control%
|
||||
(init label choices parent [callback (lambda (b e) (void))] [style '(single)]
|
||||
[selection #f] [font no-val] [label-font no-val]
|
||||
;; inherited inits
|
||||
[enabled #t]
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val]
|
||||
;; post inits
|
||||
[columns (list "Column")] [column-order #f])
|
||||
(init-rest)
|
||||
(let ([cwho '(constructor list-box)])
|
||||
(check-list-control-args cwho label choices parent callback)
|
||||
(check-style cwho '(single multiple extended)
|
||||
|
|
@ -785,25 +908,38 @@
|
|||
(format "list has only ~a items, indexed 0 to ~a; given out-of-range index: "
|
||||
m (sub1 m)))
|
||||
n)))))])
|
||||
(super-make-object
|
||||
(lambda ()
|
||||
(let-values ([(kind style)
|
||||
(cond
|
||||
[(memq 'single style) (values 'single (remq 'single style))]
|
||||
[(memq 'multiple style) (values 'multiple (remq 'multiple style))]
|
||||
[else (values 'extended (remq 'extended style))])])
|
||||
(set! wx (make-object wx-list-box% this this
|
||||
(mred->wx-container parent) (wrap-callback callback)
|
||||
label kind
|
||||
-1 -1 -1 -1 choices style
|
||||
(no-val->#f font) (no-val->#f label-font)
|
||||
column-labels
|
||||
column-order)))
|
||||
wx)
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor list-box)])
|
||||
(check-container-ready cwho parent)
|
||||
(when selection
|
||||
(check-list-control-selection cwho choices selection))))
|
||||
label parent (and (pair? choices) selection) callback
|
||||
choices)))
|
||||
(super-new
|
||||
[mk-wx
|
||||
(lambda ()
|
||||
(let-values ([(kind style)
|
||||
(cond
|
||||
[(memq 'single style) (values 'single (remq 'single style))]
|
||||
[(memq 'multiple style) (values 'multiple (remq 'multiple style))]
|
||||
[else (values 'extended (remq 'extended style))])])
|
||||
(set! wx (make-object wx-list-box% this this
|
||||
(mred->wx-container parent) (wrap-callback callback)
|
||||
label kind
|
||||
-1 -1 -1 -1 choices style
|
||||
(no-val->#f font) (no-val->#f label-font)
|
||||
column-labels
|
||||
column-order)))
|
||||
wx)]
|
||||
[mismatches
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor list-box)])
|
||||
(check-container-ready cwho parent)
|
||||
(when selection
|
||||
(check-list-control-selection cwho choices selection))))]
|
||||
[label label]
|
||||
[parent parent]
|
||||
[selection (and (pair? choices) selection)]
|
||||
[callback callback]
|
||||
[init-choices choices]
|
||||
[font font]
|
||||
[enabled enabled]
|
||||
[horiz-margin horiz-margin]
|
||||
[vert-margin vert-margin]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])))
|
||||
|
|
|
|||
|
|
@ -25,7 +25,17 @@
|
|||
|
||||
(define pane%
|
||||
(class (make-subarea% (make-container% area%))
|
||||
(init parent)
|
||||
(init parent
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[border no-val]
|
||||
[spacing no-val]
|
||||
[alignment no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(define wx #f)
|
||||
(let* ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p
|
||||
[(is-a? this vertical-pane%) 'vertical-pane]
|
||||
|
|
@ -36,27 +46,106 @@
|
|||
(check-container-parent cwho parent)
|
||||
(as-entry
|
||||
(lambda ()
|
||||
(super-make-object
|
||||
(lambda ()
|
||||
(set! wx (make-object (case who
|
||||
[(vertical-pane) wx-vertical-pane%]
|
||||
[(horizontal-pane) wx-horizontal-pane%]
|
||||
[(grow-box-spacer-pane) wx-grow-box-pane%]
|
||||
[else wx-pane%])
|
||||
this this (mred->wx-container parent) null
|
||||
#f))
|
||||
wx)
|
||||
(lambda () wx)
|
||||
(lambda () wx)
|
||||
(lambda ()
|
||||
(check-container-ready cwho parent))
|
||||
parent)
|
||||
(super-new
|
||||
[mk-wx
|
||||
(lambda ()
|
||||
(set! wx (make-object (case who
|
||||
[(vertical-pane) wx-vertical-pane%]
|
||||
[(horizontal-pane) wx-horizontal-pane%]
|
||||
[(grow-box-spacer-pane) wx-grow-box-pane%]
|
||||
[else wx-pane%])
|
||||
this this (mred->wx-container parent) null
|
||||
#f))
|
||||
wx)]
|
||||
[get-wx-pan (lambda () wx)]
|
||||
[get-outer-wx-pan (lambda () wx)]
|
||||
[mismatches
|
||||
(lambda ()
|
||||
(check-container-ready cwho parent))]
|
||||
[parent parent]
|
||||
[vert-margin vert-margin]
|
||||
[horiz-margin horiz-margin]
|
||||
[border border]
|
||||
[spacing spacing]
|
||||
[alignment alignment]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])
|
||||
(send (send wx area-parent) add-child wx)))
|
||||
(send parent after-new-child this))))
|
||||
|
||||
(define vertical-pane% (class pane% (init parent) (super-make-object parent)))
|
||||
(define horizontal-pane% (class pane% (init parent) (super-make-object parent)))
|
||||
(define grow-box-spacer-pane% (class pane% (init parent) (super-make-object parent)))
|
||||
(define vertical-pane%
|
||||
(class pane%
|
||||
(init parent
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[border no-val]
|
||||
[spacing no-val]
|
||||
[alignment no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(super-new [parent parent]
|
||||
[vert-margin vert-margin]
|
||||
[horiz-margin horiz-margin]
|
||||
[border border]
|
||||
[spacing spacing]
|
||||
[alignment alignment]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])))
|
||||
|
||||
(define horizontal-pane%
|
||||
(class pane%
|
||||
(init parent
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[border no-val]
|
||||
[spacing no-val]
|
||||
[alignment no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(super-new [parent parent]
|
||||
[vert-margin vert-margin]
|
||||
[horiz-margin horiz-margin]
|
||||
[border border]
|
||||
[spacing spacing]
|
||||
[alignment alignment]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])))
|
||||
|
||||
(define grow-box-spacer-pane%
|
||||
(class pane%
|
||||
(init parent
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[border no-val]
|
||||
[spacing no-val]
|
||||
[alignment no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(super-new [parent parent]
|
||||
[vert-margin vert-margin]
|
||||
[horiz-margin horiz-margin]
|
||||
[border border]
|
||||
[spacing spacing]
|
||||
[alignment alignment]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])))
|
||||
|
||||
(define panel%
|
||||
(class* (make-subwindow%
|
||||
|
|
@ -77,8 +166,8 @@
|
|||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val]
|
||||
)
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(define wx #f)
|
||||
(public* [get-initial-label (lambda () #f)])
|
||||
(let* ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p
|
||||
|
|
@ -135,8 +224,7 @@
|
|||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height]
|
||||
)
|
||||
[stretchable-height stretchable-height])
|
||||
(unless (memq 'deleted style)
|
||||
(send (send wx area-parent) add-child wx))))
|
||||
(send parent after-new-child this))))
|
||||
|
|
@ -154,17 +242,19 @@
|
|||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(super-instantiate (parent style)
|
||||
[enabled enabled]
|
||||
[vert-margin vert-margin]
|
||||
[horiz-margin horiz-margin]
|
||||
[border border]
|
||||
[spacing spacing]
|
||||
[alignment alignment]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])
|
||||
(init-rest)
|
||||
(super-new [parent parent]
|
||||
[style style]
|
||||
[enabled enabled]
|
||||
[vert-margin vert-margin]
|
||||
[horiz-margin horiz-margin]
|
||||
[border border]
|
||||
[spacing spacing]
|
||||
[alignment alignment]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])
|
||||
(public* [set-orientation (λ (x) (send (mred->wx this) set-orientation x))]
|
||||
[get-orientation (λ () (send (mred->wx this) get-orientation))])))
|
||||
(define horizontal-panel%
|
||||
|
|
@ -180,17 +270,19 @@
|
|||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(super-instantiate (parent style)
|
||||
[enabled enabled]
|
||||
[vert-margin vert-margin]
|
||||
[horiz-margin horiz-margin]
|
||||
[border border]
|
||||
[spacing spacing]
|
||||
[alignment alignment]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])
|
||||
(init-rest)
|
||||
(super-new [parent parent]
|
||||
[style style]
|
||||
[enabled enabled]
|
||||
[vert-margin vert-margin]
|
||||
[horiz-margin horiz-margin]
|
||||
[border border]
|
||||
[spacing spacing]
|
||||
[alignment alignment]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])
|
||||
(public* [set-orientation (λ (x) (send (mred->wx this) set-orientation x))]
|
||||
[get-orientation (λ () (send (mred->wx this) get-orientation))])))
|
||||
|
||||
|
|
@ -198,7 +290,19 @@
|
|||
|
||||
(define tab-panel%
|
||||
(class vertical-panel%
|
||||
(init choices parent [callback (lambda (b e) (void))] [style null] [font no-val])
|
||||
(init choices parent [callback (lambda (b e) (void))] [style null] [font no-val]
|
||||
;; inherited inits
|
||||
[enabled #t]
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[border no-val]
|
||||
[spacing no-val]
|
||||
[alignment no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(define save-choices choices)
|
||||
(override* [get-initial-label (lambda () save-choices)])
|
||||
|
||||
|
|
@ -209,11 +313,23 @@
|
|||
(check-container-parent cwho parent)
|
||||
(check-style cwho #f '(deleted no-border) style)
|
||||
(check-font cwho font))
|
||||
(super-make-object parent (if (memq 'no-border style)
|
||||
(if (eq? (car style) 'no-border)
|
||||
(cdr style)
|
||||
(list (car style)))
|
||||
(cons 'border style)))
|
||||
(super-new [parent parent]
|
||||
[style
|
||||
(if (memq 'no-border style)
|
||||
(if (eq? (car style) 'no-border)
|
||||
(cdr style)
|
||||
(list (car style)))
|
||||
(cons 'border style))]
|
||||
[enabled enabled]
|
||||
[vert-margin vert-margin]
|
||||
[horiz-margin horiz-margin]
|
||||
[border border]
|
||||
[spacing spacing]
|
||||
[alignment alignment]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])
|
||||
(send (mred->wx this) set-callback (lambda (wx e) (callback (wx->mred wx) e)))
|
||||
|
||||
(public*
|
||||
|
|
@ -281,8 +397,16 @@
|
|||
;; used below, we have to supply it here (even though it's
|
||||
;; handled by the subarea init args)
|
||||
[enabled #t]
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[vert-margin no-val])
|
||||
[border no-val]
|
||||
[spacing no-val]
|
||||
[alignment no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(define lbl label)
|
||||
(override* [get-initial-label (lambda () lbl)])
|
||||
|
||||
|
|
@ -304,7 +428,14 @@
|
|||
null))
|
||||
[enabled enabled]
|
||||
[horiz-margin horiz-margin]
|
||||
[vert-margin vert-margin])
|
||||
[vert-margin vert-margin]
|
||||
[border border]
|
||||
[spacing spacing]
|
||||
[alignment alignment]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])
|
||||
|
||||
(override*
|
||||
[set-label (entry-point
|
||||
|
|
|
|||
|
|
@ -50,7 +50,12 @@
|
|||
[font no-val]
|
||||
[enabled #t]
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val])
|
||||
[horiz-margin no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(check-text-field-args '(constructor text-field)
|
||||
label
|
||||
#f #f
|
||||
|
|
@ -76,30 +81,47 @@
|
|||
(when (eq? vert-margin no-val) (set! vert-margin 2))
|
||||
(as-entry
|
||||
(lambda ()
|
||||
(super-instantiate
|
||||
((lambda ()
|
||||
(set! wx (make-object wx-text-field% this this
|
||||
(mred->wx-container parent) (wrap-callback callback)
|
||||
label init-value
|
||||
(if (memq combo-flag style)
|
||||
(cons 'combo (remq combo-flag style))
|
||||
style)
|
||||
(no-val->#f font)))
|
||||
wx)
|
||||
(super-new
|
||||
[mk-wx
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor text-field)])
|
||||
(check-container-ready cwho parent)))
|
||||
label parent callback ibeam)
|
||||
(set! wx (make-object wx-text-field% this this
|
||||
(mred->wx-container parent) (wrap-callback callback)
|
||||
label init-value
|
||||
(if (memq combo-flag style)
|
||||
(cons 'combo (remq combo-flag style))
|
||||
style)
|
||||
(no-val->#f font)))
|
||||
wx)]
|
||||
[mismatches
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor text-field)])
|
||||
(check-container-ready cwho parent)))]
|
||||
[lbl label]
|
||||
[parent parent]
|
||||
[cb callback]
|
||||
[cursor ibeam]
|
||||
[font font]
|
||||
[enabled enabled]
|
||||
[vert-margin vert-margin]
|
||||
[horiz-margin horiz-margin])))))
|
||||
[horiz-margin horiz-margin]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])))))
|
||||
|
||||
(define combo-field%
|
||||
(class text-field%
|
||||
(init label choices parent [callback (lambda (b e) (void))] [init-value ""] [style '()]
|
||||
;; this is handled by a superclass, but we put it here due to the check below
|
||||
[font no-val])
|
||||
[font no-val]
|
||||
[enabled #t]
|
||||
[vert-margin no-val]
|
||||
[horiz-margin no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(init-rest)
|
||||
(inherit set-value popup-menu get-size focus get-editor)
|
||||
(check-text-field-args '(constructor combo-field)
|
||||
label
|
||||
|
|
@ -141,8 +163,19 @@
|
|||
command
|
||||
(make-object wx:control-event% 'text-field)))])
|
||||
(define menu (new popup-menu% [font font]))
|
||||
(super-instantiate (label parent callback init-value (list* combo-flag 'single style))
|
||||
[font font])
|
||||
(super-new [label label]
|
||||
[parent parent]
|
||||
[callback callback]
|
||||
[init-value init-value]
|
||||
[style (list* combo-flag 'single style)]
|
||||
[font font]
|
||||
[enabled enabled]
|
||||
[horiz-margin horiz-margin]
|
||||
[vert-margin vert-margin]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])
|
||||
(send (mred->wx this)
|
||||
set-on-popup
|
||||
(lambda ()
|
||||
|
|
|
|||
|
|
@ -44,6 +44,7 @@
|
|||
(define basic-top-level-window%
|
||||
(class* (make-area-container-window% (make-window% #t (make-container% area%))) (top-level-window<%>)
|
||||
(init mk-wx mismatches label parent)
|
||||
(init-rest)
|
||||
(inherit show)
|
||||
(rename-super [super-set-label set-label])
|
||||
(private*
|
||||
|
|
@ -146,7 +147,16 @@
|
|||
|
||||
(define frame%
|
||||
(class basic-top-level-window%
|
||||
(init label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null])
|
||||
(init label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null]
|
||||
;; for inherited keywords
|
||||
[enabled #t]
|
||||
[border no-val]
|
||||
[spacing no-val]
|
||||
[alignment no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(inherit on-traverse-char on-system-menu-char
|
||||
do-create-status-line do-set-status-text)
|
||||
(let ([cwho '(constructor frame)])
|
||||
|
|
@ -192,24 +202,45 @@
|
|||
(send wx set-modified m)]))])
|
||||
(as-entry
|
||||
(lambda ()
|
||||
(super-make-object
|
||||
(lambda (finish)
|
||||
(set! wx (finish (make-object wx-frame% this this
|
||||
(and parent (mred->wx parent)) label
|
||||
(or x -11111) (or y -11111)
|
||||
(or width -1) (or height -1)
|
||||
style)
|
||||
#f))
|
||||
(send wx set-mdi-parent #f)
|
||||
wx)
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor frame)])
|
||||
(check-container-ready cwho parent)))
|
||||
label parent)))))
|
||||
(super-new
|
||||
[mk-wx
|
||||
(lambda (finish)
|
||||
(set! wx (finish (make-object wx-frame% this this
|
||||
(and parent (mred->wx parent)) label
|
||||
(or x -11111) (or y -11111)
|
||||
(or width -1) (or height -1)
|
||||
style)
|
||||
#f))
|
||||
(send wx set-mdi-parent #f)
|
||||
wx)]
|
||||
[mismatches
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor frame)])
|
||||
(check-container-ready cwho parent)))]
|
||||
[label label]
|
||||
[parent parent]
|
||||
;; for inherited inits
|
||||
[enabled enabled]
|
||||
[border border]
|
||||
[spacing spacing]
|
||||
[alignment alignment]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])))))
|
||||
|
||||
(define dialog%
|
||||
(class basic-top-level-window%
|
||||
(init label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null])
|
||||
(init label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null]
|
||||
;; for inherited keywords
|
||||
[enabled #t]
|
||||
[border no-val]
|
||||
[spacing no-val]
|
||||
[alignment no-val]
|
||||
[min-width no-val]
|
||||
[min-height no-val]
|
||||
[stretchable-width no-val]
|
||||
[stretchable-height no-val])
|
||||
(inherit on-traverse-char on-system-menu-char center)
|
||||
(let ([cwho '(constructor dialog)])
|
||||
(check-label-string cwho label)
|
||||
|
|
@ -230,18 +261,30 @@
|
|||
(on-traverse-char event)))])
|
||||
(as-entry
|
||||
(lambda ()
|
||||
(super-make-object
|
||||
(lambda (finish)
|
||||
(set! wx (finish (make-object wx-dialog% this this
|
||||
(and parent (mred->wx parent)) label
|
||||
(or x -11111) (or y -11111) (or width 0) (or height 0)
|
||||
style)
|
||||
#f))
|
||||
wx)
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor dialog)])
|
||||
(check-container-ready cwho parent)))
|
||||
label parent)))))
|
||||
(super-new
|
||||
[mk-wx
|
||||
(lambda (finish)
|
||||
(set! wx (finish (make-object wx-dialog% this this
|
||||
(and parent (mred->wx parent)) label
|
||||
(or x -11111) (or y -11111) (or width 0) (or height 0)
|
||||
style)
|
||||
#f))
|
||||
wx)]
|
||||
[mismatches
|
||||
(lambda ()
|
||||
(let ([cwho '(constructor dialog)])
|
||||
(check-container-ready cwho parent)))]
|
||||
[label label]
|
||||
[parent parent]
|
||||
;; for inherited inits
|
||||
[enabled enabled]
|
||||
[border border]
|
||||
[spacing spacing]
|
||||
[alignment alignment]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[stretchable-width stretchable-width]
|
||||
[stretchable-height stretchable-height])))))
|
||||
|
||||
(define (get-top-level-windows)
|
||||
(remq root-menu-frame (map wx->mred (wx:get-top-level-windows))))
|
||||
|
|
|
|||
443
collects/tests/gracket/widget-init.rktl
Normal file
443
collects/tests/gracket/widget-init.rktl
Normal file
|
|
@ -0,0 +1,443 @@
|
|||
;; GUI widget initialization tests
|
||||
|
||||
(require racket/gui)
|
||||
|
||||
(define frame
|
||||
(new frame%
|
||||
[label "label"]
|
||||
[parent #f]
|
||||
[width 100]
|
||||
[height 100]
|
||||
[x 0]
|
||||
[y 0]
|
||||
[style null]
|
||||
[enabled #t]
|
||||
[border 0]
|
||||
[spacing 0]
|
||||
[alignment '(center top)]
|
||||
[min-width 100]
|
||||
[min-height 100]
|
||||
[stretchable-width #t]
|
||||
[stretchable-height #t]))
|
||||
|
||||
(define cb (lambda (b e) (void)))
|
||||
(define font (make-object font% 1 'system))
|
||||
|
||||
;; top levels
|
||||
(make-object frame%
|
||||
"label" ; label
|
||||
#f ; parent
|
||||
100 ; width
|
||||
100 ; height
|
||||
0 ; x
|
||||
0 ; y
|
||||
null ; style
|
||||
#t ; enabled
|
||||
0 ; border
|
||||
0 ; spacing
|
||||
'(center top) ; alignment
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
(make-object dialog%
|
||||
"label" ; label
|
||||
#f ; parent
|
||||
100 ; width
|
||||
100 ; height
|
||||
0 ; x
|
||||
0 ; y
|
||||
null ; style
|
||||
#t ; enabled
|
||||
0 ; border
|
||||
0 ; spacing
|
||||
'(center top) ; alignment
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
;; panels
|
||||
(make-object horizontal-panel%
|
||||
frame ; parent
|
||||
null ; style
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
0 ; border
|
||||
0 ; spacing
|
||||
'(center top) ; alignment
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
(make-object vertical-panel%
|
||||
frame ; parent
|
||||
null ; style
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
0 ; border
|
||||
0 ; spacing
|
||||
'(center top) ; alignment
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
(make-object tab-panel%
|
||||
'("a" "b") ; choices
|
||||
frame ; parent
|
||||
cb ; callback
|
||||
null ; style
|
||||
font ; font
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
0 ; border
|
||||
0 ; spacing
|
||||
'(center top) ; alignment
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
(make-object group-box-panel%
|
||||
"label" ; label
|
||||
frame ; parent
|
||||
null ; style
|
||||
font ; font
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
0 ; border
|
||||
0 ; spacing
|
||||
'(center top) ; alignment
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
;; panes
|
||||
(make-object horizontal-pane%
|
||||
frame ; parent
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
0 ; border
|
||||
0 ; spacing
|
||||
'(center top) ; alignment
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
(make-object vertical-pane%
|
||||
frame ; parent
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
0 ; border
|
||||
0 ; spacing
|
||||
'(center top) ; alignment
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
;; controls
|
||||
(make-object message%
|
||||
"label" ; label
|
||||
frame ; parent
|
||||
null ; style
|
||||
font ; font
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
#f ; auto-resize
|
||||
)
|
||||
|
||||
(make-object button%
|
||||
"label" ; label
|
||||
frame ; parent
|
||||
cb ; callback
|
||||
null ; style
|
||||
font ; font
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
(make-object radio-box%
|
||||
"label" ; label
|
||||
'("a" "b") ; choices
|
||||
frame ; parent
|
||||
cb ; callback
|
||||
'(vertical) ; style
|
||||
0 ; selection
|
||||
font ; font
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
(make-object check-box%
|
||||
"label" ; label
|
||||
frame ; parent
|
||||
cb ; callback
|
||||
null ; style
|
||||
#f ; value
|
||||
font ; font
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
(make-object slider%
|
||||
"label" ; label
|
||||
0 ; min-value
|
||||
100 ; max-value
|
||||
frame ; parent
|
||||
cb ; callback
|
||||
50 ; init-value
|
||||
'(vertical) ; style
|
||||
font ; font
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
(make-object gauge%
|
||||
"label" ; label
|
||||
100 ; range
|
||||
frame ; parent
|
||||
'(vertical) ; style
|
||||
font ; font
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
(make-object text-field%
|
||||
"label" ; label
|
||||
frame ; parent
|
||||
cb ; callback
|
||||
"foo" ; init-value
|
||||
'(single) ; style
|
||||
font ; font
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
(make-object combo-field%
|
||||
"label" ; label
|
||||
'("a" "b") ; choices
|
||||
frame ; parent
|
||||
cb ; callback
|
||||
"foo" ; init-value
|
||||
null ; style
|
||||
font ; font
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
;; list controls
|
||||
(make-object choice%
|
||||
"label" ; label
|
||||
'("a" "b") ; choices
|
||||
frame ; parent
|
||||
cb ; callback
|
||||
null ; style
|
||||
0 ; selection
|
||||
font ; font
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
(make-object list-box%
|
||||
"label" ; label
|
||||
'("a" "b") ; choices
|
||||
frame ; parent
|
||||
cb ; callback
|
||||
'(single) ; style
|
||||
0 ; selection
|
||||
font ; font
|
||||
font ; label-font
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
'("Column") ; columns
|
||||
#f ; column-order
|
||||
)
|
||||
|
||||
;; canvases
|
||||
(make-object canvas%
|
||||
frame ; parent
|
||||
null ; style
|
||||
cb ; paint-callback
|
||||
"label" ; label
|
||||
#f ; gl-config
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
(make-object editor-canvas%
|
||||
frame ; parent
|
||||
#f ; editor
|
||||
null ; style
|
||||
100 ; scrolls-per-page
|
||||
#f ; label
|
||||
3 ; wheel-step
|
||||
#f ; line-count
|
||||
5 ; horizontal-inset
|
||||
5 ; vertical-inset
|
||||
#t ; enabled
|
||||
0 ; vert-margin
|
||||
0 ; horiz-margin
|
||||
100 ; min-width
|
||||
100 ; min-height
|
||||
#t ; stretchable-width
|
||||
#t ; stretchable-height
|
||||
)
|
||||
|
||||
;; menus
|
||||
(define menu
|
||||
(make-object menu%
|
||||
"label" ; label
|
||||
(make-object menu-bar% frame) ; parent
|
||||
#f ; help-string
|
||||
(lambda (m) (void)) ; demand-callback
|
||||
))
|
||||
|
||||
(make-object popup-menu%
|
||||
"label" ; title
|
||||
(lambda (p e) (void)) ; popdown-callback
|
||||
(lambda (p) (void)) ; demand-callback
|
||||
font ; font
|
||||
)
|
||||
|
||||
(make-object menu-bar%
|
||||
(new frame% [label ""]) ; parent
|
||||
(lambda (p) (void)) ; demand-callback
|
||||
)
|
||||
|
||||
(make-object menu-item%
|
||||
"label" ; label
|
||||
menu ; parent
|
||||
cb ; callback
|
||||
'up ; shortcut
|
||||
"foo" ; help-string
|
||||
(lambda (p) (void)) ; demand-callback
|
||||
'(alt) ; shortcut-prefix
|
||||
)
|
||||
|
||||
(make-object checkable-menu-item%
|
||||
"label" ; label
|
||||
menu ; parent
|
||||
cb ; callback
|
||||
'up ; shortcut
|
||||
"foo" ; help-string
|
||||
(lambda (p) (void)) ; demand-callback
|
||||
#f ; checked
|
||||
'(alt) ; shortcut-prefix
|
||||
)
|
||||
|
||||
(make-object separator-menu-item%
|
||||
menu ; parent
|
||||
)
|
||||
|
||||
;; misc
|
||||
(make-object key-event%
|
||||
#\nul ; key-code
|
||||
#f ; shift-down
|
||||
#f ; control-down
|
||||
#f ; meta-down
|
||||
#f ; alt-down
|
||||
0 ; x
|
||||
0 ; y
|
||||
0 ; time-stamp
|
||||
#f ; caps-down
|
||||
)
|
||||
|
||||
(make-object mouse-event%
|
||||
'enter ; event-type
|
||||
#f ; left-down
|
||||
#f ; middle-down
|
||||
#f ; right-down
|
||||
0 ; x
|
||||
0 ; y
|
||||
#f ; shift-down
|
||||
#f ; control-down
|
||||
#f ; meta-down
|
||||
#f ; alt-down
|
||||
0 ; time-stamp
|
||||
#f ; caps-down
|
||||
)
|
||||
|
||||
(make-object mouse-event%
|
||||
'top ; event-type
|
||||
'vertical ; direction
|
||||
0 ; position
|
||||
0 ; time-stamp
|
||||
)
|
||||
|
||||
(make-object mouse-event%
|
||||
'button ; event-type
|
||||
0 ; time-stamp
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user