From fc5b2ac2091222170b2469ccf24c1e2c9a3794ac Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 19 Jun 2012 12:31:43 -0400 Subject: [PATCH] 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 --- collects/mred/private/mrcanvas.rkt | 140 ++++++++----- collects/mred/private/mritem.rkt | 270 +++++++++++++++++++------- collects/mred/private/mrpanel.rkt | 237 +++++++++++++++++----- collects/mred/private/mrtextfield.rkt | 69 +++++-- collects/mred/private/mrtop.rkt | 99 +++++++--- 5 files changed, 597 insertions(+), 218 deletions(-) diff --git a/collects/mred/private/mrcanvas.rkt b/collects/mred/private/mrcanvas.rkt index a2d6abbf..8f4a8504 100644 --- a/collects/mred/private/mrcanvas.rkt +++ b/collects/mred/private/mrcanvas.rkt @@ -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 diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index fe626f23..74458c25 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -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]))) diff --git a/collects/mred/private/mrpanel.rkt b/collects/mred/private/mrpanel.rkt index f3e4b085..8eeb3412 100644 --- a/collects/mred/private/mrpanel.rkt +++ b/collects/mred/private/mrpanel.rkt @@ -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 diff --git a/collects/mred/private/mrtextfield.rkt b/collects/mred/private/mrtextfield.rkt index 1dd0ab7d..e514e341 100644 --- a/collects/mred/private/mrtextfield.rkt +++ b/collects/mred/private/mrtextfield.rkt @@ -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 () diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index d74822a3..64859cf5 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -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))))