(module language-defs mzscheme
  (require
   (lib "os.ss")
   (lib "mred.ss" "mred")
   (lib "etc.ss")
   (lib "list.ss")
   (lib "string.ss")
   (lib "lex.ss" "parser-tools")
   (prefix : (lib "lex-sre.ss" "parser-tools"))
   (prefix lex: "lexer.ss")
   (lib "class.ss")
   (lib "string-constant.ss" "string-constants")
   (lib "pregexp.ss")
   (prefix ocaml: "util.ss"))
  (provide
   reset-process
   create-executable
   front-end/complete-program
   front-end/interaction
   config-panel
   default-settings
   default-settings?
   marshall-settings
   unmarshall-settings)
  
  (define (marshall-settings settings)
    (list
     (ocaml:lang-settings-toplevel settings)
     (ocaml:lang-settings-compiler settings)
     (ocaml:lang-settings-debugger settings)
     (ocaml:lang-settings-modules settings)
     (ocaml:lang-settings-includes settings)))
  
  (define (unmarshall-settings input)
    (if (and
         (list? input)
         (eq? (procedure-arity ocaml:make-lang-settings) (length input)))
        (apply ocaml:make-lang-settings input)
        (default-settings)))

  (define (config-panel _parent)
    (letrec ([parent
              (new vertical-panel%
                   [parent _parent]
                   [alignment '(center center)])]
             
             [locations-panel
              (new group-box-panel%
                   [label "Locations"]
                   [parent parent]
                   [alignment '(left center)])]
             
             [toplevel
              (new text-field%
                   [label (if (eq? (system-type 'os) 'windows)
                              "OCaml Toplevel (ocaml.exe)"
                              "OCaml Toplevel (ocaml)")]
                   [style '(single vertical-label)]
                   [parent locations-panel])]
                 
             [compiler
              (new text-field%
                   [label (if (eq? (system-type 'os) 'windows)
                              "OCaml Compiler (ocamlc.exe)"
                              "OCaml Compiler (ocamlc)")]
                   [style '(single vertical-label)]
                   [parent locations-panel])]
                 
             [debugger
              (new text-field%
                   [label (if (eq? (system-type 'os) 'windows)
                              "OCaml Debugger (ocamldebug.exe)"
                              "OCaml Debugger (ocaml)")]
                   [style '(single vertical-label)]
                   [parent locations-panel])]
      
             [modules
              (new text-field%
                   [label "Additional modules to load (separated by spaces):"]
                   [style '(single vertical-label)]
                   [parent locations-panel])]
             
             [includes
              (new text-field%
                   [label "Include path (directories separated by semicolons):"]
                   [style '(single vertical-label)]
                   [parent locations-panel])])
      
	  (case-lambda
            [()
             (apply
              ocaml:make-lang-settings
              (map (λ (x) (send x get-value)) (list toplevel compiler debugger modules includes)))]
            [(settings)
             (when (and settings (ocaml:lang-settings? settings))
               (send toplevel set-value (ocaml:lang-settings-toplevel settings))
               (send compiler set-value (ocaml:lang-settings-compiler settings))
               (send debugger set-value (ocaml:lang-settings-debugger settings))
               (send modules set-value (ocaml:lang-settings-modules settings))
               (send includes set-value (ocaml:lang-settings-includes settings)))])))
  
  (define (default-settings)
    (if (eq? (system-type 'os) 'windows)
        (ocaml:make-lang-settings
         (path->string (or (find-executable-path "ocaml.exe" #f)
                           (build-path "c:\\cygwin\\bin\\ocaml.exe")))
         (path->string (or (find-executable-path "ocamlc.exe" #f)
                           (build-path "c:\\cygwin\\bin\\ocamlc.exe")))
         (path->string (or (find-executable-path "ocamldebug.exe" #f)
                           (build-path "c:\\cygwin\\bin\\ocamldebug.exe")))
         "" "")
        (ocaml:make-lang-settings
         (path->string (or (find-executable-path "ocaml" #f)
                           (build-path "/usr/local/bin/ocaml")))
         (path->string (or (find-executable-path "ocamlc" #f)
                           (build-path "/usr/local/bin/ocamlc")))
         (path->string (or (find-executable-path "ocamldebug" #f)
                           (build-path "/usr/local/bin/ocamldebug")))
         "" "")))
  
  (define (default-settings? settings)
    (equal? settings (default-settings)))
  
  (define (reset-process settings process)
    (define proc (if process (ocaml:process-proc process) #f))
    (with-handlers
        ([exn:fail? (λ (exn) (ocaml:not-installed) (values #f #f #f #f))])
      (putenv "TERM" "dumb")
      (when (and (subprocess? proc) (eq? (subprocess-status proc) 'running))
        (subprocess-kill proc #t))
      (let*-values
          ([(lsm) (ocaml:lang-settings-modules settings)]
           [(lsi)
            (let
                ([path-list
                  (filter
                   (λ (x) (not (regexp-match "^[ \t\n]*$" x)))
                   (regexp-split ";" (ocaml:lang-settings-includes settings)))])
              (apply string-append (map (λ (x) (format "-I ~a " x)) path-list)))]
           [(args)
            (filter
             (λ (x) (not (equal? x "")))
             (list
              #f #f #f
              (ocaml:lang-settings-toplevel settings)
              lsm
              lsi))]
           [(new-proc in out err)
            (apply subprocess args)])
        (ocaml:clear-all-text err)
        (ocaml:clear-all-text in)
        (values new-proc in out err))))

  (define (create-executable settings parent program-filename)
    (define executable-name (path-replace-suffix program-filename ".exe"))
    (with-handlers
        ([exn:fail? (λ (exn) (ocaml:not-installed))])
      (let*-values
          ([(lsm) (ocaml:lang-settings-modules settings)]
           [(lsi)
            (let
                ([path-list
                  (filter
                   (λ (x) (not (regexp-match "^[ \t\n]*$" x)))
                   (regexp-split ";" (ocaml:lang-settings-includes settings)))])
              (apply string-append (map (λ (x) (format "-I ~a " x)) path-list)))]
           [(args)
            (filter
             (λ (x) (not (equal? x "")))
             (list
              #f #f #f
              (ocaml:lang-settings-compiler settings)
              "-o" executable-name
              lsm
              lsi
              program-filename))]
           [(proc in out err)
            (apply subprocess args)])
          (subprocess-wait proc)
          (unless (= (subprocess-status proc) 0)
            (message-box
             "Compilation error"
             "The file failed to compile."
             parent
             'ok)))))
  
  (define (read-through-whitespace port)
    (let ([next (peek-char port)])
      (when (eq? #\space next)
        (read-char port)
        (read-through-whitespace port))))
  
  (define process-one-expr
    (case-lambda
      [(port tab in out err index)
       (define-values (expr new-index) (ocaml:read-expr port))
       (send (object-name port) set-delayed-prompt-position (+ (if index index 0) new-index))
       (process-one-expr port tab in out err index expr new-index)]
      [(port tab in out err index expr new-index)
       (cond
         [(send (object-name port) ocaml:found-error?) eof]
         [(eof-object? expr) eof]
         [(eq? 'error expr)
          ;; Display a warning that something's left off...
          (printf "WARNING: Some text you entered has been ignored! Do you need to add ';;' or 'end'?\n")
          eof]
         [(send (object-name port) ocaml:found-error?) eof]
         [else
          (begin-with-definitions
            (define out-string (open-output-string))
            (define (loop)
              (define-values (more? next-line) (ocaml:sync-read-line-avail in))
              (if more?
                  (begin
                    (write-string (format "~a~n" next-line) out-string)
                    (loop))
                  (cond
                    [(equal? next-line "# ") #f]
                    [else
                     (write-string (format "~a~n" next-line) out-string)
                     #t])))
            (define (err-loop)
              (define-values (more? next-line)
                (ocaml:sync-read-line-avail err))
              (when (not (equal? next-line ""))
                (write-string next-line out-string)
                (newline out-string))
              (when more? (err-loop)))
            (write-string expr out)
            (newline out)
            (flush-output out)
            (err-loop)
            (read-through-whitespace in)
            (let*
                ([need-line (loop)]
                 [output (get-output-string out-string)]
                 [error-match (pregexp-match "Characters ([0-9]*)-([0-9]*):\n[^W]" output)])
              (when error-match
                (send
                 (object-name port)
                 delayed-highlight-error
                 (list
                  (+ index (string->number (second error-match)))
                  (+ index (string->number (third error-match))))))
              (if need-line
                  (begin
                    (display output)
                    (process-one-expr port tab in out err 0 (read-line) 0))
                  #`#,output)))])]))
  
  (define (front-end/complete-program port)
    (define tab (send (object-name port) get-tab))
    (define process-obj (send tab ocaml:get-process))
    (define in (ocaml:process-in process-obj))
    (define out (ocaml:process-out process-obj))
    (define err (ocaml:process-err process-obj))
    (if (subprocess? (ocaml:process-proc process-obj))
        (begin
          (send (object-name port) ocaml:reset-highlighting)
          (λ () (process-one-expr port tab in out err (send (object-name port) get-prompt-position))))
        (begin
          (ocaml:not-installed)
          (λ () eof))))
  
  (define (front-end/interaction port)
    (define tab (send (send (object-name port) get-definitions-text) get-tab))
    (define process-obj (send tab ocaml:get-process))
    (define debug-process-obj (send tab ocaml:get-debug-process))
    (cond
      [(ocaml:process? debug-process-obj)
       ;; If the debugger is running, pass input to it.
       (let ([in (ocaml:process-in debug-process-obj)]
             [out (ocaml:process-out debug-process-obj)]
             [err (ocaml:process-err debug-process-obj)])
         (λ ()
           (write-string (read-line port) out)
           (newline out)
           (flush-output out)
           eof))]
      [(ocaml:process? process-obj)
       ;; If not, pass input to the toplevel.
       (let ([in (ocaml:process-in process-obj)]
             [out (ocaml:process-out process-obj)]
             [err (ocaml:process-err process-obj)])
         (λ () (process-one-expr port tab in out err (send (object-name port) get-prompt-position))))]
      [else
       ;; If neither is possible, then probably the toplevel isn't installed properly / at all.
       (ocaml:not-installed)
       (λ () eof)])))