337 lines
13 KiB
Racket
337 lines
13 KiB
Racket
(module wxtextfield racket/base
|
|
(require racket/class
|
|
(prefix-in wx: "kernel.rkt")
|
|
(prefix-in wx: "wxme/text.rkt")
|
|
(prefix-in wx: racket/snip/private/snip)
|
|
(prefix-in wx: "wxme/editor-canvas.rkt")
|
|
"lock.rkt"
|
|
"const.rkt"
|
|
"check.rkt"
|
|
"helper.rkt"
|
|
"gdi.rkt"
|
|
"wx.rkt"
|
|
"wxwindow.rkt"
|
|
"wxitem.rkt"
|
|
"wxcanvas.rkt"
|
|
"wxpanel.rkt"
|
|
"editor.rkt"
|
|
"mrpopup.rkt")
|
|
|
|
(provide (protect-out wx-text-field%))
|
|
|
|
(define no-pen (send wx:the-pen-list find-or-create-pen "white" 1 'transparent))
|
|
(define black-brush (send wx:the-brush-list find-or-create-brush "black" 'solid))
|
|
|
|
(define password-string-snip%
|
|
(class wx:string-snip%
|
|
(inherit get-count
|
|
get-style
|
|
get-text)
|
|
(super-new)
|
|
|
|
(define delta 3)
|
|
(define hdelta 2)
|
|
(define (get-size)
|
|
(max 4 (send (send (get-style) get-font) get-point-size)))
|
|
|
|
(define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f])
|
|
(let ([s (get-size)])
|
|
(when w (set-box! w (* (max 1.0 (- s hdelta hdelta)) (get-count))))
|
|
(when h (set-box! h (+ s 2.0)))
|
|
(when descent (set-box! descent 1.0))
|
|
(when space (set-box! space 1.0))
|
|
(when lspace (set-box! lspace 0.0))
|
|
(when rspace (set-box! rspace 0.0))))
|
|
(define/override (partial-offset dc x y pos)
|
|
(let ([s (get-size)])
|
|
(* (max 1.0 (- s hdelta hdelta)) pos)))
|
|
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
|
(let ([s (get-size)]
|
|
[b (send dc get-brush)]
|
|
[p (send dc get-pen)]
|
|
[m (send dc get-smoothing)])
|
|
(send dc set-pen no-pen)
|
|
(send dc set-brush black-brush)
|
|
(send dc set-smoothing 'aligned)
|
|
(for/fold ([x x]) ([i (in-range (get-count))])
|
|
(send dc draw-ellipse (- (+ x delta) hdelta) (+ y delta 1) (- s delta delta) (- s delta delta))
|
|
(+ x (- s hdelta hdelta)))
|
|
(send dc set-pen p)
|
|
(send dc set-brush b)
|
|
(send dc set-smoothing m)))
|
|
(define/override (split pos first second)
|
|
(let ([a (new password-string-snip%)]
|
|
[b (new password-string-snip%)]
|
|
[c (get-count)])
|
|
(send a insert (get-text 0 pos) pos)
|
|
(send b insert (get-text pos c) (- c pos))
|
|
(set-box! first a)
|
|
(set-box! second b)))))
|
|
|
|
(define text-field-text%
|
|
(class text%
|
|
(init cb ret-cb control set-cb-mgrs! record-text pw?)
|
|
(rename-super [super-on-char on-char])
|
|
(inherit get-text last-position set-max-undo-history get-flattened-text)
|
|
(define return-cb ret-cb)
|
|
(define password? pw?)
|
|
(define block-callback 1)
|
|
(define callback
|
|
(lambda (type)
|
|
(as-exit (lambda () (record-text (get-flattened-text))))
|
|
(when (zero? block-callback)
|
|
(let ([e (make-object wx:control-event% type)])
|
|
(as-exit (lambda ()
|
|
(cb control e)))))))
|
|
(override*
|
|
[on-char
|
|
(entry-point
|
|
(lambda (e)
|
|
(let ([c (send e get-key-code)])
|
|
(unless (and (or (eq? c #\return)
|
|
(eq? c #\newline)
|
|
(eq? c 'numpad-enter))
|
|
return-cb
|
|
(return-cb (lambda () (callback 'text-field-enter) #t)))
|
|
(as-exit (lambda () (super-on-char e)))))))]
|
|
[on-new-string-snip
|
|
(lambda ()
|
|
(if password?
|
|
(new password-string-snip%)
|
|
(super on-new-string-snip)))])
|
|
(augment*
|
|
[after-insert
|
|
(lambda args
|
|
(as-entry
|
|
(lambda ()
|
|
(callback 'text-field))))]
|
|
[after-delete
|
|
(lambda args
|
|
(as-entry
|
|
(lambda ()
|
|
(callback 'text-field))))])
|
|
(set-cb-mgrs!
|
|
(lambda (thunk)
|
|
(dynamic-wind
|
|
(lambda () (set! block-callback (add1 block-callback)))
|
|
thunk
|
|
(lambda () (set! block-callback (sub1 block-callback)))))
|
|
(lambda ()
|
|
(set! block-callback 0)))
|
|
(super-make-object)
|
|
(set-max-undo-history 'forever)))
|
|
|
|
(define wx-text-editor-canvas%
|
|
(class* wx-editor-canvas% (wx-text-editor-canvas<%>)
|
|
(init mred proxy control parent style)
|
|
(super-make-object mred proxy parent -1 -1 100 30 #f style 100 #f)))
|
|
|
|
(define wx-text-field%
|
|
(class wx-horizontal-panel%
|
|
(init mred proxy parent fun label value style _font)
|
|
(send (send parent get-top-level) begin-container-sequence)
|
|
;; Make text field first because we'll have to exit
|
|
;; for keymap initializer
|
|
(define func fun)
|
|
(define font (or _font normal-control-font))
|
|
(define without-callback #f)
|
|
(define callback-ready #f)
|
|
(define e
|
|
(make-object text-field-text%
|
|
func
|
|
(lambda (do-cb)
|
|
(if multi?
|
|
#f
|
|
(do-cb)))
|
|
this
|
|
(lambda (wc cr)
|
|
(set! without-callback wc)
|
|
(set! callback-ready cr))
|
|
(lambda (t)
|
|
(send c set-combo-text t))
|
|
(memq 'password style)))
|
|
(as-exit
|
|
(lambda ()
|
|
((current-text-keymap-initializer) (send e get-keymap))))
|
|
(inherit alignment stretchable-in-y area-parent
|
|
get-min-size set-min-width set-min-height
|
|
spacing)
|
|
(rename-super [super-place-children place-children])
|
|
(public*
|
|
[command (lambda (e) ; No entry/exit needed
|
|
(check-instance '(method text-field% command) wx:control-event% 'control-event% #f e)
|
|
(func this e)
|
|
(void))]
|
|
|
|
[get-editor (lambda () e)]
|
|
|
|
[get-value (lambda () (send e get-text))] ; note: not as-entry when called
|
|
[set-value (lambda (v) (without-callback
|
|
(lambda () (send e insert v 0 (send e last-position)))))]
|
|
|
|
[set-label (lambda (str) (when l (send l set-label str)))]
|
|
[get-canvas-width (lambda ()
|
|
(let ([tw (box 0)])
|
|
(send c get-size tw (box 0))
|
|
(unbox tw)))]
|
|
|
|
[set-field-background (lambda (col)
|
|
(send c set-canvas-background col))]
|
|
[get-field-background (lambda ()
|
|
(send c get-canvas-background))])
|
|
(override*
|
|
;; These might be called before we are fully initialized
|
|
|
|
[set-cursor (lambda (c) (send e set-cursor c #t))]
|
|
[set-focus (lambda () (when (object? c) (send c set-focus)))]
|
|
|
|
[place-children
|
|
(lambda (children-info width height)
|
|
(if (null? children-info)
|
|
null
|
|
(let ([r (super-place-children children-info width height)])
|
|
(if horiz?
|
|
;; Line up label right with text:
|
|
(cons (list* (caar r) (+ (cadar r) dy) (cddar r))
|
|
(cdr r))
|
|
r))))])
|
|
(super-make-object #f proxy parent (if (memq 'deleted style) '(deleted) null) #f)
|
|
(unless (memq 'deleted style)
|
|
(send (area-parent) add-child this))
|
|
(define multi? (memq 'multiple style))
|
|
(define horiz?
|
|
(cond
|
|
[(memq 'vertical-label style) #f]
|
|
[(memq 'horizontal-label style) #t]
|
|
[else (eq? (send (send parent get-window) get-label-position) 'horizontal)]))
|
|
(define dy 0)
|
|
(define p
|
|
(if horiz?
|
|
this
|
|
(let ([p (make-object wx-vertical-pane% #f proxy this null #f)])
|
|
(send p skip-subwindow-events? #t)
|
|
(send (send p area-parent) add-child p)
|
|
p)))
|
|
(alignment 'left 'top)
|
|
(unless horiz? (send p alignment 'left 'top))
|
|
(unless multi? (stretchable-in-y #f))
|
|
;; For Windows:
|
|
; (wx:set-combo-box-font font)
|
|
(spacing 3)
|
|
(define l (and label
|
|
(make-object wx-message% #f proxy p label -1 -1 null font)))
|
|
(define combo-callback #f)
|
|
(define c
|
|
(make-object (class wx-text-editor-canvas%
|
|
(define/override (on-combo-select i)
|
|
(let ([len (length callbacks)])
|
|
(when (< -1 i len)
|
|
((list-ref callbacks (- len i 1))))))
|
|
(super-new))
|
|
#f proxy this p
|
|
(append
|
|
'(control-border)
|
|
(if (memq 'combo style)
|
|
'(combo)
|
|
null)
|
|
(if multi?
|
|
(if (memq 'hscroll style)
|
|
null
|
|
'(hide-hscroll))
|
|
'(hide-vscroll hide-hscroll)))))
|
|
(define callbacks null)
|
|
(override*
|
|
[pre-on-event (lambda (w e)
|
|
(or (super pre-on-event w e)
|
|
(and combo-callback
|
|
(eq? w c)
|
|
(send e button-down?)
|
|
(let ([w (box 0)]
|
|
[h (box 0)])
|
|
(send c get-client-size w h)
|
|
(not (and (<= 0 (send e get-x) (unbox w))
|
|
(<= 0 (send e get-y) (unbox h)))))
|
|
(begin
|
|
(do-popup-callback)
|
|
#t))))])
|
|
(private*
|
|
[do-popup-callback (lambda ()
|
|
(wx:queue-callback (lambda ()
|
|
(when (send c is-enabled-to-root?)
|
|
(combo-callback)
|
|
(send c popup-combo)))
|
|
wx:middle-queue-key))])
|
|
(public*
|
|
[set-on-popup (lambda (proc)
|
|
(set! combo-callback proc)
|
|
(send c set-on-popup (lambda () (do-popup-callback))))]
|
|
[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))
|
|
#t))])
|
|
(send c skip-subwindow-events? #t)
|
|
(when l
|
|
(send l skip-subwindow-events? #t)
|
|
(send l x-margin 0))
|
|
(send c set-x-margin 2)
|
|
(send c set-y-margin 2)
|
|
(send e set-line-spacing 0)
|
|
(send e set-paste-text-only #t)
|
|
(send e auto-wrap (and multi? (not (memq 'hscroll style))))
|
|
(let ([f font]
|
|
[s (send (send e get-style-list) find-named-style "Standard")])
|
|
(send s set-delta (font->delta f)))
|
|
(send c set-editor e)
|
|
(send c set-line-count (if multi? 3 1))
|
|
(unless multi? (send c set-single-line))
|
|
|
|
(when (and l horiz?)
|
|
;; Minimize vertical space around the label:
|
|
(send l y-margin 0)
|
|
;; Find amount to drop label down to line up the baselines:
|
|
(let ([wbox (box 0)]
|
|
[hbox (box 0)]
|
|
[ybox (box 0)]
|
|
[abox (box 0)])
|
|
;; To bottom of first line
|
|
(send (send e get-admin) get-dc #f ybox)
|
|
(set! dy (+ (abs (unbox ybox)) (send e line-location 0 #f)))
|
|
|
|
;; Add diff for client size
|
|
(send c get-client-size wbox hbox)
|
|
(let ([d (- (send c get-height) (unbox hbox))])
|
|
(set! dy (+ dy (quotient d 2))))
|
|
|
|
;; Subtract descent of canvas-drawn text
|
|
(let ([font (send (send (send e get-style-list) find-named-style "Standard") get-font)])
|
|
(send c get-text-extent "hi" wbox hbox ybox #f font)
|
|
(set! dy (- dy (unbox ybox))))
|
|
|
|
;; Subtract ascent of label
|
|
(send l get-text-extent "hi" wbox hbox ybox abox font)
|
|
(set! dy (- dy (- (unbox hbox) (unbox ybox))))
|
|
|
|
;; Subtract space above label
|
|
(set! dy (- dy (quotient (- (send l get-height) (unbox hbox)) 2)))
|
|
|
|
;; Exact
|
|
(set! dy (inexact->exact dy))))
|
|
|
|
(when value
|
|
(set-value value)
|
|
(unless (string=? value "")
|
|
(let* ([ew (box 0)]
|
|
[cw (box 0)]
|
|
[tw (box 0)])
|
|
(send e get-extent ew #f)
|
|
(send (send e get-admin) get-view #f #f cw #f)
|
|
(send c get-size tw (box 0))
|
|
(let ([new-min-width (+ (unbox ew) (- (unbox tw) (unbox cw)))])
|
|
(send c set-min-width (inexact->exact new-min-width))))))
|
|
(let ([min-size (get-min-size)])
|
|
(set-min-width (car min-size))
|
|
(set-min-height (cadr min-size)))
|
|
(send (send parent get-top-level) end-container-sequence)
|
|
(callback-ready))))
|