diff --git a/collects/mred/private/mrtextfield.rkt b/collects/mred/private/mrtextfield.rkt index c3747db11f..f7d81de5b8 100644 --- a/collects/mred/private/mrtextfield.rkt +++ b/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) - (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)))] + [on-popup (lambda (e) (void))] [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)))))]) + (make-object menu-item% item menu + (lambda (i e) + (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))))) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 7abf4dea60..bf75a67ad1 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/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,10 +700,15 @@ (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) (let ([pos (tell #:type _NSInteger content-cocoa indexOfSelectedItem)]) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index d372d8fd94..eb19b7848c 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/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)]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index b55c04c1e7..e4cc352e2a 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/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))) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index 3b9316a4e0..9191ba9338 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/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)) diff --git a/collects/mred/private/wxcanvas.rkt b/collects/mred/private/wxcanvas.rkt index 94da953ff4..8d8591b37d 100644 --- a/collects/mred/private/wxcanvas.rkt +++ b/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% diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index d7a618d767..e87ae2c890 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/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)) diff --git a/collects/scribblings/gui/combo-field-class.scrbl b/collects/scribblings/gui/combo-field-class.scrbl index c2b0a74fb5..14b54d5f09 100644 --- a/collects/scribblings/gui/combo-field-class.scrbl +++ b/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, - clicking the button pops up a menu, and selecting a menu item copies + has a small popup button to the right of the text field. Clicking + 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. - This menu might not be used at all if -@method[combo-field% on-popup] is overridden. +@method[combo-field% get-menu] method returns a menu that can be changed to + adjust the content and actions of the combo's menu. 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 -@method[combo-field% on-popup] method. This menu is initialized with the @scheme[labels] argument when - the @scheme[combo-field%] is created, and the -@method[combo-field% append] method adds a new item to the menu. - +Returns a @scheme[popup-menu%] that is effectively copied into the + combo's popup menu when the combo is clicked. Only the labels can + callbacks of the menu's items are used; the enable state, submenus, + 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 -@method[combo-field% get-menu], sets its minimum width to match the combo control's width, and - then pops up the menu. +Does nothing. }} diff --git a/collects/tests/gracket/combo-steps.txt b/collects/tests/gracket/combo-steps.txt new file mode 100644 index 0000000000..80a569cdb8 --- /dev/null +++ b/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. + diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 4e32dd54bb..493bfedc99 100644 --- a/collects/tests/gracket/item.rkt +++ b/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))) diff --git a/doc/release-notes/racket/Draw_and_GUI_X_Y.txt b/doc/release-notes/racket/Draw_and_GUI_X_Y.txt index f179447c3a..3e20f6fe87 100644 --- a/doc/release-notes/racket/Draw_and_GUI_X_Y.txt +++ b/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 -----------------