(module typecheck mzscheme
  (require
   (lib "class.ss")
   (lib "config.ss" "planet")
   (lib "mred.ss" "mred")
   (lib "list.ss")
   (lib "bitmap-label.ss" "mrlib")
   (lib "framework.ss" "framework")
   (prefix td: "typecheck-defs.ss")
   (prefix ocaml: "util.ss"))
  (provide definitions-text-mixin unit-frame-mixin)
  
  ;; overrides methods that make sure that type annotations go away appropriately.
  ;; adds a begin/end-edit-sequence to the insertion and deletion
  ;;  to ensure that the on-change method isn't called until after
  ;;  the annotations are cleared.
  (define (definitions-text-mixin drscheme:unit:definitions-text<%>)
    (mixin (drscheme:unit:definitions-text<%> scheme:text<%> ocaml:definitions-text<%>) ()
      (inherit
        begin-edit-sequence
        end-edit-sequence
        get-canvas
        get-end-position
        get-start-position
        get-top-level-window
        highlight-range
        scroll-to-position)
      
      ;; set at mode begin
      (define ocaml:in-typecheck #f)
      (define ocaml:type-annotations #f)
      
      ;; set often
      (define ocaml:current-annotation #f)
      (define ocaml:current-annotation-unhighlight-thunk #f)
      
      (super-new)
      
      (define/augment (ocaml:reset-highlighting)
        (inner (void) ocaml:reset-highlighting)
        (when ocaml:current-annotation-unhighlight-thunk
          (ocaml:current-annotation-unhighlight-thunk)
          (set! ocaml:current-annotation-unhighlight-thunk #f))
        (set! ocaml:current-annotation #f)
	(when (and (get-canvas) (send (get-canvas) get-top-level-window))
	  (send (send (get-canvas) get-top-level-window)
		open-status-line 'ocaml:type-check)
	  (send (send (get-canvas) get-top-level-window)
		update-status-line 'ocaml:type-check #f)))
      
      (define (ocaml:jump-to-annotation pos)
        (define best-annot
          (hash-table-get
           ocaml:type-annotations
           pos
           (λ () #f)))
        (cond
          [(not best-annot) (ocaml:reset-highlighting)]
          [(eq? best-annot ocaml:current-annotation) (void)]
          [else
           (ocaml:reset-highlighting)
           (set! ocaml:current-annotation best-annot)
           (send (send (get-canvas) get-top-level-window)
                 update-status-line 'ocaml:type-check (td:annot-type best-annot))
           (set! ocaml:current-annotation-unhighlight-thunk
                 (highlight-range
                  (td:annotation-start-char best-annot)
                  (td:annotation-end-char best-annot)
                  (make-object color% "PaleGreen")))]))
      
      #;(define/public (ocaml:get-type-at-selection)
          (ocaml:jump-to-enclosing-annotation
           (get-start-position)
           (get-end-position)))
      
      (define/augment (on-delete start len)
        (begin-edit-sequence)
        (inner (void) on-delete start len))
      (define/augment (after-delete start len)
        (inner (void) after-delete start len)
        (ocaml:clean-up)
        (end-edit-sequence))
      
      (define/augment (on-insert start len)
        (begin-edit-sequence)
        (inner (void) on-insert start len))
      (define/augment (after-insert start len)
        (inner (void) after-insert start len)
        (ocaml:clean-up)
        (end-edit-sequence))
      
      (define/override (on-event event)
        (when ocaml:type-annotations
          (cond
            [(or (send event moving?) (send event leaving?))
             (let-values ([(pos text) (ocaml:get-pos/text event this)])
               (when pos
                 (ocaml:jump-to-annotation pos)))]
            [else #f]))
        (super on-event event))
      
      (define/public (ocaml:set-typecheck annots)
        (ocaml:clean-up)
        (set! ocaml:in-typecheck #t)
        (set! ocaml:type-annotations annots))
      
      (define/augment (ocaml:clean-up)
        (inner (void) ocaml:clean-up)
        (when ocaml:in-typecheck
          #;(keymap:remove-chained-keymap this td:keymap)
          (set! ocaml:in-typecheck #f)
          (set! ocaml:type-annotations #f)
          (set! ocaml:current-annotation #f)
          (ocaml:reset-highlighting)))))
  
  (define (unit-frame-mixin drscheme:unit:frame<%> get-settings-thunk get-lang)
    (mixin (drscheme:unit:frame<%> ocaml:unit:frame<%>) ()
      
      (inherit
        get-button-panel 
        get-definitions-canvas 
        get-definitions-text
        get-interactions-text
        get-current-tab
        open-status-line
        close-status-line
        update-status-line
        ensure-rep-hidden
        save)
      
      (super-new)
      
      (define ocaml:typecheck-button-parent-panel
        (new horizontal-panel%
             [parent (get-button-panel)]
             [stretchable-width #f]
             [stretchable-height #f]))
      (define ocaml:typecheck-button
        (new button%
             [label
              ((bitmap-label-maker
                "Save and Check Types"
                (build-path (CACHE-DIR) "abromfie" "drocaml.plt" "1" "0" "icons" "type.png")) this)]
             [parent ocaml:typecheck-button-parent-panel]
             [callback (λ (button evt) (save) (ocaml:typecheck-button-callback (send button get-parent)))]))
      
      (define/public (ocaml:typecheck-button-callback parent)
        (define defs (get-definitions-text))
        (define the-settings (get-settings-thunk))
        (when (send ocaml:typecheck-button is-enabled?)
          (if (ocaml:lang-settings? the-settings)
              (begin
                (open-status-line 'ocaml:type-check)
                (update-status-line 'ocaml:type-check
                                    (format "Type checking for ~a in progress..." 
                                            (send defs get-filename)))
                (let
                    ([annots
                      (td:compile-and-get-dtypes
                       parent
                       (send defs get-filename)
                       the-settings)])
                  (if annots
                      (send defs ocaml:set-typecheck annots)
                      (begin
                        (update-status-line 'ocaml:type-check #f)
                        (message-box
                         "Error"
                         "There was an error while typechecking your program."))))
                (ensure-rep-hidden)
                #;(send (send defs get-keymap) chain-to-keymap td:keymap #t))
              (message-box
               "Wrong language"
               "You can only use the typechecker with the OCaml language."))))
      
      (define/augment (ocaml:update-button-visibility/settings settings)
        (inner (void) ocaml:update-button-visibility/settings settings)
        (when (object? ocaml:typecheck-button-parent-panel)
          (let ([visible? (send (get-lang settings) capability-value 'ocaml:typecheck-button)])
            (send ocaml:typecheck-button-parent-panel change-children
                  (λ (l)
                    (if visible?
                        (list ocaml:typecheck-button)
                        '()))))))
      
      (define/public (ocaml:typecheck:get-button) ocaml:typecheck-button)
      (send (get-button-panel) change-children
            (λ (l)
              (cons ocaml:typecheck-button-parent-panel
                    (remove ocaml:typecheck-button-parent-panel l))))
      (inherit ocaml:update-button-visibility/tab)
      (ocaml:update-button-visibility/tab (get-current-tab)))))