(module wxcanvas mzscheme
  (require mzlib/class
	   mzlib/class100
	   (prefix wx: "kernel.ss")
	   (prefix wx: "wxme/text.ss")
	   (prefix wx: "wxme/editor-canvas.ss")
	   "lock.ss"
	   "helper.ss"
	   "wx.ss"
	   "wxwindow.ss"
	   "wxitem.ss")

  (provide (protect make-canvas-glue%
		    wx-canvas%
		    wx-editor-canvas%))

  (define (make-canvas-glue% default-tabable? %) ; implies make-window-glue%
    (class100 (make-window-glue% %) (mred proxy . args)
      (inherit get-mred get-top-level clear-margins)
      (public
	[do-on-char (lambda (e) (super on-char e))]
	[do-on-event (lambda (e) (super on-event e))]
	[do-on-scroll (lambda (e) (super on-scroll e))]
	[do-on-paint (lambda () (super on-paint))])
      (private-field
       [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))))]
        [set-on-popup (lambda (proc) (set! on-popup-callback proc))])
      (override
        [gets-focus? (lambda () tabable?)]
        [handles-key-code
         (lambda (code alpha? meta?)
           (if default-tabable?
               (super handles-key-code code alpha? meta?)
               (or meta? (not tabable?))))])
      (private
        [clear-and-on-paint
         (lambda (mred)
           (clear-margins)
           (send mred on-paint))])
      (override
	[on-char (entry-point
		  (lambda (e)
		    (let ([mred (get-mred)])
		      (if mred
			  (as-exit (lambda () (send mred on-char e)))
			  (super on-char e)))))]
	[on-event (entry-point
		   (lambda (e)
		     (let ([mred (get-mred)])
		       (if mred
			   (as-exit (lambda () (send mred on-event e)))
			   (as-exit (lambda () (super on-event e)))))))]
        ;; only called for canvas%, not editor-canvas%:
	[on-scroll (entry-point
		    (lambda (e)
		      (let ([mred (get-mred)])
			(if mred
			    (send mred on-scroll e)
			    (as-exit (lambda () (super on-scroll e)))))))]
	[on-paint (entry-point
		   (lambda ()
		     (let ([mred (get-mred)])
		       (if mred
			   (as-exit (lambda () (clear-and-on-paint mred)))
			   (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% 
    (make-canvas-glue%
     #f
     (class100 (make-control% wx:canvas% 0 0 #t #t) (parent x y w h style gl-config)
       (inherit get-top-level)
       (public
         [clear-margins (lambda () (void))])
       (sequence
	 (super-init style parent x y w h (cons 'deleted style) "canvas" gl-config)
         (unless (memq 'deleted style)
           (send (get-top-level) show-control this #t))))))

  (define (make-editor-canvas% %)
    (class100 % (parent x y w h name style spp init-buffer)
      (inherit get-editor force-redraw
	       call-as-primary-owner min-height get-size
	       get-hard-minimum-size set-min-height
               get-top-level)
      (private-field
       [fixed-height? #f]
       [fixed-height-lines 0]
       [orig-hard #f]
       [single-line-canvas? #f]
       [tabable? #f])
      (override
	[on-container-resize (lambda ()
			       (let ([edit (get-editor)])
				 (when edit
				   (as-exit (lambda () (send edit on-display-size-when-ready))))))]
	[on-scroll-on-change (lambda ()
			       (queue-window-callback
				this
				(lambda ()
				  (let ([edit (get-editor)])
				    (when edit
				      (send edit on-display-size-when-ready))))))]
	[on-set-focus
	 (entry-point
	  (lambda ()
	    (as-exit (lambda () (super on-set-focus)))
	    (let ([m (get-editor)])
	      (when m 
		(let ([mred (wx->mred this)])
		  (when mred
		    (as-exit (lambda () (send m set-active-canvas mred)))))))))]
	[set-editor
	 (letrec ([l (case-lambda
		      [(edit) (l edit #t)]
		      [(edit redraw?)
		       (let ([old-edit (get-editor)])
                         ;; An exception here means we end up in a bad state:
			 (as-exit (lambda () 
                                    ;; set-editor can invoke callbacks:
                                    (super set-editor edit redraw?)))
			 
			 (let ([mred (wx->mred this)])
			   (when mred
			     (when old-edit
			       (as-exit
				(lambda () (send old-edit remove-canvas mred))))
			     (when edit
			       (as-exit
				(lambda () (send edit add-canvas mred))))))

			 (update-size)
			 
			 ;; force-redraw causes on-container-resize to be called,
			 ;;  but only when the size of the canvas really matters
			 ;;  (i.e., when it is shown)
			 (force-redraw))])])
	   l)]
	[handles-key-code 
	 (lambda (x alpha? meta?)
	   (case x
	     [(#\tab #\return escape) (and (not tabable?)
					   (not single-line-canvas?))]
	     [else (not meta?)]))]


	[popup-for-editor (entry-point
			   (lambda (e m)
			     (let ([mwx (mred->wx m)])
			       (and (send mwx popup-grab e)
				    (as-exit (lambda () (send m on-demand) #t))
				    mwx))))])
      (public
	[set-tabable (lambda (on?) (set! tabable? on?))]
	[is-tabable? (lambda () tabable?)]
	[set-single-line (lambda () (set! single-line-canvas? #t))]
	[is-single-line? (lambda () single-line-canvas?)]
	[set-line-count (lambda (n)
			  (if n
			      (begin
				(unless orig-hard
				  (let-values ([(hmw hmh) (get-hard-minimum-size)])
				    (set! orig-hard hmh)))
				(set! fixed-height? #t)
				(set! fixed-height-lines n))
			      (when orig-hard
				(set! fixed-height? #f)
				(set-min-height orig-hard)))
			  (update-size))]
	[get-line-count (lambda () (and fixed-height? fixed-height-lines))]
	[update-size
	 (lambda ()
	   (let ([edit (get-editor)])
	     (when (and edit fixed-height?)
	       (let* ([top (if (is-a? edit wx:text%)
			       (send edit line-location 0 #t)
			       0)]
		      [bottom (if (is-a? edit wx:text%)
				  (send edit line-location 0 #f)
				  14)]
		      [height (- bottom top)])
		 (let* ([ch (box 0)]
			[h (box 0)])
		   (call-as-primary-owner
		    (lambda ()
		      (send (send edit get-admin) 
			    get-view #f #f #f ch)))
		   (get-size (box 0) h)
		   (let ([new-min-height (+ (* fixed-height-lines height) 
					    (- (unbox h) (unbox ch)))])
		     (set-min-height (inexact->exact (round new-min-height)))
		     (force-redraw)))))))])
      (override
	[set-y-margin (lambda (m)
			(super set-y-margin m)
			(when fixed-height? (update-size)))])
      
      (sequence
	(super-init style parent x y w h (or name "") (cons 'deleted style) spp init-buffer)
        (unless (memq 'deleted style)
          (send (get-top-level) show-control this #t))
	(when init-buffer
	  (let ([mred (wx->mred this)])
	    (when mred
	      (as-exit (lambda () (send init-buffer add-canvas mred)))))))))

  (define wx-editor-canvas% 
    (class (make-canvas-glue%
            #t
            (make-editor-canvas% (make-control% wx:editor-canvas%
                                                0 0 #t #t)))
      (inherit editor-canvas-on-scroll
               set-no-expose-focus)
      (define/override (on-scroll e)
        (editor-canvas-on-scroll))
      (super-new)
      #;(set-no-expose-focus))))
