132 lines
3.9 KiB
Scheme
132 lines
3.9 KiB
Scheme
(module mrtextfield mzscheme
|
|
(require mzlib/class
|
|
mzlib/class100
|
|
mzlib/list
|
|
(prefix wx: "kernel.ss")
|
|
"lock.ss"
|
|
"const.ss"
|
|
"check.ss"
|
|
"helper.ss"
|
|
"wx.ss"
|
|
"kw.ss"
|
|
"wxtextfield.ss"
|
|
"mrcontainer.ss"
|
|
"mritem.ss"
|
|
"mrmenu.ss"
|
|
"mrpopup.ss")
|
|
|
|
(provide text-field%
|
|
combo-field%)
|
|
|
|
(define combo-flag (gensym))
|
|
|
|
(define (check-text-field-args cwho
|
|
label
|
|
choices? choices
|
|
parent
|
|
callback
|
|
init-value
|
|
style req-styles
|
|
font)
|
|
(check-label-string/false cwho label)
|
|
(when choices?
|
|
(unless (and (list? choices) (andmap label-string? choices))
|
|
(raise-type-error (who->name cwho) "list of strings (up to 200 characters)" choices)))
|
|
(check-container-parent cwho parent)
|
|
(check-callback cwho callback)
|
|
(check-string cwho init-value)
|
|
(check-style cwho
|
|
req-styles
|
|
(append
|
|
(if choices? null '(hscroll password))
|
|
'(vertical-label horizontal-label deleted))
|
|
(remq combo-flag style))
|
|
(check-font cwho font))
|
|
|
|
(define text-field%
|
|
(class100*/kw basic-control% ()
|
|
[(label parent [callback (lambda (b e) (void))] [init-value ""] [style '(single)])
|
|
control%-keywords]
|
|
(sequence
|
|
(check-text-field-args '(constructor text-field)
|
|
label
|
|
#f #f
|
|
parent callback init-value
|
|
style '(single multiple)
|
|
font))
|
|
(private-field
|
|
[wx #f])
|
|
(public
|
|
[get-editor (entry-point (lambda () (send wx get-editor)))]
|
|
[get-value (lambda () (send wx get-value))] ; note: wx method doesn't expect as-entry
|
|
[set-value (entry-point
|
|
(lambda (v)
|
|
(check-string '(method text-control<%> set-value) v)
|
|
(send wx set-value v)))])
|
|
(sequence
|
|
;; Technically a bad way to change margin defaults, since it's
|
|
;; implemented with an update after creation:
|
|
(when (eq? horiz-margin no-val) (set! horiz-margin 2))
|
|
(when (eq? vert-margin no-val) (set! vert-margin 2))
|
|
(as-entry
|
|
(lambda ()
|
|
(super-init (lambda ()
|
|
(set! wx (make-object wx-text-field% this this
|
|
(mred->wx-container parent) (wrap-callback callback)
|
|
label init-value
|
|
(if (memq combo-flag style)
|
|
(cons 'combo (remq combo-flag style))
|
|
style)
|
|
(no-val->#f font)))
|
|
wx)
|
|
(lambda ()
|
|
(let ([cwho '(constructor text-field)])
|
|
(check-container-ready cwho parent)))
|
|
label parent callback ibeam))))))
|
|
|
|
(define combo-field%
|
|
(class100*/kw text-field% ()
|
|
[(label choices parent [callback (lambda (b e) (void))] [init-value ""] [style '()])
|
|
control%-keywords]
|
|
(inherit set-value popup-menu get-size focus get-editor)
|
|
(sequence
|
|
(check-text-field-args '(constructor combo-field)
|
|
label
|
|
#f choices
|
|
parent callback init-value
|
|
style #f
|
|
font))
|
|
(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)))]
|
|
[get-menu (lambda () menu)]
|
|
[append (lambda (item)
|
|
(check-label-string '(method combo-field% append) item)
|
|
(make-object menu-item% item menu
|
|
(lambda (i e)
|
|
(focus)
|
|
(set-value item)
|
|
(let ([e (get-editor)])
|
|
(send e set-position 0 (send e last-position)))
|
|
(send (as-entry (lambda () (mred->wx this)))
|
|
command
|
|
(make-object wx:control-event% 'text-field)))))])
|
|
(override
|
|
[on-subwindow-event (lambda (w e)
|
|
(and (send e button-down?)
|
|
(let-values ([(cw) (send (mred->wx this) get-canvas-width)])
|
|
(and ((send e get-x) . >= . (- cw side-combo-width))
|
|
(begin
|
|
(on-popup e)
|
|
#t)))))])
|
|
(private-field
|
|
[menu (new popup-menu% [font font])])
|
|
(sequence
|
|
(for-each (lambda (item)
|
|
(append item))
|
|
choices)
|
|
(super-init label parent callback init-value (list* combo-flag 'single style))))))
|