suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Matthew Flatt 2010-11-05 13:50:41 -06:00
parent c6710b8938
commit 39596efef5
11 changed files with 184 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/mred/private/mrtextfield.rkt
View File

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

11
collects/mred/private/wx/cocoa/canvas.rkt
View File

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

24
collects/mred/private/wx/gtk/canvas.rkt
View File

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

5
collects/mred/private/wx/gtk/window.rkt
View File

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

4
collects/mred/private/wx/win32/canvas.rkt
View File

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

10
collects/mred/private/wxcanvas.rkt
View File

@ -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%

6
collects/mred/private/wxtextfield.rkt
View File

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

25
collects/scribblings/gui/combo-field-class.scrbl
View File

@ -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.
}}

12
collects/tests/gracket/combo-steps.txt Normal file
View File

@ -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.

74
collects/tests/gracket/item.rkt
View File

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

13
doc/release-notes/racket/Draw_and_GUI_X_Y.txt
View File

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