(module language mzscheme
  (require
   (lib "class.ss")
   (lib "match.ss")
   (lib "list.ss")
   (lib "mred.ss" "mred")
   (lib "framework.ss" "framework")
   (prefix ld: "language-defs.ss")
   (prefix ocaml: "util.ss"))
  (provide
   interactions-text-mixin
   definitions-text-mixin
   tab-mixin
   language%)
  (define (interactions-text-mixin drscheme:rep:text<%>)
    (mixin (drscheme:rep:text<%>) ()
      (inherit scroll-to-position last-position)
      (inherit-field prompt-position)
      (define delayed-prompt-position 0)
      (define delayed-highlight-args #f)
      (super-new)
      (define/augment (on-submit)
        (inner (void) on-submit)
        (set! delayed-prompt-position prompt-position))
      (define/public (delayed-highlight-error args)
        (set! delayed-highlight-args args))
      (define/augment (after-insert start len)
        (inner (void) after-insert start len)
        (scroll-to-position (last-position)))
      (define/override (insert-prompt)
        (super insert-prompt)
        (when delayed-highlight-args
          (send this highlight-error this
                (+ 1 (first delayed-highlight-args))
                (+ 1 (second delayed-highlight-args)))
          (set! delayed-highlight-args #f)))
      (define/override (kill-evaluation)
        (when (eq? (system-type 'os) 'windows)
          (let-values ([(proc in out err)
                        (subprocess #f #f #f "c:\\cygwin\\bin\\killall.exe" "-v" "-9" "ocamlrun")])
            (subprocess-wait proc)
            (sleep 0.1)))
        (super kill-evaluation))
      (define/public (ocaml:found-error?) (if delayed-highlight-args #t #f))
      (define/public (set-delayed-prompt-position pos) (set! delayed-prompt-position pos))
      (define/public (get-prompt-position) delayed-prompt-position)))
  (define (definitions-text-mixin drscheme:unit:definitions-text<%>)
    (mixin (drscheme:unit:definitions-text<%> scheme:text<%>) (ocaml:definitions-text<%>)
      (define ocaml:error-unhighlight-thunk #f)
      (define delayed-prompt-position #f)
      (inherit
        highlight-range
        set-position)
      (super-new)
      (define/public (delayed-highlight-error args)
        (ocaml:reset-highlighting)
        (set-position (first args))
        (set!
         ocaml:error-unhighlight-thunk
         (highlight-range (first args) (second args) (make-object color% "Pink"))))
      (define/augment (on-change)
        (ocaml:reset-highlighting)
        (inner (void) on-change))
      (define/pubment (ocaml:reset-highlighting)
        (inner (void) ocaml:reset-highlighting) 
        (set-delayed-prompt-position 0)
        (if ocaml:error-unhighlight-thunk
            (begin
              (ocaml:error-unhighlight-thunk)
              (set! ocaml:error-unhighlight-thunk #f))))
      (define/pubment (ocaml:clean-up)
        (inner (void) ocaml:clean-up))
      (define/public (ocaml:found-error?) (if ocaml:error-unhighlight-thunk #t #f))
      (define/public (set-delayed-prompt-position pos) (set! delayed-prompt-position pos))
      (define/public (get-prompt-position) delayed-prompt-position)))
  (define (tab-mixin drscheme:unit:tab<%>)
    (mixin (drscheme:unit:tab<%>) ()
      (define ocaml:process #f)
      (super-new)
      (define/public (ocaml:get-process) ocaml:process)
      (define/public (ocaml:reset-process settings)
        (let-values ([(proc in out err) (ld:reset-process settings ocaml:process)])
          (set! ocaml:process (ocaml:make-process proc in out err))))))
  (define (language% drscheme:language:language<%>)
    (class* object% (drscheme:language:language<%>)
      (super-new)
      (define/public (capability-value key)
        (match key
          ('drscheme:language-menu-title "&OCaml")
          ('drscheme:define-popup (cons "let" "let ..."))
          ('ocaml:debug-button #t)
          ('ocaml:typecheck-button #t)
          (_ #f)))
      (define/public (config-panel parent) (ld:config-panel parent))
      (define/public (create-executable settings parent program-filename teachpack-cache)
        (ld:create-executable settings parent program-filename))
      (define/public (default-settings) (ld:default-settings))
      (define/public (default-settings? settings) (ld:default-settings? settings))
      (define/public (first-opened) (void))
      (define/public (front-end/complete-program port settings teachpack-cache)
        (define tab (send (object-name port) get-tab))
        (send tab ocaml:reset-process settings)
        (ld:front-end/complete-program port))
      (define/public (front-end/interaction port settings teachpack-cache)
        (define tab (send (send (object-name port) get-definitions-text) get-tab))
        (unless (ocaml:process? (send tab ocaml:get-process))
          (send tab ocaml:reset-process settings))
        (ld:front-end/interaction port))
      (define/public (get-comment-character) (values "*" #\*))
      (define/public (get-language-id) "ocaml:ocaml")
      (define/public (get-language-name) "OCaml")
      (define/public (get-language-numbers) (list -1000 3447))
      (define/public (get-language-position) (list "Professional Languages" "Objective Caml"))
      (define/public (get-language-url) "http://caml.inria.fr")
      (define/public (get-one-line-summary) "The Objective Caml language")
      (define/public (get-style-delta) #f)
      (define/public (marshall-settings settings) (ld:marshall-settings settings))
      (define/public (on-execute settings run-in-user-thread) ())
      (define/public (order-manuals manuals) (values manuals #t))
      (define/public (render-value value settings port)
        (display value))
      (define/public (render-value/format value settings port width)
        (display value))
      (define/public (unmarshall-settings input) (ld:unmarshall-settings input)))))