(module debugger-defs mzscheme
  (require
   (lib "class.ss")
   (lib "list.ss")
   (lib "mred.ss" "mred")
   (lib "string.ss")
   (lib "etc.ss")
   (prefix ocaml: "util.ss"))
  (provide
   debug-callback
   compile-for-debug
   start-debugger
   repeat-action-callback
   break-callback
   inspect-value
   update-breakpoints)
   
  (define (debug-callback defs parent settings)
    (define fname (send defs get-filename))
    (define tab (send defs get-tab))
    (define frame (send tab get-frame))
    (define-values (file-path file-name file-is-dir?)
      (split-path fname))
    (define executable-name
      (compile-for-debug
       parent
       settings
       (if (eq? (system-type 'os) 'windows)
           (ocaml:strip-crlf fname)
           fname)))
    (if executable-name
        (begin
          (send defs ocaml:clean-up)
          (send frame ocaml:show-debug)
          (send frame ensure-rep-shown #t)
          (let-values ([(proc in out err) (start-debugger executable-name tab settings)])
            (send tab ocaml:set-debug-process (ocaml:make-process proc in out err)))
          (update-breakpoints tab (send (send tab get-defs) ocaml:debug:get-breakpoints))
          (start-debug-threads tab)
          #;(send (send defs get-keymap) chain-to-keymap ocaml:debugger-keymap #t))
        (message-box
         "Compilation error"
         "This program cannot compile. Please fix the errors and try again.")))
  
  (define (start-debug-threads tab)
    (define defs (send tab get-defs))
    (define process-obj (send tab ocaml:get-debug-process))
    (define proc (ocaml:process-proc process-obj))
    (define in (ocaml:process-in process-obj))
    (define out (ocaml:process-out process-obj))
    (define err (ocaml:process-err process-obj))
    (send defs ocaml:debug:set-in-handler (thread (debugger-output-handler tab in)))
    (send defs ocaml:debug:set-err-handler (thread (debugger-output-handler tab err))))
  
  (define (compile-for-debug parent settings filename)
    (with-handlers
        ([exn:fail? (λ (exn) (ocaml:not-installed) #f)])
      (define executable-name (path-replace-suffix filename ".exe"))
      (if (ocaml:lang-settings? settings)
          (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)
                  "-g"
                  "-o" (path->string executable-name)
                  lsm
                  lsi
                  "-impl" (path->string filename)))]
               [(proc in out err) (apply subprocess args)])
            (subprocess-wait proc)
            (if (= (subprocess-status proc) 0)
                executable-name
                (begin
                  (message-box
                   "Compilation error"
                   "This program cannot compile. Please fix the errors and try again.")
                  #f)))
      (begin
        (message-box
         "Wrong language"
         "You can only use the debugger with the OCaml language.")
        #f))))

  (define (start-debugger executable-name tab settings)
    (with-handlers
        ([exn:fail?
          (λ (exn)
            (ocaml:not-installed)
            (send tab ocaml:kill-debug)
            (values #f #f #f #f))])
      (define-values (file-path file-name file-is-dir?) (split-path executable-name))
      (define ocamldebug-executable (ocaml:lang-settings-debugger settings))
      (define _1 (current-directory file-path))
			(define _2 (putenv "PATH" (string-append "/usr/local/bin:/usr/bin:/bin:" (getenv "PATH"))))
      (define-values (proc in out err)
        (subprocess
         #f #f #f
         ocamldebug-executable
         "-emacs"
         (path->string file-name)))
      (send (send tab get-frame) open-status-line 'ocaml:debugger)
      (write-string "frame\n" out)
      (flush-output out)
			(ocaml:clear-all-text err)
			(ocaml:clear-all-text in)
      (values proc in out err)))
  
  (define (repeat-action-callback tab message direction)
    (define process-obj (send tab ocaml:get-debug-process))
    (define out (ocaml:process-out process-obj))
    (send (send tab get-defs) ocaml:reset-highlighting)
    (write-string message out)
    (newline out)
    (flush-output out))
  
  (define (ocaml:display-debugger-output tab message)
    (define ints (send tab get-ints))
    (define (thunk)
      (send ints display-results message))
    (send ints run-in-evaluation-thread thunk))
  
  ;; runs on separate thread
  (define (debugger-output-handler tab port)
    (λ ()
      (define defs (send tab get-defs))
      (define ints (send tab get-ints))
      (define-values (in-pipe out-pipe) (make-pipe))
      (define (read-chars-loop)
        (define process-obj (send tab ocaml:get-debug-process))
        (when process-obj
          (let ([out (ocaml:process-out process-obj)]
                [next (read-char port)])
            (when (not (eq? next eof))
               (write-char next out-pipe)
							 (ocaml:display-debugger-output tab (list next)))
            (when (eq? next #\newline)
              (handle out (read-line in-pipe)))
            (read-chars-loop))))
      (define (handle out response-text)
        (cond
          [(regexp-match "Breakpoint : ([0-9]+)" response-text)]
          [(regexp-match "Time : ([0-9]+) - pc : [0-9]+ - module [A-Z][a-z]*" response-text)
           =>
           (λ (x) (send defs ocaml:set-debug-time (string->number (second x))))]
          [(regexp-match "Time : ([0-9]+)" response-text)
           =>
           (λ (x) (send defs ocaml:set-debug-time (string->number (second x))))]
          [(equal? response-text "Beginning of program.")
           (send defs ocaml:set-debug-status "At beginning of program")
           (send defs scroll-to-position 0)]
          [(equal? response-text "Program exit.")
           (send defs ocaml:set-debug-status "At end of program")
           (send defs scroll-to-position (send defs last-position))]
          [(equal? "H" response-text)]
          [(and
            (>= (string-length response-text) 3)
            (equal? (substring response-text 0 3) "M"))
           (begin-with-definitions
             (define parts
               ;; if on windows, start after the drive identifier
               ;; the colon (C:) will screw us up
               (regexp-split
                ":"
                (substring
                 response-text
                 (if (eq? (system-type 'os) 'windows)
                     3
                     5))))
             (define drive-prefix
               ;; if on windows, find out what the drive is: we'll need to know
               (and
                (eq? (system-type 'os) 'windows)
                (substring response-text 3 5)))
             (define file-path
               ;; if on windows, merge in the drive prefix
               (normal-case-path
                (string->path
                 (if (eq? (system-type 'os) 'windows)
                     (string-append drive-prefix (car parts)) ;; hee hee
                     (car parts))))) ;; i crack myself up
             (define start (string->number (second parts)))
             (define lame-ocaml-version (< (length parts) 4))
             (define end
               (if lame-ocaml-version
                   start
                   (string->number (third parts))))
             (define event-type
               (if lame-ocaml-version
                   (third parts)
                   (fourth parts)))
             (define-values (debug-path debug-filename debug-dir?)
               (split-path file-path))
             (define-values (defs-path defs-filename defs-dir?)
               (split-path (send defs get-filename)))
             (if (or (equal? debug-filename defs-filename)
                     (equal? debug-filename (path-replace-suffix defs-filename ".crlf.ml")))
                 (begin
                   (send defs scroll-to-position start #f end)
                   (send defs ocaml:set-debug-highlighting start end)
                   (send defs ocaml:set-debug-status (format "Type ~a" event-type)))
                 (let ([direction (send defs ocaml:get-direction)])
                   (cond
                     [(eq? direction 'forward)
                      (write-string "step" out)
                      (newline out)
                      (flush-output out)]
                     [(eq? direction 'backward)
                      (write-string "backstep" out)
                      (newline out)
                      (flush-output out)]
                     [else
                      ;; This should never happen!
                      (write-string "reverse" out)
                      (newline out)
                      (flush-output out)]))))]))
      (read-chars-loop)))

  (define (break-callback tab)
    (define defs (send tab get-defs))
    (define process-obj (send tab ocaml:get-debug-process))
    (define proc (ocaml:process-proc process-obj))
    (define in (ocaml:process-in process-obj))
    (define out (ocaml:process-out process-obj))
    (define err (ocaml:process-err process-obj))
    (when (subprocess? proc)
      ;; should only send SIGINT
      (send defs ocaml:debug:pause-handlers)
      (subprocess-kill proc #f)
      (ocaml:clear-all-text in)
      (ocaml:clear-all-text err)
      (send defs ocaml:debug:resume-handlers)))
  
  (define (inspect-value tab name)
    (define frame (send tab get-frame))
    (define defs (send tab get-defs))
    (define ints (send tab get-ints))
    (define process-obj (send tab ocaml:get-debug-process))
    (define proc (ocaml:process-proc process-obj))
    (define in (ocaml:process-in process-obj))
    (define out (ocaml:process-out process-obj))
    (define err (ocaml:process-err process-obj))
    (define (loop message)
      (define-values (more? response)
        (if (ocaml:sync-char-ready? err)
            (ocaml:sync-read-line-avail err)
            (ocaml:sync-read-line-avail in)))
      (unless (eq? (system-type 'os) 'windows) (printf "loop ~a ~a~n" message response))
      (if (or (equal? response "Interrupted.")
              (equal? response "")
              (equal? response "(ocd) "))
          (begin
            (ocaml:clear-all-text in)
            (ocaml:clear-all-text err)
            message)
          (loop (string-append message response))))
    (when (subprocess? proc)
      (send defs ocaml:debug:pause-handlers)
      (write-string (format "print ~a~n" name) out)
      (flush-output out)
      (send defs ocaml:set-debug-status (format "~a" (loop "")))
      (send defs ocaml:debug:resume-handlers)))
  
  (define (remove-all-breakpoints tab)
    (define frame (send tab get-frame))
    (define defs (send tab get-defs))
    (define ints (send tab get-ints))
    (define process-obj (send tab ocaml:get-debug-process))
    (define proc (ocaml:process-proc process-obj))
    (define in (ocaml:process-in process-obj))
    (define out (ocaml:process-out process-obj))
    (define err (ocaml:process-err process-obj))
    (define-values (response? response-text)
      (begin
        (write-string "delete\n" out)
        (flush-output)
        (ocaml:sync-read-line-avail in)))
    (when (equal? response-text "Delete all breakpoints ? (y or n) ")
      (write-string "y\n" out)
      (flush-output)))

  (define (update-breakpoints tab breakpoints)
    (define frame (send tab get-frame))
    (define defs (send tab get-defs))
    (define ints (send tab get-ints))
    (define process-obj (send tab ocaml:get-debug-process))
    (define proc (ocaml:process-proc process-obj))
    (define in (ocaml:process-in process-obj))
    (define out (ocaml:process-out process-obj))
    (define err (ocaml:process-err process-obj))
    (define module-name
      (let-values
          ([(_ filename __) (split-path (send defs get-filename))])
           (path-replace-suffix filename "")))
    (define (update-one pos value)
      (when value
        (write-string (format "break @ ~a # ~a~n" module-name pos) out)
        (flush-output out)))
    (remove-all-breakpoints tab)
    (hash-table-for-each breakpoints update-one)))