diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 1906ceea9b..0c34141c07 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -16,12 +16,35 @@ (define (panel-mixin %) (class % + (inherit register-as-child) + (define lbl-pos 'horizontal) + (define children null) + (super-new) (define/public (get-label-position) lbl-pos) (define/public (set-label-position pos) (set! lbl-pos pos)) + (define/public (fix-dc) + (for ([child (in-list children)]) + (send child fix-dc))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (fix-dc)) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) + + (define/override (register-child child on?) + (let ([now-on? (and (memq child children) #t)]) + (unless (eq? on? now-on?) + (set! children + (if on? + (cons child children) + (remq child children)))))) + (def/public-unimplemented on-paint) (define/public (set-item-cursor x y) (void)) (def/public-unimplemented get-item-cursor))) @@ -31,29 +54,6 @@ x y w h style label) - (inherit register-as-child) - - (define children null) - - (define/public (fix-dc) - (for ([child (in-list children)]) - (send child fix-dc))) - - (define/override (set-size x y w h) - (super set-size x y w h) - (fix-dc)) - - (define/override (maybe-register-as-child parent on?) - (register-as-child parent on?)) - - (define/override (register-child child on?) - (let ([now-on? (and (memq child children) #t)]) - (unless (eq? on? now-on?) - (set! children - (if on? - (cons child children) - (remq child children)))))) - (super-new [parent parent] [cocoa (as-objc-allocation diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index f3e0327941..738ccbb6c6 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -84,7 +84,8 @@ [ignored-name #f] [gl-config #f]) - (inherit get-gtk set-size get-client-size) + (inherit get-gtk set-size get-size get-client-size + on-size register-as-child) (define client-gtk (gtk_drawing_area_new)) (define-values (gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) @@ -196,9 +197,19 @@ (define/override (refresh) (gtk_widget_queue_draw client-gtk)) + + (define/public (reset-child-dcs) + (send dc reset-dc #t)) + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) (define/override (internal-on-client-size w h) - (send dc reset-dc-size)) + (send dc reset-dc #f)) + (define/override (on-client-size w h) + (let ([xb (box 0)] + [yb (box 0)]) + (get-size xb yb) + (on-size (unbox xb) (unbox yb)))) (define/public (show-scrollbars h? v?) (when hscroll-gtk diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index 018db56490..f957b182d4 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -9,13 +9,13 @@ racket/draw/local ffi/unsafe/alloc) -(provide dc% reset-dc-size) +(provide dc% reset-dc) (define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t) #:wrap (allocator cairo_destroy)) (define-local-member-name - reset-dc-size) + reset-dc) (define dc-backend% (class default-dc-backend% @@ -31,8 +31,9 @@ (set! c (gdk_cairo_create w)) c)))) - (define/public (reset-dc-size) - (when (eq? 'windows (system-type)) + (define/public (reset-dc force?) + (when (or force? + (eq? 'windows (system-type))) ;; FIXME: ensure that the dc is not in use (as-entry (lambda () diff --git a/collects/mred/private/wx/gtk/panel.rkt b/collects/mred/private/wx/gtk/panel.rkt index 3f6bda3e2c..5cee2fcc36 100644 --- a/collects/mred/private/wx/gtk/panel.rkt +++ b/collects/mred/private/wx/gtk/panel.rkt @@ -17,12 +17,36 @@ (define (panel-mixin %) (class % - (define lbl-pos 'vertical) + (inherit register-as-child) + + (define lbl-pos 'horizontal) + (define children null) + (super-new) (define/public (get-label-position) lbl-pos) (define/public (set-label-position pos) (set! lbl-pos pos)) + (define/public (reset-child-dcs) + (when (pair? children) + (for ([child (in-list children)]) + (send child reset-child-dcs)))) + + (define/override (set-size x y w h) + (super set-size x y w h) + (reset-child-dcs)) + + (define/override (maybe-register-as-child parent on?) + (register-as-child parent on?)) + + (define/override (register-child child on?) + (let ([now-on? (and (memq child children) #t)]) + (unless (eq? on? now-on?) + (set! children + (if on? + (cons child children) + (remq child children)))))) + (def/public-unimplemented on-paint) (define/public (set-item-cursor x y) (void)) (def/public-unimplemented get-item-cursor))) diff --git a/collects/mred/private/wx/gtk/tab-panel.rkt b/collects/mred/private/wx/gtk/tab-panel.rkt index 1ce9cc4163..a190e4c485 100644 --- a/collects/mred/private/wx/gtk/tab-panel.rkt +++ b/collects/mred/private/wx/gtk/tab-panel.rkt @@ -45,7 +45,8 @@ style labels) - (inherit set-size set-auto-size get-gtk) + (inherit set-size set-auto-size get-gtk + reset-child-dcs) (define gtk (gtk_notebook_new)) ;; Reparented so that it's always in the current page's bin: @@ -56,7 +57,9 @@ (define (select-bin bin-gtk) (set! current-bin-gtk bin-gtk) - (gtk_box_pack_start bin-gtk client-gtk #t #t 0)) + (gtk_box_pack_start bin-gtk client-gtk #t #t 0) + ;; re-parenting can change the underlying window dc: + (reset-child-dcs)) (define pages (for/list ([lbl labels]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index e37b8f5045..7e9f50bee6 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -255,7 +255,8 @@ (if on? (gtk_widget_show gtk) (gtk_widget_hide gtk)) - (set! shown? (and on? #t))) + (set! shown? (and on? #t)) + (maybe-register-as-child parent on?)) (define/public (show on?) (direct-show on?)) (define/public (is-shown?) shown?) @@ -325,8 +326,16 @@ (define/public (on-char e) (void)) (define/public (on-event e) (void)) + (define/public (on-size w h) (void)) + + (define/public (maybe-register-as-child parent on?) + (void)) + (define/public (register-as-child parent on?) + (send parent register-child this on?)) + (define/public (register-child child on?) + (void)) + (def/public-unimplemented on-drop-file) - (def/public-unimplemented on-size) (def/public-unimplemented get-handle) (def/public-unimplemented set-phantom-size) (def/public-unimplemented popup-menu)