(module typecheck-defs mzscheme
  (require
   (lib "class.ss")
   (lib "list.ss")
   (lib "pregexp.ss")
   (lib "string.ss")
   (lib "framework.ss" "framework")
   (lib "mred.ss" "mred")
   (prefix ocaml: "util.ss"))
  (provide
   annotation
   annotation-start-char
   annotation-end-char
   annot-type
   compile-and-get-dtypes
   format-annot)
  
  (define (compile-and-get-dtypes parent fname settings)
    (with-handlers
        ([exn:fail? (λ (exn) (ocaml:not-installed) #f)])
      (define filename
        (path->string 
         (if (eq? (system-type 'os) 'windows)
             (ocaml:strip-crlf fname)
             fname)))
      (define executable-name (path-replace-suffix fname ".exe"))
      (define lsm (ocaml:lang-settings-modules settings))
      (define annot-filename (path->string (path-replace-suffix filename ".annot")))
      (define _ (when (file-exists? annot-filename) (delete-file annot-filename) (sleep 0.01)))
      (define 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))))
      (define args
        (filter
         (λ (x) (not (equal? x "")))
         (list
          #f #f #f
          (ocaml:lang-settings-compiler settings)
          "-o" (path->string executable-name)
          "-dtypes"
          lsm
          lsi
          "-impl" filename)))
      (define-values (proc in out err)
        (apply subprocess args))
      (define annot-table (make-hash-table))
      (subprocess-wait proc)
      (call-with-input-file annot-filename (λ (port) (get-annotations annot-table port)))))
      #;(if (= (subprocess-status compile-process) 0)
          (call-with-input-file annot-filename (λ (port) (get-annotations annot-table port)))
          (message-box
           "Compilation error"
           "The file failed to compile."
           parent
           'ok))

  #|
  (define (setup-keymap keymap)
    (let ([add-pos-function
           (λ (name call-method)
             (send keymap add-function name
                   (λ (edit event)
                     (call-method
                      edit
                      (send edit get-start-position)))))])
      (add-pos-function "prev-annotation-at-pos" (λ (e p) (send e ocaml:prev-annotation-at-pos p)))
      (add-pos-function "next-annotation-at-pos" (λ (e p) (send e ocaml:next-annotation-at-pos p)))
      (add-pos-function "prev-typed-expression" (λ (e p) (send e ocaml:prev-typed-expression p)))
      (add-pos-function "next-typed-expression" (λ (e p) (send e ocaml:next-typed-expression p)))
      (add-pos-function "prev-char-with-type" (λ (e p) (send e ocaml:prev-char-with-type p)))
      (add-pos-function "next-char-with-type" (λ (e p) (send e ocaml:next-char-with-type p)))
      (add-pos-function "prev-word-with-type" (λ (e p) (send e ocaml:prev-word-with-type p)))
      (add-pos-function "next-word-with-type" (λ (e p) (send e ocaml:next-word-with-type p)))
      (add-pos-function "up-line-with-type" (λ (e p) (send e ocaml:up-line-with-type p)))
      (add-pos-function "down-line-with-type" (λ (e p) (send e ocaml:down-line-with-type p))))
    
    (let ([add-edit-function
           (λ (name call-method)
             (send keymap add-function name
                   (λ (edit event)
                     (call-method edit))))])
      (add-edit-function "select-prev-annotation-at-pos" 
                         (λ (x) (send x ocaml:select-prev-annotation-at-pos)))
      (add-edit-function "select-next-annotation-at-pos" 
                         (λ (x) (send x ocaml:select-next-annotation-at-pos)))
      (add-edit-function "select-prev-typed-expression" 
                         (λ (x) (send x ocaml:select-prev-typed-expression)))
      (add-edit-function "select-next-typed-expression" 
                         (λ (x) (send x ocaml:select-next-typed-expression)))
      (add-edit-function "select-prev-char-with-type" 
                         (λ (x) (send x ocaml:select-prev-char-with-type)))
      (add-edit-function "select-next-char-with-type" 
                         (λ (x) (send x ocaml:select-next-char-with-type)))
      (add-edit-function "select-prev-word-with-type"
                         (λ (x) (send x ocaml:select-prev-word-with-type)))
      (add-edit-function "select-next-word-with-type"
                         (λ (x) (send x ocaml:select-next-word-with-type)))
      (add-edit-function "select-up-line-with-type" 
                         (λ (x) (send x ocaml:select-up-line-with-type)))
      (add-edit-function "select-down-line-with-type" 
                         (λ (x) (send x ocaml:select-down-line-with-type)))
      (add-edit-function "get-type-at-selection"
                         (λ (x) (send x ocaml:get-type-at-selection))))
    
    
    (let ([map-meta
           (λ (key func)
             (keymap:send-map-function-meta keymap key func))]
          [map
           (λ (key func)
             (send keymap map-function key func))])
      
      (map-meta "down" "prev-annotation-at-pos")
      (map "a:down" "prev-annotation-at-pos")
      (map-meta "wheeldown" "prev-annotation-at-pos")
      (map "a:wheeldown" "prev-annotation-at-pos")

      (map-meta "up" "next-annotation-at-pos")
      (map "a:up" "next-annotation-at-pos")
      (map-meta "wheelup" "next-annotation-at-pos")
      (map "a:wheelup" "next-annotation-at-pos")

      (map-meta "left" "prev-typed-expression")
      (map "a:left" "prev-typed-expression")
      
      (map-meta "right" "next-typed-expression")
      (map "a:right" "next-typed-expression")
      
      (map-meta "s:down" "select-prev-annotation-at-pos")
      (map "s:a:down" "select-prev-annotation-at-pos")

      (map-meta "s:up" "select-next-annotation-at-pos")
      (map "s:a:up" "select-next-annotation-at-pos")))
  
  (define keymap (make-object keymap:aug-keymap%))
  (setup-keymap keymap)
  (define (get-keymap) keymap) |#
  
  ;; inside joke
  (define (cadadaddr lst) (car (cdr (car (cdr (car (cdr (cdr lst))))))))
  
  (define-struct annotation (start-char end-char type) #f)
    
  (define (get-one-annotation port)
    (define begin-char
      (begin
        (read port) ;; garbage: begin-line
        (read port) ;; garbage: begin-line-char
        (read port)))
    (define end-char
      (begin
        (read port) ;; garbage: filename-2
        (read port) ;; garbage: end-line
        (read port) ;; garbage: end-line-char
        (read port)))
    (define raw-type-desc
      (begin
        (read port) ;; garbage: "type"
        (regexp-replace* (regexp "[|]['][|] ") (format "~v" (read port)) "'")))
    (define type-desc-length (string-length raw-type-desc))
    (define type-desc (substring raw-type-desc 1 (- type-desc-length 1)))
    (make-annotation begin-char end-char type-desc))
  
  (define readtable-no-quote
    (make-readtable
     #f
     #\' 'non-terminating-macro (λ (a b c d e f) #'\')
     #\` 'non-terminating-macro (λ (a b c d e f) #'\`)
     #\, 'non-terminating-macro (λ (a b c d e f) #'\,)))
  
  (define (get-annotations annot-table port)
    (define (loop)
      (define string-test (read port)) ;; garbage: filename-1
      (when (not (eof-object? string-test))
        (let ([one-annot (get-one-annotation port)])
          (insert-one-annotation annot-table one-annot)
          (loop))))
    (current-readtable readtable-no-quote)
    (loop)
    (current-readtable #f)
    annot-table)
  
  (define (insert-one-annotation annot-table annot)
    (define (insert-one-pos pos)
      (define ht-status (hash-table-get annot-table pos (λ () #f)))
      (unless ht-status
        (hash-table-put! annot-table pos annot)))
    (define (loop start end)
      (unless (>= start end)
        (insert-one-pos start)
        (loop (add1 start) end)))
    (loop (annotation-start-char annot) (annotation-end-char annot)))
  
  #;(define (get-first-and-last-end-chars annot-table)
      (define end-char-list
        (hash-table-map
         annot-table
         (λ (key v) key)))
      (values
       (apply min end-char-list)
       (apply max end-char-list)))
  
  (define (annot-type annot)
    (format "~a" (annotation-type annot)))
  
  (define (format-annot annot)
    (format "~a -> ~a \"~a\""
            (annotation-start-char annot)
            (annotation-end-char annot)
            (annotation-type annot)))

  )