cocoa and gtk: fix combo% `on-popup' method

collects/mred/private/mrtextfield.rkt

@@ -101,20 +101,30 @@
 			       parent callback init-value
 			       style #f 
 			       font))
+      (private
+        [prep-popup
+         (lambda ()
+           (send menu on-demand)
+           (let ([items (send menu get-items)]
+                 [wx (mred->wx this)])
+             (send wx clear-combo-items)
+             (for-each 
+              (lambda (item)
+                (unless (item . is-a? . separator-menu-item%)
+                  (send wx append-combo-item
+                        (send item get-plain-label)
+                        (lambda ()
+                          (send item command 
+                                (make-object wx:control-event% 'menu-popdown))))))
+              items)))])
       (public
-	[on-popup (lambda (e)
+	[on-popup (lambda (e) (void))]
-		    (let-values ([(w h) (get-size)]
-				 [(cw) (send (mred->wx this) get-canvas-width)])
-		      (send menu set-min-width cw)
-		      (popup-menu menu (- w cw) h)))]
 	[get-menu (lambda () menu)]
 	[append (lambda (item)
 		  (check-label-string '(method combo-field% append) item)
-                  (unless (send (mred->wx this) append-combo-item item
-                                (lambda () (handle-selected item)))
                   (make-object menu-item% item menu 
                                (lambda (i e)
-                                   (handle-selected item)))))])
+                                 (handle-selected item))))])
       (private
         [handle-selected (lambda (item)
                            (focus)
@@ -128,5 +138,10 @@
        [menu (new popup-menu% [font font])])
       (sequence
 	(super-init label parent callback init-value (list* combo-flag 'single style))
+        (send (mred->wx this) 
+              set-on-popup
+              (lambda ()
+                (on-popup (make-object wx:control-event% 'menu-popdown))
+                (prep-popup)))
 	(for-each (lambda (item) (append item))
 		  choices)))))

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

@@ -601,6 +601,8 @@
              (scroller-page scroller)
              1)]))
 
+     (define/public (clear-combo-items)
+       (tellv content-cocoa removeAllItems))
      (define/public (append-combo-item str)
        (tellv content-cocoa addItemWithObjectValue: #:type _NSString str)
        #t)
@@ -698,9 +700,14 @@
          (get-client-size xb yb)
          ((send e get-x) . > . (- (unbox xb) 22))))
 
+     (define/public (on-popup) (void))
+
      (define/public (starting-combo)
        (set! in-menu-click? #t)
-       (tellv content-cocoa setStringValue: #:type _NSString current-text))
+       (tellv content-cocoa setStringValue: #:type _NSString current-text)
+       (constrained-reply (get-eventspace)
+                          (lambda () (on-popup))
+                          (void)))
        
      (define/public (ending-combo)
        (set! in-menu-click? #f)

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

@@ -40,6 +40,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_widget_queue_draw (_fun _GtkWidget -> _void))
 
@@ -190,7 +191,8 @@
               set-auto-size 
               adjust-client-delta infer-client-delta
               is-auto-scroll? get-virtual-width get-virtual-height
-              refresh-for-autoscroll)
+              refresh-for-autoscroll
+              get-eventspace)
 
      (define is-combo? (memq 'combo style))
      (define has-border? (or (memq 'border style)
@@ -341,6 +343,12 @@
      (define/override (get-client-gtk) client-gtk)
      (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)
+                  (send e button-down?))
+         (on-popup))
+       #f)
+
      (define/override (get-client-delta)
        (values margin margin))
 
@@ -535,8 +543,20 @@
      (when is-combo?
        (connect-changed client-gtk))
 
+     (define combo-count 0)
+     (define/public (clear-combo-items)
+       (atomically
+        (for ([n (in-range combo-count)])
+          (gtk_combo_box_remove_text gtk 0))
+        (set! combo-count 0)))
      (define/public (append-combo-item str)
-       (gtk_combo_box_append_text gtk str))
+       (atomically
+        (set! combo-count (add1 combo-count))
+        (gtk_combo_box_append_text gtk str)))
+
+     (when is-combo? (append-combo-item "..."))
+
+     (define/public (on-popup) (void))
 
      (define/public (combo-maybe-clicked)
        (let ([i (gtk_combo_box_get_active gtk)])

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

@@ -346,7 +346,8 @@
                                           (send wx dispatch-on-event m #f)))
                  #t)
                (constrained-reply (send wx get-eventspace)
-                                  (lambda () (send wx dispatch-on-event m #t))
+                                  (lambda () (or (send wx dispatch-on-event m #t)
+                                                 (send wx internal-pre-on-event gtk m)))
                                   #t))))))))
 
 ;; ----------------------------------------
@@ -590,6 +591,8 @@
        [just-pre? #f]
        [else (when enabled? (on-event e)) #t]))
 
+    (define/public (internal-pre-on-event gtk e) #f)
+
     (define/public (call-pre-on-event w e)
       (or (send parent call-pre-on-event w e)
           (pre-on-event w e)))

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

@@ -453,6 +453,10 @@
      (define/public (set-combo-text s) (void))
      (define/public (append-combo-item s)
        (SendMessageW/str combo-hwnd CB_ADDSTRING 0 s))
+     (define/public (clear-combo-items)
+       (void))
+
+     (define/public (on-popup) (void))
 
      (define/override (is-command? cmd)
        (= cmd CBN_SELENDOK))

collects/mred/private/wxcanvas.rkt

@@ -23,14 +23,16 @@
 	[do-on-scroll (lambda (e) (super on-scroll e))]
 	[do-on-paint (lambda () (super on-paint))])
       (private-field
-       [tabable? default-tabable?])
+       [tabable? default-tabable?]
+       [on-popup-callback void])
       (public
         [get-tab-focus (lambda () tabable?)]
         [set-tab-focus (lambda (v) (set! tabable? v))]
         [on-tab-in (lambda () 
 		     (let ([mred (wx->mred this)])
 		       (when mred
-			 (send mred on-tab-in))))])
+			 (send mred on-tab-in))))]
+        [set-on-popup (lambda (proc) (set! on-popup-callback proc))])
       (override
         [gets-focus? (lambda () tabable?)]
         [handles-key-code
@@ -68,7 +70,9 @@
 		     (let ([mred (get-mred)])
 		       (if mred
 			   (as-exit (lambda () (clear-and-on-paint mred)))
-			   (as-exit (lambda () (clear-margins) (super on-paint)))))))])
+			   (as-exit (lambda () (clear-margins) (super on-paint)))))))]
+        ;; for 'combo canvases:
+        [on-popup (lambda () (on-popup-callback))])
       (sequence (apply super-init mred proxy args))))
 
   (define wx-canvas% 

collects/mred/private/wxtextfield.rkt

@@ -167,7 +167,9 @@
 	       (make-object wx-message% #f proxy p label -1 -1 null font))]
        [c (make-object (class wx-text-editor-canvas% 
                          (define/override (on-combo-select i)
-                           ((list-ref callbacks (- (length callbacks) i 1))))
+                           (let ([len (length callbacks)])
+                             (when (< -1 i len)
+                               ((list-ref callbacks (- len i 1))))))
                          (super-new))
                        #f proxy this p
 		       (append
@@ -182,6 +184,8 @@
 			    '(hide-vscroll hide-hscroll))))]
        [callbacks null])
       (public
+        [set-on-popup (lambda (proc) (send c set-on-popup proc))]
+        [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)
                                   (set! callbacks (cons cb callbacks))

collects/scribblings/gui/combo-field-class.scrbl

@@ -5,8 +5,8 @@
 
 A @scheme[combo-field%] object is a @scheme[text-field%]
  object that also resembles a @scheme[choice%] object, because it
- has a small popup button to the right of the text field. By default,
+ has a small popup button to the right of the text field. Clicking 
- clicking the button pops up a menu, and selecting a menu item copies
+ the button pops up a menu, and selecting a menu item typically copies
  the item into the text field.
 
 
@@ -40,9 +40,8 @@ The @scheme[choices] list specifies the initial list of items for the
  combo's popup menu. The
 @method[combo-field% append] method adds a new item to the menu with a callback to install the
  appended item into the combo's text field. The
-@method[combo-field% get-menu] method returns the combo's menu to allow arbitrary other operations.
+@method[combo-field% get-menu] method returns a menu that can be changed to
- This menu might not be used at all if
+ adjust the content and actions of the combo's menu.
-@method[combo-field% on-popup] is overridden.
 
 The @scheme[callback] procedure is called when the user changes the text
  in the combo or presses the Enter key (and Enter is not handled by
@@ -75,11 +74,10 @@ Adds a new item to the combo's popup menu. The given label is used for
 
 @defmethod[(get-menu)
            (is-a?/c popup-menu%)]{
-Returns the @scheme[popup-menu%] that is used by the default
+Returns a @scheme[popup-menu%] that is effectively copied into the
-@method[combo-field% on-popup] method. This menu is initialized with the @scheme[labels] argument when
+ combo's popup menu when the combo is clicked. Only the labels can
- the @scheme[combo-field%] is created, and the
+ callbacks of the menu's items are used; the enable state, submenus,
-@method[combo-field% append] method adds a new item to the menu.
+ or separators are ignored.
-
 }
 
 
@@ -88,14 +86,13 @@ Returns the @scheme[popup-menu%] that is used by the default
 
 @methspec{
 
-Called when the user clicks the combo's popup button.
+Called when the user clicks the combo's popup button. Override this method
+to adjust the content of the combo menu on demand.
 
 }
 @methimpl{
 
-Gets a menu from
+Does nothing.
-@method[combo-field% get-menu], sets its minimum width to match the combo control's width, and
- then pops up the menu.
 
 }}
 

collects/tests/gracket/combo-steps.txt

@@ -0,0 +1,12 @@
+Set Up, Callbacks, Appending
+----------------------------
+
+The choice/list should contain "Apple" and "Banana" for
+ starters.
+
+Watch for "Popup!" printed to stdout when you click the choice item.
+
+When you use "Reset", the content should change to "Alpha", "Beta",
+ and "Gamma", and selecting them should install the word plus
+ "for Reset" into the text field.
+

collects/tests/gracket/item.rkt

@@ -1565,6 +1565,79 @@
   (instructions p "choice-list-steps.txt")
   (send f show #t))
 
+(define (combo-frame empty?)
+  (define f (make-frame frame% "Combo Test"))
+  (define p f)
+  (define actual-content '("Apple" "Banana"))
+  (define (callback c e) (void))
+  (define c (make-object (class combo-field% 
+                           (define/override (on-popup e)
+                             (printf "Popup!\n"))
+                           (super-new))
+                         "Tester" actual-content p callback))
+  (define counter 0)
+  (define append-with-user-data? #f)
+  (define ab (make-object button%
+			  "Append" p
+			  (lambda (b e)
+			    (set! counter (add1 counter))
+			    (let ([naya (format "~aExtra ~a" 
+						(if (= counter 10)
+						    (string-append
+						     "This is a Really Long Named Item That Would Have Used the Short Name, Yes "
+						     "This is a Really Long Named Item That Would Have Used the Short Name ")
+						    "")
+						counter)]
+				  [naya-data (box 0)])
+			      (set! actual-content (append actual-content (list naya)))
+			      (send c append naya)))))
+  (define asb (make-object button%
+                           "Append Separator" p
+                           (lambda (b e)
+                             (set! counter (add1 counter))
+                             (new separator-menu-item% [parent (send c get-menu)]))))
+  (define cdp (make-object horizontal-panel% p))
+  (define (clear)
+    (for ([i (send (send c get-menu) get-items)])
+      (send i delete)))
+  (define rb (make-object button% "Clear" cdp
+                          (lambda (b e) (clear))))
+  (define (gone l n)
+    (if (zero? n)
+        (cdr l)
+        (cons (car l) (gone (cdr l) (sub1 n)))))
+  (define (delete p)
+    (send (list-ref (send (send c get-menu) get-items) p) delete)
+    (when (<= 0 p (sub1 (length actual-content)))
+      (set! actual-content (gone actual-content p))))
+  (define db (make-object button%
+                          "Delete First" cdp
+                          (lambda (b e)
+                            (unless (null? actual-content)
+                              (delete 0)))))
+  (define dbe (make-object button%
+                           "Delete Last" cdp
+                           (lambda (b e)
+                             (unless (null? actual-content)
+                               (delete (sub1 (length actual-content)))))))
+  (define setb (make-object button%
+                            "Reset" cdp
+                            (lambda (b e)
+                              (clear)
+                              (let ([m (send c get-menu)])
+                                (for ([i '("Alpha" "Beta" "Gamma")])
+                                  (new menu-item% [parent m] [label i]
+                                       [callback (lambda (itm e)
+                                                   (send c set-value
+                                                         (format "~a from Reset" i)))]))))))
+  (define tb (make-object button%
+			  "Check" p
+			  (lambda (b e)
+                            (void))))
+  (send c stretchable-width #t)
+  (instructions p "combo-steps.txt")
+  (send f show #t))
+
 (define (slider-frame style)
   (define f (make-frame frame% "Slider Test"))
   (define p (make-object vertical-panel% f))
@@ -2163,6 +2236,7 @@
 (send cp stretchable-width #f)
 (make-object button% "Make Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #f)))
 (make-object button% "Make Empty Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #t)))
+(make-object button% "Make Combo Frame" cp (lambda (b e) (combo-frame #f)))
 (define lp (make-object horizontal-pane% ap))
 (send lp stretchable-width #f)
 (make-object button% "Make List Frame" lp (lambda (b e) (choice-or-list-frame #t '(single) #f)))

doc/release-notes/racket/Draw_and_GUI_X_Y.txt

@@ -93,8 +93,8 @@ backward-compatibile. Methods like `get-translation',
 `set-translation', `scale', etc. help hide the reundancy.
 
 
-Others Drawing-Context Changes
+Other Drawing-Context Changes
-------------------------------
+-----------------------------
 
 The alpha value of a `dc<%>' (as set by `set-alpha') is used for all
 drawing operations, including drawing a bitmap.
@@ -122,6 +122,15 @@ background for the selected region, and it should draw the foreground
 in the color specified by `get-highlight-text-color', if any.
 
 
+Other GUI Changes
+-----------------
+
+The `on-popup' method of `combo-field%' can be used to adjust the
+content of the combo-box popup menu, but the default implementation no
+longer triggers the popup menu; instead, the popup behavior is built
+into the control.
+
+
 Removed Functions
 -----------------