(module wxtextfield mzscheme
  (require (lib "class.ss")
	   (lib "class100.ss")
	   (prefix wx: "kernel.ss")
	   "lock.ss"
	   "const.ss"
	   "check.ss"
	   "helper.ss"
	   "gdi.ss"
	   "wx.ss"
	   "wxwindow.ss"
	   "wxitem.ss"
	   "wxcanvas.ss"
	   "wxpanel.ss"
	   "editor.ss"
	   "mrpopup.ss")

  (provide (protect wx-text-field%))

  (define text-field-text% 
    (class100 text% (cb ret-cb control set-cb-mgrs!)
      (rename [super-on-char on-char])
      (inherit get-text last-position)
      (private-field
       [return-cb ret-cb])
      (private-field
       [block-callback 1]
       [callback
	(lambda (type)
	  (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))
			   return-cb
			   (return-cb (lambda () (callback 'text-field-enter) #t)))
		(as-exit (lambda () (super-on-char e)))))))])
      (augment
       [after-insert
	(lambda args
	  (as-entry
	   (lambda ()
	     (callback 'text-field))))]
       [after-delete
	(lambda args
	  (as-entry
	   (lambda ()
	     (callback 'text-field))))])
      (sequence
	(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-init))))
  
  (define wx-text-editor-canvas% 
    (class100* wx-editor-canvas% (wx-text-editor-canvas<%>) (mred proxy control parent style)
      (sequence
	(super-init mred proxy parent -1 -1 100 30 #f style 100 #f))))

  (define wx-text-field%
    (class100 wx-horizontal-panel% (mred proxy parent fun label value style _font)
      ;; Make text field first because we'll have to exit
      ;;  for keymap initializer
      (private-field
       [func fun]
       [font (or _font normal-control-font)]
       [without-callback #f]
       [callback-ready #f]
       [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)))])
      (sequence
	(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)
      (rename [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)))])
      (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))))])
      (sequence
	(super-init #f proxy parent (if (memq 'deleted style) '(deleted) null))
	(unless (memq 'deleted style)
	  (send (area-parent) add-child this)))
      (private-field
       [multi? (memq 'multiple style)]
       [horiz? (cond
		[(memq 'vertical-label style) #f]
		[(memq 'horizontal-label style) #t]
		[else (eq? (send (send parent get-window) get-label-position) 'horizontal)])]
       [dy 0]
       [p (if horiz?
	      this
	      (let ([p (make-object wx-vertical-pane% #f proxy this null)])
		(send (send p area-parent) add-child p)
		p))])
      (sequence
	(alignment 'left 'top)
	(unless horiz? (send p alignment 'left 'top))
	(unless multi? (stretchable-in-y #f))
	;; For Windows:
	(wx:set-combo-box-font font))
      (private-field
       [l (and label
	       (make-object wx-message% #f proxy p label -1 -1 null font))]
       [c (make-object wx-text-editor-canvas% #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))))])
      (sequence
	(when l
	  (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 (let ([d (font->delta f)])
			      (if (memq 'password style)
				  (begin
				    (send d set-face #f)
				    (send d set-family 'modern)
				    (send d set-delta-foreground "darkgray")
				    (send d set-delta-background "darkgray"))
				  d))))
	(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)
	    (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)))
	(callback-ready)))))