(module canvas mzscheme
  (require (lib "unitsig.ss")
	   (lib "class.ss")
	   "sig.ss"
	   (lib "mred-sig.ss" "mred"))

  (provide canvas@)

  (define canvas@
    (unit/sig framework:canvas^
      (import mred^
	      [preferences : framework:preferences^]
	      [frame : framework:frame^]
              [text : framework:text^])
      
      (rename [-color% color%])
      
      (define basic<%> (interface ((class->interface editor-canvas%))))
      (define basic-mixin
	(mixin ((class->interface editor-canvas%)) (basic<%>)
          (super-new)))
      
      (define color<%> (interface (basic<%>)))
      
      (define color-mixin
        (mixin (basic<%>) (color<%>)
          (define callback (λ (p v) (set-canvas-background v)))
          (super-new)
          (inherit set-canvas-background)
          (set-canvas-background (preferences:get 'framework:basic-canvas-background))
          (preferences:add-callback 'framework:basic-canvas-background callback #t)))
      
      (define delegate<%> (interface (basic<%>)))

      (define delegate-mixin
        (mixin (basic<%>) (delegate<%>)
          (inherit get-top-level-window)
          (define/override (on-superwindow-show shown?)
            (send (send (get-top-level-window) get-delegatee) set-start/end-para #f #f)
            (super on-superwindow-show shown?))
          (super-instantiate ())))
      
      (define info<%> (interface (basic<%>)))
      ;; (basic<%> -> (class (is-a? (send this get-top-level-window) frame:info<%>)))
      (define info-mixin 
	(mixin (basic<%>) (info<%>)
	  (inherit has-focus? get-top-level-window)
	  (define/override (on-focus on?)
            (super on-focus on?)
            (send (get-top-level-window) set-info-canvas (and on? this))
            (when on?
              (send (get-top-level-window) update-info)))
          (define/override (set-editor m)
            (super set-editor m)
            (let ([tlw (get-top-level-window)])
              (when (eq? this (send tlw get-info-canvas))
                (send tlw update-info))))
          
          (super-new)

          (unless (is-a? (get-top-level-window) frame:info<%>)
            (error 'canvas:text-info-mixin
                   "expected to be placed into a frame or dialog implementing frame:info<%>, got: ~e" 
                   (get-top-level-window)))

          (when (has-focus?)
            (send (get-top-level-window) update-info))))

      (define wide-snip<%> (interface (basic<%>)
			     recalc-snips
			     add-wide-snip
			     add-tall-snip))

      (define wide-snip-mixin
	(mixin (basic<%>) (wide-snip<%>)
	  (inherit get-editor)
          (define/private ((update-snip-size width?) s)
            (let* ([width (box 0)]
                   [height (box 0)]
                   [leftm (box 0)]
                   [rightm (box 0)]
                   [topm (box 0)]
                   [bottomm (box 0)]
                   [left-edge-box (box 0)]
                   [top-edge-box (box 0)]
                   [snip-media (send s get-editor)]
                   [edit (get-editor)]        
                   [get-width
                    (let ([bl (box 0)]
                          [br (box 0)])
                      (λ (s)
                        (send edit get-snip-location s bl #f #f)
                        (send edit get-snip-location s br #f #t)
                        (- (unbox br) (unbox bl))))]
                   [calc-after-width
                    (λ (s)
                      (+ 4 ;; this is compensate for an autowrapping bug
                         (let loop ([s s])
                           (cond
                             [(not s) 0]
                             [(member 'hard-newline (send s get-flags)) (get-width s)]
                             [(member 'newline (send s get-flags)) (get-width s)]
                             [else
                              (+ (get-width s)
                                 2 ;; for the caret
                                 (loop (send s next)))]))))])
              (when edit
                (send edit
                      run-after-edit-sequence
                      (λ ()
                        (let ([admin (send edit get-admin)])
                          (send admin get-view #f #f width height)
                          (send s get-margin leftm topm rightm bottomm)
                          
                          
                          ;; when the width is to be maximized and there is a
                          ;; newline just behind the snip, we know that the left
                          ;; edge is zero. Special case for efficiency in the 
                          ;; console printer
                          (let ([fallback
                                 (λ ()
                                   (send edit get-snip-location s left-edge-box top-edge-box))])
                            (cond
                              [(not width?) (fallback)]
                              [(let ([prev (send s previous)])
                                 (and prev
                                      (member 'hard-newline (send prev get-flags))))
                               (set-box! left-edge-box 0)]
                              [else (fallback)]))
                          
                          (if width?
                              (let* ([after-width (calc-after-width (send s next))]
                                     [snip-width (max 0 (- (unbox width)
                                                           (unbox left-edge-box)
                                                           (unbox leftm)
                                                           (unbox rightm)
                                                           after-width
                                                           ;; this two is the space that 
                                                           ;; the caret needs at the right of
                                                           ;; a buffer.
                                                           2))])
                                (send* s 
                                  (set-min-width snip-width)
                                  (set-max-width snip-width))
                                (when snip-media
                                  (send snip-media set-max-width
                                        (if (send snip-media auto-wrap)
                                            snip-width
                                            0))))
                              (let ([snip-height (max 0 (- (unbox height)
                                                           (unbox top-edge-box)
                                                           (unbox topm)
                                                           (unbox bottomm)))])
                                (send* s 
                                  (set-min-height snip-height)
                                  (set-max-height snip-height))))))))))
	  (define/public (recalc-snips)
            (let ([editor (get-editor)])
              (unless (is-a? editor text:wide-snip<%>)
                (error 'recalc-snips "expected a text:wide-snip<%> editor, instead ~e" editor))
              (when (eq? (send editor get-canvas) this)
                (for-each (update-snip-size #t) (send editor get-wide-snips))
                (for-each (update-snip-size #f) (send editor get-tall-snips)))))
	  (define/public (add-wide-snip snip)
            (let ([editor (get-editor)])
              (unless (is-a? editor text:wide-snip<%>)
                (error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor))
              (send editor add-wide-snip snip))
            ((update-snip-size #t) snip))
          (define/public (add-tall-snip snip)
            (let ([editor (get-editor)])
              (unless (is-a? editor text:wide-snip<%>)
                (error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor))
              (send editor add-tall-snip snip))
            ((update-snip-size #f) snip))
	  (define/override (on-size width height)
            (recalc-snips)
            (super on-size width height))
          (super-new)))

      (define basic% (basic-mixin editor-canvas%))
      (define -color% (color-mixin basic%))
      (define info% (info-mixin basic%))
      (define delegate% (delegate-mixin basic%))
      (define wide-snip% (wide-snip-mixin basic%)))))
