From 21ccccbc3f7fb6ba73762204334a14b15a0ec54a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 5 Aug 2010 05:48:18 -0600 Subject: [PATCH] fix on-subwindow- and modal for choice%; suppress other callbacks on set original commit: f8ba0a65d2104139bc2ab9b072d6e09f5a8aee5b --- collects/mred/private/wx/gtk/canvas.rkt | 51 ++++++---- collects/mred/private/wx/gtk/choice.rkt | 34 +++---- collects/mred/private/wx/gtk/combo.rkt | 118 ++++++++++++++++++++++ collects/mred/private/wx/gtk/list-box.rkt | 75 +++++++++----- collects/mred/private/wx/gtk/slider.rkt | 23 +++-- collects/mred/private/wx/gtk/utils.rkt | 11 +- collects/mred/private/wx/gtk/window.rkt | 11 +- 7 files changed, 234 insertions(+), 89 deletions(-) create mode 100644 collects/mred/private/wx/gtk/combo.rkt diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index 16f364bc..36061022 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -12,7 +12,8 @@ "window.rkt" "client-window.rkt" "widget.rkt" - "dc.rkt") + "dc.rkt" + "combo.rkt") (provide canvas%) @@ -108,19 +109,20 @@ (GdkRectangle-height r))) (gdk_gc_unref gc))))) -(define (handle-value-changed-h gtk ignored) - (let ([wx (gtk->wx gtk)]) - (queue-window-event wx (lambda () (send wx do-scroll 'horizontal)))) - #t) -(define handle_value_changed_h - (function-ptr handle-value-changed-h (_fun #:atomic? #t _GtkWidget _pointer -> _void))) +(define-signal-handler connect-value-changed-h "value-changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (do-value-changed gtk 'horizontal))) -(define (handle-value-changed-v gtk ignored) +(define-signal-handler connect-value-changed-v "value-changed" + (_fun _GtkWidget -> _void) + (lambda (gtk) + (do-value-changed gtk 'vertical))) + +(define (do-value-changed gtk dir) (let ([wx (gtk->wx gtk)]) - (queue-window-event wx (lambda () (send wx do-scroll 'vertical)))) + (queue-window-event wx (lambda () (send wx do-scroll dir)))) #t) -(define handle_value_changed_v - (function-ptr handle-value-changed-v (_fun #:atomic? #t _GtkWidget _pointer -> _void))) (define-gtk gtk_entry_get_type (_fun -> _GType)) @@ -145,7 +147,9 @@ (define virtual-height #f) (define virtual-width #f) - (define-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) + (define-values (client-gtk gtk + hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box + combo-button-gtk) (cond [(or (memq 'hscroll style) (memq 'vscroll style)) @@ -184,11 +188,12 @@ (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))))] + (and (memq 'hscroll style) (memq 'vscroll style) resize-box) + #f)))] [is-combo? (let* ([gtk (gtk_combo_box_entry_new_text)] [orig-entry (gtk_bin_get_child gtk)]) - (values orig-entry gtk #f #f #f #f #f))] + (values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk)))] [has-border? (let ([client-gtk (gtk_drawing_area_new)] [h (gtk_hbox_new #f 0)]) @@ -196,10 +201,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))] + (values client-gtk h #f #f #f #f #f #f))] [else (let ([client-gtk (gtk_drawing_area_new)]) - (values client-gtk client-gtk #f #f #f #f #f))])) + (values client-gtk client-gtk #f #f #f #f #f #f))])) (super-new [parent parent] [gtk gtk] @@ -209,7 +214,9 @@ null (if hscroll-adj (list client-gtk hscroll-adj vscroll-adj) - (list client-gtk)))]) + (if combo-button-gtk + (list client-gtk combo-button-gtk) + (list client-gtk))))]) (set-size x y w h) @@ -248,18 +255,18 @@ GDK_LEAVE_NOTIFY_MASK)) (set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk) GTK_CAN_FOCUS)) + (when combo-button-gtk + (connect-combo-key-and-mouse combo-button-gtk)) - (when hscroll-adj - (g_signal_connect hscroll-adj "value-changed" handle_value_changed_h)) - (when vscroll-adj - (g_signal_connect vscroll-adj "value-changed" handle_value_changed_v)) + (when hscroll-adj (connect-value-changed-h hscroll-adj)) + (when vscroll-adj (connect-value-changed-v vscroll-adj)) (define/override (direct-update?) #f) (define/public (get-dc) dc) (define/override (get-client-gtk) client-gtk) - (define/override (handles-events?) #t) + (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk))) (define/override (get-client-delta) (values margin margin)) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index ff7c532c..ce69a648 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -7,7 +7,9 @@ "types.rkt" "utils.rkt" "window.rkt" - "../common/event.rkt") + "combo.rkt" + "../common/event.rkt" + "../common/queue.rkt") (unsafe!) (provide choice%) @@ -20,9 +22,6 @@ (define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void)) (define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int)) -(define-gtk gtk_container_foreach (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void)) -(define-gtk gtk_container_forall (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void)) - (define-signal-handler connect-changed "changed" (_fun _GtkWidget -> _void) (lambda (gtk) @@ -43,18 +42,7 @@ ;; Hack to access the combobox's private child, where is ;; where the keyboard focus goes. - (define button-gtk - (let ([all null] - [ext null]) - (gtk_container_forall gtk (lambda (c) (set! all (cons c all))) #f) - (gtk_container_foreach gtk (lambda (c) (set! ext (cons c ext))) #f) - (for-each (lambda (e) - (set! all (filter (lambda (a) (not (ptr-equal? a e))) - all))) - ext) - (unless (= 1 (length all)) - (error "expected Gtk combobox to have one private child")) - (car all))) + (define button-gtk (extract-combo-button gtk)) (super-new [parent parent] [gtk gtk] @@ -62,14 +50,13 @@ [callback cb] [no-show? (memq 'deleted style)]) - (connect-key-and-mouse button-gtk) - (gtk_combo_box_set_active gtk 0) (set-auto-size) (connect-changed gtk) (connect-focus button-gtk) + (connect-combo-key-and-mouse button-gtk) (define callback cb) (define/public (clicked) @@ -94,13 +81,18 @@ (define/public (clear) (as-entry (lambda () + (set! ignore-clicked? #t) (for ([i (in-range count)]) (gtk_combo_box_remove_text gtk 0)) - (set! count 0)))) - (define/public (append l) + (set! count 0) + (set! ignore-clicked? #f)))) + (public [-append append]) + (define (-append l) (as-entry (lambda () + (set! ignore-clicked? #t) (set! count (add1 count)) (gtk_combo_box_append_text gtk l) (when (= count 1) - (set-selection 0)))))) + (set-selection 0)) + (set! ignore-clicked? #f))))) diff --git a/collects/mred/private/wx/gtk/combo.rkt b/collects/mred/private/wx/gtk/combo.rkt new file mode 100644 index 00000000..d0c08c37 --- /dev/null +++ b/collects/mred/private/wx/gtk/combo.rkt @@ -0,0 +1,118 @@ +#lang scheme/base +(require scheme/foreign + scheme/class + "../../syntax.rkt" + "types.rkt" + "utils.rkt" + "window.rkt") +(unsafe!) + +;; Hacks for working with GtkComboBox[Entry] + +(provide extract-combo-button + connect-combo-key-and-mouse) + +;; ---------------------------------------- + +(define-gtk gtk_container_foreach (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void)) +(define-gtk gtk_container_forall (_fun _GtkWidget (_fun _GtkWidget -> _void) _pointer -> _void)) + +(define-gobj g_signal_parse_name (_fun _string + _GType + (id : (_ptr o _uint)) + (_ptr o _GQuark) + _gboolean + -> (r : _gboolean) + -> (and r id))) + +(define-gobj g_type_from_name (_fun _string -> _GType)) + +(define _GSignalMatchType _int) +(define _GQuark _uint32) +(define _GClosure _int) +(define-gobj g_signal_handler_find (_fun _GtkWidget + _GSignalMatchType + _uint ; signal_id + _GQuark ; detail + _GClosure ; closure + _pointer ; func + _pointer ; data + -> _ulong)) +(define-gobj g_signal_handler_disconnect (_fun _GtkWidget _uint -> _void)) +(define-gobj g_signal_handler_block (_fun _GtkWidget _uint -> _void)) +(define-gobj g_signal_handler_unblock (_fun _GtkWidget _uint -> _void)) + +(define-gobj g_signal_emit (_fun _GtkWidget + _uint + _GQuark + _pointer + (r : (_ptr o _gboolean)) + -> _void + -> r)) + +(define G_SIGNAL_MATCH_ID 1) + +(define button-press-id #f) + +(define unblocked? #f) +(define-signal-handler connect-reorder-button-press "button-press-event" + (_fun _GtkWidget _GdkEventButton-pointer _long -> _gboolean) + (lambda (gtk event other-id) + (if unblocked? + #f + (let ([v (do-button-event gtk event #f #f)]) + (or v + (begin + (g_signal_handler_unblock gtk other-id) + (let ([r (g_signal_emit gtk + button-press-id + 0 + event)]) + (g_signal_handler_block gtk other-id) + r))))))) + +;; Dependence on the implemenation of GtkComboBox: +;; Keyboard focus and other actions are based on a private button widget +;; inside a GtkComboBox, so we extract it. +(define (extract-combo-button gtk) + (let ([all null] + [ext null]) + (gtk_container_forall gtk (lambda (c) (set! all (cons c all))) #f) + (gtk_container_foreach gtk (lambda (c) (set! ext (cons c ext))) #f) + (for-each (lambda (e) + (set! all (filter (lambda (a) (not (ptr-equal? a e))) + all))) + ext) + (unless (= 1 (length all)) + (error "expected Gtk combobox to have one private child")) + (car all))) + +;; More dependence on the implemenation of GtkComboBox: +;; The memnu-popup action is implemented by seeting a button-press-event +;; signal handler on `button-gtk'. Since Gtk calls signal handlers in the +;; order that they're registered, our button-press-event handler doesn't +;; get called first, so it can't cancel the button press due to modality +;; or an `on-subwindow-event' result. We effectively reorder the callbacks +;; by finding the old one, blocking it, and then unblocking during a +;; redispatch. +(define (connect-combo-key-and-mouse button-gtk) + (unless button-press-id + (set! button-press-id + (g_signal_parse_name "button-press-event" (g_type_from_name "GtkWidget") #f))) + (let ([hand-id + (and button-press-id + (let ([hand-id (g_signal_handler_find button-gtk + G_SIGNAL_MATCH_ID + button-press-id + 0 + 0 + #f + #f)]) + (if (zero? hand-id) + #f + (begin + (g_signal_handler_block button-gtk hand-id) + hand-id))))]) + (connect-key-and-mouse button-gtk (and hand-id #t)) + (when hand-id + (connect-reorder-button-press button-gtk (cast hand-id _long _pointer))))) diff --git a/collects/mred/private/wx/gtk/list-box.rkt b/collects/mred/private/wx/gtk/list-box.rkt index a744d4ae..4544f778 100644 --- a/collects/mred/private/wx/gtk/list-box.rkt +++ b/collects/mred/private/wx/gtk/list-box.rkt @@ -79,9 +79,14 @@ (let ([iter (make-GtkTreeIter 0 #f #f #f)]) (for ([s (in-list items)]) (gtk_list_store_append store iter #f) - (gtk_list_store_set store iter 0 s -1)))) - (reset-content) + (gtk_list_store_set store iter 0 s -1))) + (maybe-init-select)) + (define/private (maybe-init-select) + (when (and (= (get-selection) -1) + (pair? data)) + (set-selection 0))) + (define column (let ([renderer (gtk_cell_renderer_text_new)]) (gtk_tree_view_column_new_with_attributes @@ -119,15 +124,18 @@ (define/override (get-client-gtk) client-gtk) (define callback cb) + (define ignore-click? #f) (define/public (queue-changed) + (make-will-executor) ;; Called from event-handling thread - (queue-window-event - this - (lambda () - (unless (null? items) - (callback this (new control-event% - [event-type 'list-box] - [time-stamp (current-milliseconds)])))))) + (unless ignore-click? + (queue-window-event + this + (lambda () + (unless (null? items) + (callback this (new control-event% + [event-type 'list-box] + [time-stamp (current-milliseconds)]))))))) (define/private (get-iter i) (let ([iter (make-GtkTreeIter 0 #f #f #f)] @@ -151,10 +159,14 @@ (gtk_tree_path_free p))) (define/public (set choices) - (clear) - (set! items choices) - (set! data (map (lambda (x) (box #f)) choices)) - (reset-content)) + (as-entry + (lambda () + (set! ignore-click? #t) + (clear) + (set! items choices) + (set! data (map (lambda (x) (box #f)) choices)) + (reset-content) + (set! ignore-click? #f)))) (define/public (get-selections) (as-entry @@ -206,14 +218,18 @@ (gtk_tree_path_free p)))) (define/public (select i [on? #t] [extend? #t]) - (let ([p (gtk_tree_path_new_from_indices i -1)]) - (if on? - (begin - (unless extend? - (gtk_tree_selection_unselect_all selection)) - (gtk_tree_selection_select_path selection p)) - (gtk_tree_selection_unselect_path selection p)) - (gtk_tree_path_free p))) + (as-entry + (lambda () + (set! ignore-click? #t) + (let ([p (gtk_tree_path_new_from_indices i -1)]) + (if on? + (begin + (unless extend? + (gtk_tree_selection_unselect_all selection)) + (gtk_tree_selection_select_path selection p)) + (gtk_tree_selection_unselect_path selection p)) + (gtk_tree_path_free p)) + (set! ignore-click? #f)))) (define/public (set-selection i) (select i #t #f)) @@ -231,10 +247,15 @@ (public [append* append]) (define (append* s [v #f]) - (set! items (append items (list s))) - (set! data (append data (list (box v)))) - (let ([iter (make-GtkTreeIter 0 #f #f #f)]) - (gtk_list_store_append store iter #f) - (gtk_list_store_set store iter 0 s -1)))) - + (as-entry + (lambda () + (set! ignore-click? #t) + (set! items (append items (list s))) + (set! data (append data (list (box v)))) + (let ([iter (make-GtkTreeIter 0 #f #f #f)]) + (gtk_list_store_append store iter #f) + (gtk_list_store_set store iter 0 s -1)) + (maybe-init-select) + (set! ignore-click? #f)))) + (reset-content)) diff --git a/collects/mred/private/wx/gtk/slider.rkt b/collects/mred/private/wx/gtk/slider.rkt index 3a273718..2ed4cc2e 100644 --- a/collects/mred/private/wx/gtk/slider.rkt +++ b/collects/mred/private/wx/gtk/slider.rkt @@ -7,7 +7,8 @@ "types.rkt" "window.rkt" "const.rkt" - "../common/event.rkt") + "../common/event.rkt" + "../../lock.rkt") (unsafe!) (provide slider%) @@ -53,17 +54,23 @@ (connect-changed gtk) (define callback cb) + (define ignore-click? #f) (define/public (queue-changed) ;; Called in event-dispatch thread (gtk_range_set_value gtk (floor (gtk_range_get_value gtk))) - (queue-window-event - this - (lambda () - (callback this (new control-event% - [event-type 'slider] - [time-stamp (current-milliseconds)]))))) + (unless ignore-click? + (queue-window-event + this + (lambda () + (callback this (new control-event% + [event-type 'slider] + [time-stamp (current-milliseconds)])))))) (define/public (set-value v) - (gtk_range_set_value gtk v)) + (as-entry + (lambda () + (set! ignore-click? #t) + (gtk_range_set_value gtk v) + (set! ignore-click? #f)))) (define/public (get-value) (inexact->exact (floor (gtk_range_get_value gtk))))) diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 9175c90f..5524e577 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -17,7 +17,6 @@ g_object_set_data g_object_get_data - g_signal_connect g_object_new @@ -81,9 +80,9 @@ (define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void)) (define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer)) -(define-gobj g_signal_connect_data (_fun _gpointer _string _fpointer (_pointer = #f) _fnpointer _int -> _ulong)) -(define (g_signal_connect obj s proc) - (g_signal_connect_data obj s proc #f 0)) +(define-gobj g_signal_connect_data (_fun _gpointer _string _fpointer _pointer _fnpointer _int -> _ulong)) +(define (g_signal_connect obj s proc user-data) + (g_signal_connect_data obj s proc user-data #f 0)) (define-gobj g_object_get (_fun _GtkWidget (_string = "window") [w : (_ptr o _GdkWindow)] @@ -114,5 +113,5 @@ (define handler-proc proc) (define handler_function (function-ptr handler-proc (_fun #:atomic? #t . args))) - (define (connect-name gtk) - (g_signal_connect gtk signal-name handler_function)))) + (define (connect-name gtk [user-data #f]) + (g_signal_connect gtk signal-name handler_function user-data)))) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 0fb3fab9..b24e6537 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -29,6 +29,7 @@ connect-focus connect-key-and-mouse + do-button-event (struct-out GtkRequisition) _GtkRequisition-pointer (struct-out GtkAllocation) _GtkAllocation-pointer) @@ -96,7 +97,7 @@ [y 0] [time-stamp (GdkEventKey-time event)] [caps-down (bit? modifiers GDK_LOCK_MASK)])]) - (if (send wx handles-events?) + (if (send wx handles-events? gtk) (begin (queue-window-event wx (lambda () (send wx dispatch-on-char k #f))) #t) @@ -132,10 +133,10 @@ (lambda (gtk event) (do-button-event gtk event #f #t))) -(define (connect-key-and-mouse gtk) +(define (connect-key-and-mouse gtk [skip-press? #f]) (connect-key-press gtk) (connect-button-press gtk) - (connect-button-release gtk) + (unless skip-press? (connect-button-release gtk)) (connect-pointer-motion gtk) (connect-enter gtk) (connect-leave gtk)) @@ -201,7 +202,7 @@ (if crossing? GdkEventCrossing-time GdkEventButton-time)) event)] [caps-down (bit? modifiers GDK_LOCK_MASK)])]) - (if (send wx handles-events?) + (if (send wx handles-events? gtk) (begin (queue-window-event wx (lambda () (send wx dispatch-on-event m #f))) @@ -366,7 +367,7 @@ (define/public (on-set-focus) (void)) (define/public (on-kill-focus) (void)) - (define/public (handles-events?) #f) + (define/public (handles-events? gtk) #f) (define/public (dispatch-on-char e just-pre?) (cond [(other-modal? this) #t]