fix on-subwindow- and modal for choice%; suppress other callbacks on set

original commit: f8ba0a65d2104139bc2ab9b072d6e09f5a8aee5b

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)
+(define-signal-handler connect-value-changed-h "value-changed"
-  (let ([wx (gtk->wx gtk)])
+  (_fun _GtkWidget -> _void)
-    (queue-window-event wx (lambda () (send wx do-scroll 'horizontal))))
+  (lambda (gtk)
-  #t)
+    (do-value-changed gtk 'horizontal)))
-(define handle_value_changed_h
-  (function-ptr handle-value-changed-h (_fun #:atomic? #t _GtkWidget _pointer -> _void)))
 
-(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
+    (when hscroll-adj (connect-value-changed-h hscroll-adj))
-      (g_signal_connect hscroll-adj "value-changed" handle_value_changed_h))
+    (when vscroll-adj (connect-value-changed-v vscroll-adj))
-    (when vscroll-adj
-      (g_signal_connect vscroll-adj "value-changed" handle_value_changed_v))
 
     (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))

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
+  (define button-gtk (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)))
 
   (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))))
+       (set! count 0)
-  (define/public (append l)
+       (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)))))

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

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))))
+        (gtk_list_store_set store iter 0 s -1)))
-  (reset-content)
+    (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
+    (unless ignore-click?
-     this
+      (queue-window-event
-     (lambda ()
+       this
-       (unless (null? items)
+       (lambda ()
-         (callback this (new control-event%
+         (unless (null? items)
-                             [event-type 'list-box]
+           (callback this (new control-event%
-                             [time-stamp (current-milliseconds)]))))))
+                               [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)
+    (as-entry
-    (set! items choices)
+     (lambda ()
-    (set! data (map (lambda (x) (box #f)) choices))
+       (set! ignore-click? #t)
-    (reset-content))
+       (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)])
+    (as-entry
-      (if on?
+     (lambda ()
-          (begin
+       (set! ignore-click? #t)
-            (unless extend?
+       (let ([p (gtk_tree_path_new_from_indices i -1)])
-              (gtk_tree_selection_unselect_all selection))
+         (if on?
-            (gtk_tree_selection_select_path selection p))
+             (begin
-          (gtk_tree_selection_unselect_path selection p))
+               (unless extend?
-      (gtk_tree_path_free p)))
+                 (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)))
+    (as-entry
-    (set! data (append data (list (box v))))
+     (lambda ()
-    (let ([iter (make-GtkTreeIter 0 #f #f #f)])
+       (set! ignore-click? #t)
-      (gtk_list_store_append store iter #f)
+       (set! items (append items (list s)))
-      (gtk_list_store_set store iter 0 s -1))))
+       (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))

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 
+    (unless ignore-click?
-     this
+      (queue-window-event 
-     (lambda ()
+       this
-       (callback this (new control-event%
+       (lambda ()
-                           [event-type 'slider]
+         (callback this (new control-event%
-                           [time-stamp (current-milliseconds)])))))
+                             [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)))))

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-gobj g_signal_connect_data (_fun _gpointer _string _fpointer _pointer _fnpointer _int -> _ulong))
-(define (g_signal_connect obj s proc)
+(define (g_signal_connect obj s proc user-data)
-  (g_signal_connect_data obj s proc #f 0))
+  (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)
+    (define (connect-name gtk [user-data #f])
-      (g_signal_connect gtk signal-name handler_function))))
+      (g_signal_connect gtk signal-name handler_function user-data))))

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]