suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix get-face-list 'mono under Mac OS X and X, and delay showing children of a frame during a container sequence

Browse Source 
svn: r6563

original commit: 1131abd11f6fd8b46c0f8f74c9cf2e7629961eeb
This commit is contained in:
Matthew Flatt 2007-06-10 09:47:19 +00:00
parent f73a2b9dc5
commit 08bb60e13a
5 changed files with 63 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/mred/private/wxcanvas.ss
View File

@ -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

19
collects/mred/private/wxitem.ss
View File

@ -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)))])

5
collects/mred/private/wxpanel.ss
View File

@ -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

25
collects/mred/private/wxtop.ss
View File

@ -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

18
collects/mred/private/wxwindow.ss
View File

@ -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)