From 08bb60e13a11e319c11446050d234acb0dd8ed88 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 10 Jun 2007 09:47:19 +0000 Subject: [PATCH] fix get-face-list 'mono under Mac OS X and X, and delay showing children of a frame during a container sequence svn: r6563 original commit: 1131abd11f6fd8b46c0f8f74c9cf2e7629961eeb --- collects/mred/private/wxcanvas.ss | 12 +++++++++--- collects/mred/private/wxitem.ss | 19 ++++++++++--------- collects/mred/private/wxpanel.ss | 5 ++++- collects/mred/private/wxtop.ss | 25 ++++++++++++++++++++++++- collects/mred/private/wxwindow.ss | 18 ++++++++++++++++-- 5 files changed, 63 insertions(+), 16 deletions(-) diff --git a/collects/mred/private/wxcanvas.ss b/collects/mred/private/wxcanvas.ss index d4dcb4c2..16e549bc 100644 --- a/collects/mred/private/wxcanvas.ss +++ b/collects/mred/private/wxcanvas.ss @@ -62,6 +62,7 @@ (define wx-canvas% (make-canvas-glue% (class100 (make-control% wx:canvas% 0 0 #t #t) (parent x y w h style gl-config) + (inherit get-top-level) (private-field [tabable? #f]) (public @@ -74,13 +75,16 @@ (lambda (code alpha? meta?) (or meta? (not tabable?)))]) (sequence - (super-init style parent x y w h style "canvas" gl-config))))) + (super-init style parent x y w h (cons 'deleted style) "canvas" gl-config) + (unless (memq 'deleted style) + (send (get-top-level) show-control this #t)))))) (define (make-editor-canvas% %) (class100 % (parent x y w h name style spp init-buffer) (inherit get-editor force-redraw call-as-primary-owner min-height get-size - get-hard-minimum-size set-min-height) + get-hard-minimum-size set-min-height + get-top-level) (private-field [fixed-height? #f] [fixed-height-lines 0] @@ -195,7 +199,9 @@ (when fixed-height? (update-size)))]) (sequence - (super-init style parent x y w h (or name "") style spp init-buffer) + (super-init style parent x y w h (or name "") (cons 'deleted style) spp init-buffer) + (unless (memq 'deleted style) + (send (get-top-level) show-control this #t)) (when init-buffer (let ([mred (wx->mred this)]) (when mred diff --git a/collects/mred/private/wxitem.ss b/collects/mred/private/wxitem.ss index d5247dcc..afa41d91 100644 --- a/collects/mred/private/wxitem.ss +++ b/collects/mred/private/wxitem.ss @@ -40,7 +40,7 @@ (lambda (item% x-margin-w y-margin-h stretch-x stretch-y) (class100 (wx-make-window% item% #f) (window-style . args) (inherit get-width get-height get-x get-y - get-parent get-client-size) + get-parent get-client-size get-top-level) (private-field [enabled? #t]) (override [enable @@ -197,6 +197,7 @@ (set-min-height (init-min (get-height))) (unless (memq 'deleted window-style) + (send (get-top-level) show-control this #t) ;; For a pane[l], the creator must call the equivalent of the following, ;; delaying to let the panel's wx field get initialized before ;; panel-sizing methods are called @@ -233,7 +234,7 @@ (as-exit (lambda () (command (make-object wx:control-event% 'button)))))]) - (sequence (super-init style parent cb label x y w h style font) + (sequence (super-init style parent cb label x y w h (cons 'deleted style) font) (when border? (send (get-top-level) add-border-button this)))))) (define wx-check-box% (class100 (make-window-glue% (make-simple-control% wx:check-box%)) (mred proxy parent cb label x y w h style font) @@ -244,17 +245,17 @@ (lambda () (set-value (not (get-value))) (command (make-object wx:control-event% 'check-box)))))]) - (sequence (super-init mred proxy style parent cb label x y w h style font)))) + (sequence (super-init mred proxy style parent cb label x y w h (cons 'deleted style) font)))) (define wx-choice% (class100 (make-window-glue% (make-simple-control% wx:choice%)) (mred proxy parent cb label x y w h choices style font) (override [handles-key-code (lambda (x alpha? meta?) (or (memq x '(up down)) (and alpha? (not meta?))))]) - (sequence (super-init mred proxy style parent cb label x y w h choices style font)))) + (sequence (super-init mred proxy style parent cb label x y w h choices (cons 'deleted style) font)))) (define wx-message% (class100 (make-window-glue% (make-simple-control% wx:message%)) (mred proxy parent label x y style font) (override [gets-focus? (lambda () #f)]) - (sequence (super-init mred proxy style parent label x y style font)))) + (sequence (super-init mred proxy style parent label x y (cons 'deleted style) font)))) (define wx-gauge% (make-window-glue% @@ -270,7 +271,7 @@ ;; # pixels per unit of value. [pixels-per-value 1]) (sequence - (super-init style parent label range -1 -1 -1 -1 style font) + (super-init style parent label range -1 -1 -1 -1 (cons 'deleted style) font) (let-values ([(client-width client-height) (get-two-int-values (lambda (a b) (get-client-size a b)))]) @@ -337,7 +338,7 @@ [(wheel-up) (scroll -1) #t] [(wheel-down) (scroll 1) #t] [else #f])))]) - (sequence (super-init style parent cb label kind x y w h choices style font label-font))))) + (sequence (super-init style parent cb label kind x y w h choices (cons 'deleted style) font label-font))))) (define wx-radio-box% (make-window-glue% @@ -365,7 +366,7 @@ (set-selection i) (command (make-object wx:control-event% 'radio-box)))))]) - (sequence (super-init style parent cb label x y w h choices major style font)) + (sequence (super-init style parent cb label x y w h choices major (cons 'deleted style) font)) (private-field [enable-vector (make-vector (number) #t)])))) @@ -385,7 +386,7 @@ ;; which looks bad. (sequence - (super-init style parent func label value min-val max-val -1 -1 -1 style font) + (super-init style parent func label value min-val max-val -1 -1 -1 (cons 'deleted style) font) (let-values ([(client-w client-h) (get-two-int-values (lambda (a b) (get-client-size a b)))]) diff --git a/collects/mred/private/wxpanel.ss b/collects/mred/private/wxpanel.ss index bcc04f98..5b4349ca 100644 --- a/collects/mred/private/wxpanel.ss +++ b/collects/mred/private/wxpanel.ss @@ -34,6 +34,7 @@ [on-size (lambda () (void))] [enable (lambda () (void))] [show (lambda (on?) (void))] + [is-shown? (lambda () #f)] [is-shown-to-root? (lambda () (send parent is-shown-to-root?))] [is-enabled-to-root? (lambda () (send parent is-enabled-to-root?))] [get-parent (lambda () parent)] @@ -454,7 +455,9 @@ child-infos placements))]) (sequence - (super-init style parent -1 -1 0 0 style)))) + (super-init style parent -1 -1 0 0 (cons 'deleted style)) + (unless (memq 'deleted style) + (send (get-top-level) show-control this #t))))) (define (wx-make-pane% wx:panel% stretch?) (class100 (make-container-glue% (make-glue% (wx-make-basic-panel% wx:panel% stretch?))) args diff --git a/collects/mred/private/wxtop.ss b/collects/mred/private/wxtop.ss index 9929e1cf..14926763 100644 --- a/collects/mred/private/wxtop.ss +++ b/collects/mred/private/wxtop.ss @@ -95,7 +95,8 @@ [parent-for-center parent] - [show-ht (make-hash-table)]) + [show-ht (make-hash-table)] + [fake-show-ht (make-hash-table)]) (override [enable @@ -196,6 +197,13 @@ (when perform-updates? (when pending-redraws? (force-redraw)) + (when (positive? (hash-table-count fake-show-ht)) + (let ([t fake-show-ht]) + (set! fake-show-ht (make-hash-table)) + (hash-table-for-each + t + (lambda (win v?) + (send win really-show #t))))) (when (positive? (hash-table-count show-ht)) (let ([t show-ht]) (set! show-ht (make-hash-table)) @@ -220,6 +228,21 @@ (send child show show?) (hash-table-put! show-ht child show?)))] + [show-control + (lambda (child on?) + (if (or perform-updates? + (not on?) + (child . is-a? . wx-frame%) + (child . is-a? . wx-dialog%)) + (send child really-show on?) + (begin + (if on? + (hash-table-put! fake-show-ht child #t) + (begin + (hash-table-remove! show-ht child) + (hash-table-remove! fake-show-ht child))) + (send child fake-show on?))))] + ;; force-redraw: receives a message from to redraw the ;; entire frame. ;; input: none diff --git a/collects/mred/private/wxwindow.ss b/collects/mred/private/wxwindow.ss index 1d838645..88e5ed75 100644 --- a/collects/mred/private/wxwindow.ss +++ b/collects/mred/private/wxwindow.ss @@ -52,7 +52,8 @@ (rename [super-enable enable]) (private-field - [can-accept-drag? #f]) + [can-accept-drag? #f] + [fake-shown? #f]) (public [accept-drag? (lambda () can-accept-drag?)] @@ -77,11 +78,24 @@ (set! top-level window)] [else (loop (send window get-parent))]))) top-level)]) + (public + [really-show + (lambda (on?) + (set! fake-shown? #f) + (super show on?))] + [fake-show + (lambda (on?) + (set! fake-shown? on?))]) (override [show (lambda (on?) (queue-visible) - (super show on?))] + (send (get-top-level) show-control this on?))] + [is-shown? + (lambda () + (or fake-shown? + (super is-shown?)))] + [enable (lambda (on?) (queue-active)