137 lines
3.6 KiB
Scheme
137 lines
3.6 KiB
Scheme
|
|
(module text-field mzscheme
|
|
(require (prefix mred: mred)
|
|
mzlib/class
|
|
mzlib/file
|
|
mzlib/pretty
|
|
mzlib/etc
|
|
mzlib/list
|
|
"utils.ss"
|
|
"base.ss"
|
|
"feature.ss")
|
|
|
|
(define gb:make-text-initial-snip%
|
|
(lambda (cl)
|
|
(class cl
|
|
(inherit gb-need-recalc-size get-style)
|
|
(private-field
|
|
[initial "value"])
|
|
(public*
|
|
[get-initial (lambda () initial)]
|
|
[get-initial-size
|
|
(lambda (dc)
|
|
(let-values ([(w h d a) (send dc get-text-extent initial
|
|
(send (get-style) get-font))])
|
|
(values w h)))]
|
|
|
|
[initial-install
|
|
(lambda (i)
|
|
(set! initial i))])
|
|
(override*
|
|
[get-frame%
|
|
(lambda ()
|
|
(class (super get-frame%)
|
|
(inherit-field controls)
|
|
(super-new)
|
|
(private-field
|
|
[initial-text
|
|
(make-one-line/callback-edit controls "Initial:"
|
|
(lambda (txt)
|
|
(set! initial txt)
|
|
(gb-need-recalc-size))
|
|
initial)])))]
|
|
|
|
[copy
|
|
(lambda ()
|
|
(let ([o (super copy)])
|
|
(send o initial-install initial)
|
|
o))]
|
|
[write
|
|
(lambda (stream)
|
|
(super write stream)
|
|
(send stream put (string->bytes/utf-8 initial)))]
|
|
[read
|
|
(lambda (stream version)
|
|
(super read stream version)
|
|
(initial-install ((get-bytes->string version) (send stream get-bytes))))])
|
|
(super-new))))
|
|
|
|
(define gb:make-text-hscroll-checkable-snip%
|
|
(lambda (cl)
|
|
(class (gb:make-boolean-configure-snip% cl 'hscroll "Horizontal Scroll" #f
|
|
void
|
|
(lambda (f snip)
|
|
(send (send f find-control 'hscroll)
|
|
enable
|
|
(send snip get-tagged-value 'multi))))
|
|
(inherit get-tagged-value)
|
|
(override*
|
|
[gb-get-style
|
|
(lambda ()
|
|
(append
|
|
(if (get-tagged-value 'hscroll)
|
|
'(hscroll)
|
|
null)
|
|
(super gb-get-style)))])
|
|
(super-new))))
|
|
|
|
(define gb:make-text-snip%
|
|
(lambda (cl cn)
|
|
(class cl
|
|
(inherit-field w h)
|
|
(inherit get-initial-size get-initial
|
|
get-callback-names get-multi
|
|
get-label)
|
|
(private-field
|
|
[margin 2])
|
|
(override*
|
|
[get-classname (lambda () cn)]
|
|
[init-name (lambda () (new-name "text"))]
|
|
[init-x-stretch? (lambda () #t)]
|
|
[get-label-top-margin (lambda () margin)]
|
|
[get-min-body-size
|
|
(lambda (dc)
|
|
(let-values ([(w h) (get-initial-size dc)])
|
|
(values (+ w (* 2 margin))
|
|
(+ (* h (if (get-multi) 3 1))
|
|
(* 2 margin)))))]
|
|
[draw-body
|
|
(lambda (dc x y w h)
|
|
(send dc draw-rectangle x y w h)
|
|
(send dc draw-text (get-initial) (+ x margin) (+ y margin)))]
|
|
[get-callback-kinds (lambda ()
|
|
(list "-change-callback" "-return-callback" "-focus-callback"))]
|
|
[gb-get-default-class (lambda () 'text-field%)]
|
|
[gb-get-style (lambda () (append
|
|
(super gb-get-style)
|
|
(if (get-multi) '(multiple) '(single))))]
|
|
[gb-get-unified-callback
|
|
(lambda ()
|
|
(let-values ([(change return focus)
|
|
(apply values (get-callback-names))])
|
|
`(lambda (b e)
|
|
(let ([t (send e get-event-type)])
|
|
(cond
|
|
[(eq? t 'text-field) (,change b e)]
|
|
[(eq? t 'text-field-enter) (,return b e)]
|
|
[else (,focus b e)])))))]
|
|
[gb-instantiate-arguments
|
|
(lambda ()
|
|
(cons
|
|
`[init-value ,(get-initial)]
|
|
(super gb-instantiate-arguments)))])
|
|
(super-new))))
|
|
|
|
(define gb:text-snip% (gb:make-text-snip%
|
|
(gb:make-text-hscroll-checkable-snip%
|
|
(gb:make-multi-checkable-snip%
|
|
(gb:make-text-initial-snip%
|
|
(gb:make-callback-snip%
|
|
(gb:make-text-labelled-snip% gb:atomic-snip%
|
|
"Text")))))
|
|
"gb:text"))
|
|
|
|
(register-class gb:text-snip% "gb:text")
|
|
|
|
(provide gb:text-snip%))
|