From f7caa3965bf383bbc2ec5cccdb28d0a34d6372e4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 6 Sep 2010 06:51:21 -0600 Subject: [PATCH] fix problems with gtk canvas client size and with checkable menus original commit: 6772afbd2eca2c2e145cd81e9d3dadaa6c1412f7 --- collects/mred/private/wx/gtk/canvas.rkt | 63 ++++++++++++------- .../mred/private/wx/gtk/client-window.rkt | 16 ----- collects/mred/private/wx/gtk/menu.rkt | 38 ++++++----- collects/mred/private/wx/gtk/window.rkt | 12 ---- 4 files changed, 63 insertions(+), 66 deletions(-) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index dd256a66..c96d3144 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -185,7 +185,8 @@ (inherit get-gtk set-size get-size get-client-size on-size get-top-win - set-auto-size adjust-client-delta) + set-auto-size + adjust-client-delta infer-client-delta) (define is-combo? (memq 'combo style)) (define has-border? (or (memq 'border style) @@ -199,7 +200,8 @@ (define-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box - combo-button-gtk) + combo-button-gtk + scroll-width) (atomically ;; need to connect all children to gtk to avoid leaks (cond [(or (memq 'hscroll style) @@ -214,6 +216,13 @@ [hscroll (gtk_hscrollbar_new hadj)] [vscroll (gtk_vscrollbar_new vadj)] [resize-box (gtk_drawing_area_new)]) + ;; |------------------------------------| + ;; | h |-----------------| |-----------|| + ;; | | v | | v2 || + ;; | | | | [vscroll] || + ;; | | [h2 [hscroll]] | | [resize] || + ;; | |-----------------| |-----------|| + ;; |------------------------------------| (when has-border? (gtk_container_set_border_width h margin)) (gtk_box_pack_start h v #t #t 0) @@ -223,28 +232,29 @@ (gtk_box_pack_start v h2 #f #f 0) (gtk_box_pack_start h2 hscroll #t #t 0) (gtk_box_pack_start v2 resize-box #f #f 0) - (gtk_widget_show hscroll) + (when (memq 'hscroll style) + (gtk_widget_show hscroll)) (gtk_widget_show vscroll) (gtk_widget_show h) (gtk_widget_show v) - (gtk_widget_show v2) + (when (memq 'vscroll style) + (gtk_widget_show v2)) (gtk_widget_show h2) - (gtk_widget_show resize-box) + (when (memq 'hscroll style) + (gtk_widget_show resize-box)) (gtk_widget_show client-gtk) - (unless (memq 'hscroll style) - (gtk_widget_hide hscroll) - (gtk_widget_hide resize-box)) - (unless (memq 'vscroll style) - (gtk_widget_hide v2)) - (values client-gtk h hadj vadj - (and (memq 'hscroll style) h2) - (and (memq 'vscroll style) v2) - (and (memq 'hscroll style) (memq 'vscroll style) resize-box) - #f)))] + (let ([req (make-GtkRequisition 0 0)]) + (gtk_widget_size_request vscroll req) + (values client-gtk h hadj vadj + (and (memq 'hscroll style) h2) + (and (memq 'vscroll style) v2) + (and (memq 'hscroll style) (memq 'vscroll style) resize-box) + #f + (GtkRequisition-width req)))))] [is-combo? (let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))] [orig-entry (gtk_bin_get_child gtk)]) - (values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk)))] + (values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk) 0))] [has-border? (let ([client-gtk (gtk_drawing_area_new)] [h (as-gtk-allocation (gtk_hbox_new #f 0))]) @@ -252,10 +262,10 @@ (gtk_container_set_border_width h margin) (connect-expose-border h) (gtk_widget_show client-gtk) - (values client-gtk h #f #f #f #f #f #f))] + (values client-gtk h #f #f #f #f #f #f 0))] [else (let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))]) - (values client-gtk client-gtk #f #f #f #f #f #f))]))) + (values client-gtk client-gtk #f #f #f #f #f #f 0))]))) (super-new [parent parent] [gtk gtk] @@ -268,9 +278,9 @@ (if combo-button-gtk (list client-gtk combo-button-gtk) (list client-gtk))))]) - - (set-size x y w h) + (set-size x y w h) + (define dc (new dc% [canvas this])) (gtk_widget_realize gtk) @@ -303,7 +313,14 @@ (when vscroll-adj (connect-value-changed-v vscroll-adj)) (set-auto-size) - (adjust-client-delta margin margin) + (adjust-client-delta (+ (* 2 margin) + (if (memq 'vscroll style) + scroll-width + 0)) + (+ (* 2 margin) + (if (memq 'hscroll style) + scroll-width + 0))) (define/override (direct-update?) #f) @@ -400,7 +417,9 @@ (gtk_widget_show resize-box)] [(and v? (not h?)) ;; remove corner - (gtk_widget_hide resize-box)]))) + (gtk_widget_hide resize-box)])) + (adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0)) + (+ (* 2 margin) (if h? scroll-width 0)))) (define/private (configure-adj adj scroll-gtk len page pos) (when (and scroll-gtk adj) diff --git a/collects/mred/private/wx/gtk/client-window.rkt b/collects/mred/private/wx/gtk/client-window.rkt index 5c34d43c..ed86c963 100644 --- a/collects/mred/private/wx/gtk/client-window.rkt +++ b/collects/mred/private/wx/gtk/client-window.rkt @@ -29,12 +29,8 @@ (class % (init client-gtk) - (inherit remember-client-size) - (connect-size-allocate client-gtk) - (define client-w 0) - (define client-h 0) (define client-x 0) (define client-y 0) @@ -44,9 +40,6 @@ ;; Called in the Gtk event-loop thread (set! client-x x) (set! client-y y) - (set! client-w w) - (set! client-h h) - (remember-client-size w h) (queue-window-event this (lambda () (internal-on-client-size w h) (on-client-size w h)))) @@ -54,15 +47,6 @@ (define/public (internal-on-client-size w h) (void)) - (define/override (tentative-client-size w h) - (set! client-w w) - (set! client-h h)) - - #; - (define/override (get-client-size xb yb) - (set-box! xb client-w) - (set-box! yb client-h)) - (define/override (get-client-delta) (values client-x client-y)) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 504d8d92..9cb4a3a5 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -129,23 +129,26 @@ 0 (gtk_get_current_event_time))) + (define ignore-callback? #f) + (define/public (do-selected menu-item) ;; Called in event-pump thread - (let ([top (get-top-parent)]) - (cond - [top - (queue-window-event - top - (lambda () (send top on-menu-command menu-item)))] - [on-popup - (let* ([e (new popup-event% [event-type 'menu-popdown])] - [pu on-popup] - [cnb cancel-none-box]) - (set! on-popup #f) - (set-box! cancel-none-box #t) - (send e set-menu-id menu-item) - (pu (lambda () (cb this e))))] - [parent (send parent do-selected menu-item)]))) + (unless ignore-callback? + (let ([top (get-top-parent)]) + (cond + [top + (queue-window-event + top + (lambda () (send top on-menu-command menu-item)))] + [on-popup + (let* ([e (new popup-event% [event-type 'menu-popdown])] + [pu on-popup] + [cnb cancel-none-box]) + (set! on-popup #f) + (set-box! cancel-none-box #t) + (send e set-menu-id menu-item) + (pu (lambda () (cb this e))))] + [parent (send parent do-selected menu-item)])))) (define/public (do-no-selected) ;; Queue a none-selected event, but only tentatively, because @@ -237,7 +240,10 @@ (define/public (check item on?) (let ([gtk (find-gtk item)]) (when gtk - (gtk_check_menu_item_set_active gtk on?)))) + (atomically + (set! ignore-callback? #t) + (gtk_check_menu_item_set_active gtk on?) + (set! ignore-callback? #f))))) (define/public (checked? item) (let ([gtk (find-gtk item)]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index c843f68a..321eb1bb 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -338,8 +338,6 @@ (unless (= h -1) (set! save-h h)) (set! save-w (max save-w client-delta-w)) (set! save-h (max save-h client-delta-h)) - (tentative-client-size (+ save-w client-delta-w) - (+ save-h client-delta-h)) (really-set-size gtk save-x save-y save-w save-h))) (define/public (save-size x y w h) @@ -368,16 +366,6 @@ (define client-delta-w 0) (define client-delta-h 0) - (define min-client-delta-w 0) - (define min-client-delta-h 0) - (define/public (remember-client-size w h) - ;; Called in the Gtk event-loop thread - ;(set! client-delta-w (max min-client-delta-w (- save-w w))) - ;(set! client-delta-h (max min-client-delta-h (- save-h h))) - #;(queue-window-event this (lambda () (on-size 0 0))) - (void)) - (define/public (tentative-client-size w h) - (void)) (define/public (adjust-client-delta dw dh) (set! client-delta-w dw)