 
 (overlay-put caml-types-expr-ovl 'face 'caml-types-face)
 
+
+(defvar caml-types-annotation-tree)
+(defvar caml-types-annotation-date)
+(make-variable-buffer-local 'caml-types-annotation-tree)
+(make-variable-buffer-local 'caml-types-annotation-date)
+(set-default 'caml-types-annotation-tree ())
+
+
 (defun caml-types-show-type (arg)
   "Show the type of expression or pattern at point.
    The smallest expression or pattern that contains point is

  (interactive "p")
  (let* ((target-buf (current-buffer))
         (target-file (file-name-nondirectory (buffer-file-name)))
         (target-date (nth 5 (file-attributes (buffer-file-name))))
         (target-line (1+ (count-lines (point-min) (line-beginning-position))))
         (target-bol (line-beginning-position))
         (target-cnum (point))
         (type-file (concat (file-name-sans-extension (buffer-file-name))
                            ".annot"))
         (type-date (nth 5 (file-attributes type-file)))
         (type-buf (caml-types-find-file type-file)))
    (if (caml-types-date< type-date target-date)
        (message (format "%s is more recent than %s" target-file type-file))
      (save-excursion
        (set-buffer type-buf)
        (widen)
        (goto-char (point-min))
        (let ((loc (caml-types-find-location target-file target-line
                                             target-bol target-cnum)))
          (if (null loc)
              (progn
                (delete-overlay caml-types-expr-ovl)
                (message
                 "Point is not within a typechecked expression or pattern.")
                (narrow-to-region 1 1))
            (let ((left (caml-types-get-pos target-buf (nth 0 loc) (nth 1 loc)))
                  (right (caml-types-get-pos target-buf
                                             (nth 2 loc) (nth 3 loc))))
              (move-overlay caml-types-expr-ovl left right target-buf))
            ;; not strictly correct
            (re-search-forward
             "^type(\n  \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)")
            (message (format "type: %s" (match-string 1)))
            (narrow-to-region (match-beginning 1) (match-end 1)))))
      (if (and (= arg 4)
               (not (window-live-p (get-buffer-window type-buf))))
          (display-buffer type-buf))
      (unwind-protect
          (sit-for 60)
        (delete-overlay caml-types-expr-ovl)))))

(defun caml-types-date< (date1 date2)
  (or (< (car date1) (car date2))
      (and (= (car date1) (car date2))
           (< (nth 1 date1) (nth 1 date2)))))

(defun caml-types-find-location (targ-file targ-line targ-bol targ-cnum)
  (catch 'exit
    (while (re-search-forward caml-types-location-re () t)
      (let ((left-file (file-name-nondirectory (match-string 1)))
            (left-line (string-to-int (match-string 3)))
            (left-bol (string-to-int (match-string 4)))
            (left-cnum (string-to-int (match-string 5)))
            (right-file (file-name-nondirectory (match-string 6)))
            (right-line (string-to-int (match-string 8)))
            (right-bol (string-to-int (match-string 9)))
            (right-cnum (string-to-int (match-string 10))))
        (if (and (caml-types-pos<= left-file left-line left-bol left-cnum
                                   targ-file targ-line targ-bol targ-cnum)
                 (caml-types-pos> right-file right-line right-bol right-cnum
                                  targ-file targ-line targ-bol targ-cnum))
            (throw 'exit (list left-line (- left-cnum left-bol)
                               right-line (- right-cnum right-bol))))))))

(defun caml-types-find-inside ()
  ;; durty code to retreive the matching Region determined by Left-Right
  (goto-char (match-beginning 0))
  (if (looking-at caml-types-location-re) nil
    (error 'ocaml-types-find-inside))
  (let ((Left-file (file-name-nondirectory (match-string 1)))
        (Left-line (string-to-int (match-string 3)))
        (Left-bol (string-to-int (match-string 4)))
        (Left-cnum (string-to-int (match-string 5)))
        (Right-file (file-name-nondirectory (match-string 6)))
        (Right-line (string-to-int (match-string 8)))
        (Right-bol (string-to-int (match-string 9)))
        (Right-cnum (string-to-int (match-string 10)))
        left right)
  ;; we are searching for a region inside Region.
   (catch 'exit
     (while (and (or (not left) (not right))
                 (re-search-backward caml-types-location-re nil t))
       (let ((left-file (file-name-nondirectory (match-string 1)))
             (left-line (string-to-int (match-string 3)))
             (left-bol (string-to-int (match-string 4)))
             (left-cnum (string-to-int (match-string 5)))
             (right-file (file-name-nondirectory (match-string 6)))
             (right-line (string-to-int (match-string 8)))
             (right-bol (string-to-int (match-string 9)))
             (right-cnum (string-to-int (match-string 10))))
         (if (caml-types-pos<= right-file right-line right-bol right-cnum
                               Left-file Left-line Left-bol Left-cnum)
             (throw 'exit nil)
           (if (caml-types-pos> Right-file Right-line Right-bol Right-cnum
                                right-file right-line right-bol right-cnum)
               (setq right (+ right-bol right-cnum)))
           (if (caml-types-pos> left-file left-line left-bol left-cnum
                                Left-file Left-line Left-bol Left-cnum)
               (setq left (+ left-bol left-cnum)))
           ))))
   ;; if no region is found, make its intersection with Region is empty
   (cons (or left (+ Right-bol Right-cnum))
         (or right (+ Left-bol Left-cnum)))
   ))


;; Warning: these comparison functions are not symmetric.
;; The first argument determines the format:
;; when its file component is empty, only the cnum is compared.

(defun caml-types-pos<= (file1 line1 bol1 cnum1 file2 line2 bol2 cnum2)
  (if (string= file1 "")
      (<= cnum1 cnum2)
    (and (string= file1 file2)
         (or (< line1 line2)
             (and (= line1 line2)
                  (<= (- cnum1 bol1) (- cnum2 bol2)))))))

(defun caml-types-pos> (file1 line1 bol1 cnum1 file2 line2 bol2 cnum2)
  (if (string= file1 "")
      (> cnum1 cnum2)
    (and (string= file1 file2)
         (or (> line1 line2)
             (and (= line1 line2)
                  (> (- cnum1 bol1) (- cnum2 bol2)))))))


(defun caml-types-get-pos (buf line col)
  (save-excursion
    (set-buffer buf)
    (goto-line line)
    (forward-char col)
    (point)))

; find-file-read-only-noselect seems to be missing from emacs...

  (set-buffer (window-buffer (posn-window (event-start event))))
  (let* ((target-buf (current-buffer))
         (target-file (file-name-nondirectory (buffer-file-name)))
         (type-file (concat (file-name-sans-extension (buffer-file-name))
                            ".annot"))
         (type-buf (caml-types-find-file type-file))
         (target-line) (target-bol)
         target-pos
         Left Right limits cnum loc mes ty-start ty-end
         (tree caml-types-annotation-tree)
         )
    (caml-types-preprocess type-file type-buf)
    ; (message "Drag the mouse to explore types")
    (unwind-protect
        (track-mouse
          (while (and event
                      (integer-or-marker-p
                       (setq cnum (posn-point (event-end event)))))
            (if (and limits (>= cnum (car limits)) (< cnum (cdr limits)))
                (message mes)
              (setq target-bol
                    (save-excursion (goto-char cnum) (line-beginning-position)))
              (setq target-line
                    (1+ (count-lines (point-min) target-bol)))
              (setq target-pos (vector target-file target-line target-bol cnum))
              (save-excursion
                (set-buffer type-buf)
                (widen)
                (setq node (caml-types-find-location target-pos () tree))
                (cond
                 (node
                  (setq Left (caml-types-get-pos target-buf (elt node 0)))
                  (setq Right (caml-types-get-pos target-buf (elt node 1)))
                  (move-overlay caml-types-expr-ovl Left Right target-buf)
                  (setq limits (caml-types-find-interval target-buf target-pos
                                                         node))
                  (setq ty-start (car (elt node 2))
                        ty-end (cdr (elt node 2)))
                  (setq mes (format "type: %s" (buffer-substring ty-start
                                                                 (1- ty-end))))
                  (narrow-to-region ty-start ty-end)
                  )
                 (t
                  (delete-overlay caml-types-expr-ovl)
                  (setq mes nil)
                  (narrow-to-region 1 1)
                  (setq limits (caml-types-find-interval target-buf target-pos
                                                         tree))
                 )))
              (message mes)
              )
              (setq event (read-event))
