cocoa and gtk: make combo-field% `on-popup' work better

original commit: c9e778c54137b1fe1468e9ef46a242245572e9e1

collects/mred/private/wx/cocoa/canvas.rkt

@@ -382,6 +382,7 @@
      (define/override (get-client-size xb yb)
        (super get-client-size xb yb)
        (when is-combo?
+         (set-box! xb (max 0 (- (unbox xb) 22)))
          (set-box! yb (max 0 (- (unbox yb) 5)))))
 
      (define/override (maybe-register-as-child parent on?)
@@ -627,6 +628,8 @@
        (tellv content-cocoa addItemWithObjectValue: #:type _NSString str)
        #t)
      (define/public (on-combo-select i) (void))
+     (define/public (popup-combo)
+       (tellv (tell content-cocoa cell) popUp: #f))
 
      (define clear-bg? (and (not (memq 'transparent canvas-style)) 
                             (not (memq 'no-autoclear canvas-style))))
@@ -718,7 +721,7 @@
        (let ([xb (box 0)]
              [yb (box 0)])
          (get-client-size xb yb)
-         ((send e get-x) . > . (- (unbox xb) 22))))
+         ((send e get-x) . > . (unbox xb))))
 
      (define/public (on-popup) (void))
 
@@ -764,12 +767,10 @@
        (void))
 
      (define/public (get-backing-size xb yb)
-       (get-client-size xb yb)
+       (get-client-size xb yb))
-       (when is-combo?
-         (set-box! xb (- (unbox xb) 22))))
 
      (define/override (get-cursor-width-delta)
-       (if is-combo? 22 0))
+       0)
 
      (define/public (is-flipped?)
        (tell #:type _BOOL (get-cocoa-content) isFlipped))

collects/mred/private/wx/gtk/canvas.rkt

@@ -41,6 +41,7 @@
 (define-gtk gtk_combo_box_entry_new_text (_fun -> _GtkWidget))
 (define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void))
 (define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void))
+(define-gtk gtk_combo_box_popup (_fun _GtkWidget -> _void))
 
 (define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void))
 
@@ -344,10 +345,19 @@
      (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk)))
 
      (define/override (internal-pre-on-event gtk e)
-       (when (and (ptr-equal? gtk combo-button-gtk)
+       (if (and (ptr-equal? gtk combo-button-gtk)
                 (send e button-down?))
-         (on-popup))
+           (begin
-       #f)
+             (on-popup)
+             #t)
+           #f))
+     (define/public (popup-combo)
+       ;; Unfortunately, the user has to hold the mouse 
+       ;; button down when popping up the menu this way,
+       ;; whereas the default handler (that we subvert in
+       ;; `internal-pre-on-event') keeps the menu open if
+       ;; the user release the mouse button right away.
+       (gtk_combo_box_popup gtk))
 
      (define/override (get-client-delta)
        (values margin margin))

collects/mred/private/wxtextfield.rkt

@@ -221,6 +221,7 @@
       (private-field
        [l (and label
 	       (make-object wx-message% #f proxy p label -1 -1 null font))]
+       [combo-callback #f]
        [c (make-object (class wx-text-editor-canvas% 
                          (define/override (on-combo-select i)
                            (let ([len (length callbacks)])
@@ -239,8 +240,30 @@
 				'(hide-hscroll))
 			    '(hide-vscroll hide-hscroll))))]
        [callbacks null])
+      (override 
+        [pre-on-event (lambda (w e)
+                        (or (super pre-on-event w e)
+                            (and combo-callback
+                                 (eq? w c)
+                                 (send e button-down?)
+                                 (let ([w (box 0)]
+                                       [h (box 0)])
+                                   (send c get-client-size w h)
+                                   (not (and (<= 0 (send e get-x) (unbox w))
+                                             (<= 0 (send e get-y) (unbox h)))))
+                                 (begin
+                                   (do-popup-callback)
+                                   #t))))])
+      (private
+        [do-popup-callback (lambda ()
+                             (wx:queue-callback (lambda ()
+                                                  (combo-callback)
+                                                  (send c popup-combo))
+                                                wx:middle-queue-key))])
       (public
-        [set-on-popup (lambda (proc) (send c set-on-popup proc))]
+        [set-on-popup (lambda (proc) 
+                        (set! combo-callback proc) 
+                        (send c set-on-popup (lambda () (do-popup-callback))))]
         [clear-combo-items (lambda () (set! callbacks null) (send c clear-combo-items))]
         [append-combo-item (lambda (s cb)
                              (and (send c append-combo-item s)