(module util mzscheme
  (require
   (lib "os.ss")
   (lib "mred.ss" "mred")
   (lib "etc.ss")
   (lib "list.ss")
   (lib "lex.ss" "parser-tools")
   (prefix : (lib "lex-sre.ss" "parser-tools"))
   (prefix lex: "lexer.ss")
   (lib "framework.ss" "framework")
   (lib "class.ss")
   (lib "string-constant.ss" "string-constants")
   (lib "pregexp.ss"))
  (provide
   clear-all-text
   definitions-text<%>
	 unit:frame<%>
   make-lang-settings
   lang-settings
   lang-settings?
   lang-settings-toplevel
   lang-settings-compiler
   lang-settings-debugger
   lang-settings-modules
   lang-settings-includes
   make-process
   process
   process?
   process-proc
   process-in
   process-out
   process-err
   not-installed
   read-expr
   sync-char-ready?
   strip-crlf
   get-pos/text
   sync-read-line-avail)
  
  (define-struct lang-settings (toplevel compiler debugger modules includes) #f)
  (define-struct process (proc in out err) #f)
  
  (define (clear-all-text port)
    (when (sync-char-ready? port)
      (read-char port)
      (clear-all-text port)))
  
  ;;; Copied from collects/drscheme/syncheck.ss, from DrScheme v301.
  (define (get-pos/text event -editor)
    (let ([event-x (send event get-x)]
          [event-y (send event get-y)]
          [on-it? (box #f)])
      (let loop ([editor -editor])
        (let-values ([(x y) (send editor dc-location-to-editor-location event-x event-y)])
          (cond
            [(is-a? editor text%)
             (let ([pos (send editor find-position x y #f on-it?)])
               (cond
                 [(not (unbox on-it?)) (values #f #f)]
                 [else
                  (let ([snip (send editor find-snip pos 'after-or-none)])
                    (if (and snip
                             (is-a? snip editor-snip%))
                        (loop (send snip get-editor))
                        (values pos editor)))]))]
            [(is-a? editor pasteboard%)
             (let ([snip (send editor find-snip x y)])
               (if (and snip
                        (is-a? snip editor-snip%))
                   (loop (send snip get-editor))
                   (values #f #f)))]
            [else (values #f #f)])))))
  
  (define (strip-crlf filename)
    (define outfilename (path-replace-suffix filename ".crlf-ml"))
    (define infile (open-input-file filename 'text))
    (define outfile (open-output-file outfilename 'replace))
    (define (copy-all)
      (define next (read-char infile))
      (when (not (eof-object? next))
        (write-char next outfile)
        (copy-all)))
    (copy-all)
    (flush-output outfile)
    (close-input-port infile)
    (close-output-port outfile)
    outfilename)
  
  (define definitions-text<%>
    (interface (scheme:text<%>)
      ocaml:reset-highlighting
      ocaml:clean-up))
  
  (define unit:frame<%>
    (interface ()
      ocaml:update-button-visibility/settings
      ocaml:update-button-visibility/tab))
  
  (define read-expr
    (case-lambda 
      [(port) (read-expr port 0)]
      [(port index)
       (define-values (in out) (make-pipe))
       (define (get-char the-char)
         (if (sync-char-ready? port)
             (let ([next (peek-char port)])
               (if (eq? the-char next)
                   (begin
                     (write-char (read-char port) out)
                     next)
                   #f))))
       (define (loop in-block)
         (define next (if (sync-char-ready? port) (peek-char port) eof))
         (cond
           [(eof-object? next) #f]
           [(eq? next #\s)
            (write-char (read-char port) out)
            (cond
              [(get-char #\i)
               =>
               (λ (next)
                 (if (and (get-char #\g)
                          (get-char #\space))
                     (loop (add1 in-block))
                     (loop in-block)))]
              [(get-char #\t)
               =>
               (λ (next)
                 (if (and
                      (get-char #\r)
                      (get-char #\u)
                      (get-char #\c)
                      (get-char #\t)
                      (get-char #\space))
                     (loop (add1 in-block))
                     (loop in-block)))]
              [else (loop in-block)])]
           [(eq? next #\e)
            (write-char (read-char port) out)
            (if (> in-block 0)
                (if (and
                     (get-char #\n)
                     (get-char #\d)
                     (get-char #\space))
                    (loop (sub1 in-block))
                    (loop in-block))
                (loop in-block))]
           [(eq? next #\")
            (let-values
                ([(str _a _b _c _d)
                   (with-handlers ([exn:fail:read? (λ (exn) "")])
                     (lex:get-string-token port))])
              (write-string str out)
              (loop in-block))]
           [(eq? next #\()
            (if (eq? (if (sync-char-ready? port) (peek-char port 1) eof) #\*)
                (let-values
                    ([(str _a _b _c _d)
                      (with-handlers ([exn:fail:read? (λ (exn) "")])
                        (lex:get-comment-token port))])
                  (write-string (make-string (string-length str) #\space) out)
                  (loop in-block))
                (begin
                  (write-char (read-char port) out)
                  (loop in-block)))]
           [(equal? next #\;)
            (write-char (read-char port) out)
            (if (> in-block 0)
                (loop in-block)
                (if
                 (eq? (if (sync-char-ready? port) (peek-char port) eof) #\;)
                 (begin
                   (write-char (read-char port) out)
                   #t)
                 (loop in-block)))]
           [else
            (write-char (read-char port) out)
            (loop in-block)]))
       (define found-expr (loop 0))
       (define new-index (+ index (pipe-content-length in)))
       (define outport (open-output-string))
       (define (move-string)
               (when (> (pipe-content-length in) 0)
                 (write-byte (read-byte in) outport)
                 (move-string)))
       (define outstring (begin (move-string) (get-output-string outport)))
       (if found-expr
           (values outstring new-index)
           (let ([string-without-whitespace (regexp-replace* "[ \t\n]" outstring "")])
             (if (> (string-length string-without-whitespace) 0)
                 (values 'error index)
                 (values eof index))))]))
  
  ;; if the port isn't ready, give it a bit of time to synchronize
  (define (sync-char-ready? port)
    (or
     (char-ready? port)
     (begin
       (sleep .05)
       (char-ready? port))))
  
  ;; sync-read-live-avail: port -> (values boolean string)
  (define (sync-read-line-avail port)
    (define out (open-output-string))
    (define (loop)
      (if (sync-char-ready? port)
          (let ([next (read-char port)])
            (cond
              [(eq? next #\newline)
               (values #t (get-output-string out))]
              [(eq? next eof)
               (values #f (get-output-string out))]
              [else
               (begin
                 (write-char next out)
                 (loop))]))
          (values #f (get-output-string out))))
    (loop))
  
  (define (not-installed)
    (message-box
     "OCaml not found"
     "There was an error running the OCaml process. Check your languge configuration and try again. Alternatively, OCaml might not be properly installed. You may continue to use DrOCaml as an editor, but you will not be able to execute code.")))