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. original commit: 0e4f9fcd9771986b5e960686d35f5fbf32eeb634
This commit is contained in:
Asumu Takikawa
parent
713f91d0e4
commit
fc5b2ac209
|
|
@ -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))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user