;(***********************************************************************)
;(*                                                                     *)
;(*                                OCaml                                *)
;(*                                                                     *)
;(*          Damien Doligez, projet Moscova, INRIA Rocquencourt         *)
;(*                                                                     *)
;(*  Copyright 2003 Institut National de Recherche en Informatique et   *)
;(*  en Automatique.  All rights reserved.  This file is distributed    *)
;(*  under the terms of the GNU General Public License.                 *)
;(*                                                                     *)
;(***********************************************************************)

; An emacs-lisp complement to the "-annot" option of ocamlc and ocamlopt.

;; XEmacs compatibility

(eval-and-compile
  (if (and (boundp 'running-xemacs) running-xemacs)
      (require 'caml-xemacs)
    (require 'caml-emacs)))


(defvar caml-types-build-dirs '("_build" "_obuild")
  "List of possible compilation directories created by build systems.
It is expected that the files under `caml-types-build-dir' preserve
the paths relative to the parent directory of `caml-types-build-dir'.")
(make-variable-buffer-local 'caml-types-build-dir)

(defvar caml-annot-dir nil
  "A directory, generally relative to the file location, containing the
.annot file.  Intended to be set as a local variable in the .ml file.
See \"Specifying File Variables\" in the Emacs info manual.")
(make-variable-buffer-local 'caml-annot-dir)
(put 'caml-annot-dir 'safe-local-variable #'stringp)

(defvar caml-types-location-re nil "Regexp to parse *.annot files.

Annotation files *.annot may be generated with the \"-annot\" option
of ocamlc and ocamlopt.

Their format is:

  file ::= block *
  block ::= position <SP> position <LF> annotation *
  position ::= filename <SP> num <SP> num <SP> num
  annotation ::= keyword open-paren <LF> <SP> <SP> data <LF> close-paren <LF>

  <SP> is a space character (ASCII 0x20)
  <LF> is a line-feed character (ASCII 0x0A)
  num is a sequence of decimal digits
  filename is a string with the lexical conventions of OCaml
  open-paren is an open parenthesis (ASCII 0x28)
  close-paren is a closed parenthesis (ASCII 0x29)
  data is any sequence of characters where <LF> is always followed by
       at least two space characters.

- in each block, the two positions are respectively the start and the
  end of the range described by the block.
- in a position, the filename is the name of the file, the first num
  is the line number, the second num is the offset of the beginning
  of the line, the third num is the offset of the position itself.
- the char number within the line is the difference between the third
  and second nums.

The current list of keywords is:
type call ident"
)

(defvar caml-types-position-re nil)

(let* ((caml-types-filename-re "\"\\(\\([^\\\"]\\|\\\\.\\)*\\)\"")
       (caml-types-number-re "\\([0-9]*\\)"))
  (setq caml-types-position-re
        (concat caml-types-filename-re " "
                caml-types-number-re " "
                caml-types-number-re " "
                caml-types-number-re))
  (setq caml-types-location-re
        (concat "^" caml-types-position-re " " caml-types-position-re)))

(defvar caml-types-expr-ovl (make-overlay 1 1))
(make-face 'caml-types-expr-face)
(set-face-doc-string 'caml-types-expr-face
                     "face for hilighting expressions and types")
(if (not (face-differs-from-default-p 'caml-types-expr-face))
    (set-face-background 'caml-types-expr-face "#88FF44"))
(overlay-put caml-types-expr-ovl 'face 'caml-types-expr-face)

(defvar caml-types-typed-ovl (make-overlay 1 1))
(make-face 'caml-types-typed-face)
(set-face-doc-string 'caml-types-typed-face
                     "face for hilighting typed expressions")
(if (not (face-differs-from-default-p 'caml-types-typed-face))
    (set-face-background 'caml-types-typed-face "#FF8844"))
(overlay-put caml-types-typed-ovl 'face 'caml-types-typed-face)

(defvar caml-types-scope-ovl (make-overlay 1 1))
(make-face 'caml-types-scope-face)
(set-face-doc-string 'caml-types-scope-face
                     "face for hilighting variable scopes")
(if (not (face-differs-from-default-p 'caml-types-scope-face))
    (set-face-background 'caml-types-scope-face "#BBFFFF"))
(overlay-put caml-types-scope-ovl 'face 'caml-types-scope-face)

(defvar caml-types-def-ovl (make-overlay 1 1))
(make-face 'caml-types-def-face)
(set-face-doc-string 'caml-types-def-face
                     "face for hilighting binding occurrences")
(if (not (face-differs-from-default-p 'caml-types-def-face))
    (set-face-background 'caml-types-def-face "#FF4444"))
(overlay-put caml-types-def-ovl 'face 'caml-types-def-face)

(defvar caml-types-occ-ovl (make-overlay 1 1))
(make-face 'caml-types-occ-face)
(set-face-doc-string 'caml-types-occ-face
                     "face for hilighting variable occurrences")
(if (not (face-differs-from-default-p 'caml-types-occ-face))
    (set-face-background 'caml-types-occ-face "#44FF44"))
(overlay-put caml-types-occ-ovl 'face 'caml-types-occ-face)


(defvar caml-types-annotation-tree nil)
(defvar caml-types-annotation-date nil)
(make-variable-buffer-local 'caml-types-annotation-tree)
(make-variable-buffer-local 'caml-types-annotation-date)

(defvar caml-types-buffer-name "*caml-types*"
  "Name of buffer for displaying caml types")
(defvar caml-types-buffer nil
  "buffer for displaying caml types")

(defun caml-types-show-type (arg)
  "Show the type of expression or pattern at point.
   The smallest expression or pattern that contains point is
   temporarily highlighted.  Its type is highlighted in the .annot
   file and the mark is set to the beginning of the type.
   The type is also displayed in the mini-buffer.

   Hints on using the type display:
   . If you want the type of an identifier, put point within any
     occurrence of this identifier.
   . If you want the result type of a function application, put point
     at the first space after the function name.
   . If you want the type of a list, put point on a bracket, on a
     semicolon, or on the :: constructor.
   . Even if type checking fails, you can still look at the types
     in the file, up to where the type checker failed.

Types are also displayed in the buffer *caml-types*, which is
displayed when the command is called with Prefix argument 4.

See also `caml-types-explore' for exploration by mouse dragging.
See `caml-types-location-re' for annotation file format.
"
  (interactive "p")
  (let* ((target-buf (current-buffer))
         (target-file (file-name-nondirectory (buffer-file-name)))
         (target-line (1+ (count-lines (point-min)
                                       (caml-line-beginning-position))))
         (target-bol (caml-line-beginning-position))
         (target-cnum (point)))
    (caml-types-preprocess (buffer-file-name))
    (setq caml-types-buffer (get-buffer-create caml-types-buffer-name))
    (let* ((targ-loc (vector target-file target-line target-bol target-cnum))
           (node (caml-types-find-location targ-loc "type" ()
                                           caml-types-annotation-tree)))
      (cond
       ((null node)
         (delete-overlay caml-types-expr-ovl)
         (message "Point is not within a typechecked expression or pattern."))
       (t
        (let ((left (caml-types-get-pos target-buf (elt node 0)))
              (right (caml-types-get-pos target-buf (elt node 1)))
              (type (cdr (assoc "type" (elt node 2)))))
          (move-overlay caml-types-expr-ovl left right target-buf)
          (with-current-buffer caml-types-buffer
            (erase-buffer)
            (insert type)
            (message (format "type: %s" type)))
          ))))
    (if (and (= arg 4)
             (not (window-live-p (get-buffer-window caml-types-buffer))))
        (display-buffer caml-types-buffer))
    (unwind-protect
        (caml-sit-for 60)
      (delete-overlay caml-types-expr-ovl)
      )))

(defun caml-types-show-call (arg)
  "Show the kind of call at point.
   The smallest function call that contains point is
   temporarily highlighted.  Its kind is highlighted in the .annot
   file and the mark is set to the beginning of the kind.
   The kind is also displayed in the mini-buffer.

The kind is also displayed in the buffer *caml-types*, which is
displayed when the command is called with Prefix argument 4.

See `caml-types-location-re' for annotation file format.
"
  (interactive "p")
  (let* ((target-buf (current-buffer))
         (target-file (file-name-nondirectory (buffer-file-name)))
         (target-line (1+ (count-lines (point-min)
                                       (caml-line-beginning-position))))
         (target-bol (caml-line-beginning-position))
         (target-cnum (point)))
    (caml-types-preprocess (buffer-file-name))
    (setq caml-types-buffer (get-buffer-create caml-types-buffer-name))
    (let* ((targ-loc (vector target-file target-line target-bol target-cnum))
           (node (caml-types-find-location targ-loc "call" ()
                                           caml-types-annotation-tree)))
      (cond
       ((null node)
         (delete-overlay caml-types-expr-ovl)
         (message "Point is not within a function call."))
       (t
        (let ((left (caml-types-get-pos target-buf (elt node 0)))
              (right (caml-types-get-pos target-buf (elt node 1)))
              (kind (cdr (assoc "call" (elt node 2)))))
          (move-overlay caml-types-expr-ovl left right target-buf)
          (with-current-buffer caml-types-buffer
            (erase-buffer)
            (insert kind)
            (message (format "%s call" kind)))
          ))))
    (if (and (= arg 4)
             (not (window-live-p (get-buffer-window caml-types-buffer))))
        (display-buffer caml-types-buffer))
    (unwind-protect
        (caml-sit-for 60)
      (delete-overlay caml-types-expr-ovl)
      )))

(defun caml-types-show-ident (arg)
  "Show the binding of identifier at point.
   The identifier that contains point is
   temporarily highlighted.  Its binding is highlighted in the .annot
   file and the mark is set to the beginning of the binding.
   The binding is also displayed in the mini-buffer.

The binding is also displayed in the buffer *caml-types*, which is
displayed when the command is called with Prefix argument 4.

See `caml-types-location-re' for annotation file format.
"
  (interactive "p")
  (let* ((target-buf (current-buffer))
         (target-file (file-name-nondirectory (buffer-file-name)))
         (target-line (1+ (count-lines (point-min)
                                       (caml-line-beginning-position))))
         (target-bol (caml-line-beginning-position))
         (target-cnum (point)))
    (caml-types-preprocess (buffer-file-name))
    (setq caml-types-buffer (get-buffer-create caml-types-buffer-name))
    (let* ((targ-loc (vector target-file target-line target-bol target-cnum))
           (node (caml-types-find-location targ-loc "ident" ()
                                           caml-types-annotation-tree)))
      (cond
       ((null node)
         (delete-overlay caml-types-expr-ovl)
         (message "Point is not within an identifier."))
       (t
        (let ((left (caml-types-get-pos target-buf (elt node 0)))
              (right (caml-types-get-pos target-buf (elt node 1)))
              (kind (cdr (assoc "ident" (elt node 2)))))
          (move-overlay caml-types-expr-ovl left right target-buf)
          (let* ((loc-re (concat caml-types-position-re " "
                                 caml-types-position-re))
                 (end-re (concat caml-types-position-re " --"))
                 (def-re (concat "def \\([^ ]*\\) " loc-re))
                 (def-end-re (concat "def \\([^ ]*\\) " end-re))
                 (internal-re (concat "int_ref \\([^ ]*\\) " loc-re))
                 (external-re "ext_ref \\(.*\\)"))
            (cond
             ((string-match def-re kind)
              (let ((var-name (match-string 1 kind))
                    (l-file (file-name-nondirectory (match-string 2 kind)))
                    (l-line (caml-string-to-int (match-string 4 kind)))
                    (l-bol (caml-string-to-int (match-string 5 kind)))
                    (l-cnum (caml-string-to-int (match-string 6 kind)))
                    (r-file (file-name-nondirectory (match-string 7 kind)))
                    (r-line (caml-string-to-int (match-string 9 kind)))
                    (r-bol (caml-string-to-int (match-string 10 kind)))
                    (r-cnum (caml-string-to-int (match-string 11 kind))))
                (let* ((lpos (vector l-file l-line l-bol l-cnum))
                       (rpos (vector r-file r-line r-bol r-cnum))
                       (left (caml-types-get-pos target-buf lpos))
                       (right (caml-types-get-pos target-buf rpos)))
                  (message (format "local variable %s is bound here" var-name))
                  (move-overlay caml-types-scope-ovl left right target-buf))))
             ((string-match def-end-re kind)
              (let ((var-name (match-string 1 kind))
                    (l-file (file-name-nondirectory (match-string 2 kind)))
                    (l-line (caml-string-to-int (match-string 4 kind)))
                    (l-bol (caml-string-to-int (match-string 5 kind)))
                    (l-cnum (caml-string-to-int (match-string 6 kind))))
                (let* ((lpos (vector l-file l-line l-bol l-cnum))
                       (left (caml-types-get-pos target-buf lpos))
                       (right (buffer-size target-buf)))
                  (message (format "global variable %s is bound here" var-name))
                  (move-overlay caml-types-scope-ovl left right target-buf))))
             ((string-match internal-re kind)
              (let ((var-name (match-string 1 kind))
                    (l-file (file-name-nondirectory (match-string 2 kind)))
                    (l-line (caml-string-to-int (match-string 4 kind)))
                    (l-bol (caml-string-to-int (match-string 5 kind)))
                    (l-cnum (caml-string-to-int (match-string 6 kind)))
                    (r-file (file-name-nondirectory (match-string 7 kind)))
                    (r-line (caml-string-to-int (match-string 9 kind)))
                    (r-bol (caml-string-to-int (match-string 10 kind)))
                    (r-cnum (caml-string-to-int (match-string 11 kind))))
                (let* ((lpos (vector l-file l-line l-bol l-cnum))
                       (rpos (vector r-file r-line r-bol r-cnum))
                       (left (caml-types-get-pos target-buf lpos))
                       (right (caml-types-get-pos target-buf rpos)))
                  (move-overlay caml-types-def-ovl left right target-buf)
                  (message (format "%s is bound at line %d char %d"
                                   var-name l-line (- l-cnum l-bol))))))
             ((string-match external-re kind)
              (let ((fullname (match-string 1 kind)))
                (with-current-buffer caml-types-buffer
                  (erase-buffer)
                  (insert fullname)
                  (message (format "external ident: %s" fullname)))))))
          ))))
    (if (and (= arg 4)
             (not (window-live-p (get-buffer-window caml-types-buffer))))
        (display-buffer caml-types-buffer))
    (unwind-protect
        (caml-sit-for 60)
      (delete-overlay caml-types-expr-ovl)
      (delete-overlay caml-types-def-ovl)
      (delete-overlay caml-types-scope-ovl)
      )))

(defun caml-types-preprocess (target-path)
  (let* ((type-path (caml-types-locate-type-file target-path))
         (type-date (nth 5 (file-attributes (file-chase-links type-path))))
         (target-date (nth 5 (file-attributes target-file))))
    (unless (and caml-types-annotation-tree
                 type-date
                 caml-types-annotation-date
                 (not (caml-types-date< caml-types-annotation-date type-date)))
      (if (and type-date target-date (caml-types-date< type-date target-date))
          (error (format "`%s' is more recent than `%s'"
                         target-path type-path)))
      (message "Reading annotation file...")
      (let* ((type-buf (caml-types-find-file type-path))
             (tree (with-current-buffer type-buf
                    (widen)
                    (goto-char (point-min))
                    (caml-types-build-tree
                     (file-name-nondirectory target-path)))))
        (setq caml-types-annotation-tree tree
              caml-types-annotation-date type-date)
        (kill-buffer type-buf)
        (message "done"))
      )))

(defun caml-types-parent-dir (d) (file-name-directory (directory-file-name d)))

(defun caml-types-locate-type-file (target-path)
  "Given the path to an OCaml file, this function tries to locate
and return the corresponding .annot file."
  (let ((sibling (concat (file-name-sans-extension target-path) ".annot")))
    (if (file-exists-p sibling)
        sibling
      (let* ((dir (file-name-directory sibling)))
        (if caml-annot-dir
            ;; Use the relative path set by the user
            (let* ((annot-dir (expand-file-name caml-annot-dir dir))
                   (fname (file-name-nondirectory sibling))
                   (path-fname (expand-file-name fname annot-dir)))
              (if (file-exists-p path-fname)
                  path-fname
                (error (concat "No annotation file in " caml-annot-dir
                               ". Compile with option \"-annot\"."))))
          ;; Else, try to get the .annot from one of build dirs.
          (let* ((is-build (regexp-opt caml-types-build-dirs))
                 (project-dir (locate-dominating-file
                               dir
                               (lambda(d) (directory-files d nil is-build))))
                 (annot
                  (if project-dir
                      (locate-file
                       (file-relative-name sibling project-dir)
                       (mapcar (lambda(d) (expand-file-name d project-dir))
                               caml-types-build-dirs)))))
            (if annot
                annot
              (error (concat "No annotation file. Compile with option "
                             "\"-annot\" or set `caml-annot-dir'.")))))))))

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


; we use an obarray for hash-consing the strings within each tree

(defun caml-types-make-hash-table ()
  (make-vector 255 0))

(defun caml-types-hcons (elem table)
  (symbol-name (intern elem table)))


(defun next-annotation ()
  (forward-char 1)
  (if (re-search-forward "^[a-z\"]" () t)
      (forward-char -1)
    (goto-char (point-max)))
  (looking-at "[a-z]")
)

; tree of intervals
; each node is a vector
; [ pos-left pos-right annotation child child child... ]
; annotation is a list of:
;   (kind . info) where kind = "type" "call" etc.
;                 and info = the contents of the annotation

(defun caml-types-build-tree (target-file)
  (let ((stack ())
        (accu ())
        (table (caml-types-make-hash-table))
        (annotation ()))
    (while (re-search-forward caml-types-location-re () t)
      (let ((l-file (file-name-nondirectory (match-string 1)))
            (l-line (caml-string-to-int (match-string 3)))
            (l-bol (caml-string-to-int (match-string 4)))
            (l-cnum (caml-string-to-int (match-string 5)))
            (r-file (file-name-nondirectory (match-string 6)))
            (r-line (caml-string-to-int (match-string 8)))
            (r-bol (caml-string-to-int (match-string 9)))
            (r-cnum (caml-string-to-int (match-string 10))))
        (unless (caml-types-not-in-file l-file r-file target-file)
          (setq annotation ())
          (while (next-annotation)
            (cond ((looking-at "^\\([a-z]+\\)(\n  \\(\\(.*\n  \\)*.*\\)\n)")
                   (let ((kind (caml-types-hcons (match-string 1) table))
                         (info (caml-types-hcons (match-string 2) table)))
                     (setq annotation (cons (cons kind info) annotation))))))
          (setq accu ())
          (while (and stack
                      (caml-types-pos-contains l-cnum r-cnum (car stack)))
            (setq accu (cons (car stack) accu))
            (setq stack (cdr stack)))
          (let* ((left-pos (vector l-file l-line l-bol l-cnum))
                 (right-pos (vector r-file r-line r-bol r-cnum))
                 (node (caml-types-make-node left-pos right-pos annotation
                                             accu)))
            (setq stack (cons node stack))))))
    (if (null stack)
        (error "no annotations found for this source file")
      (let* ((left-pos (elt (car (last stack)) 0))
             (right-pos (elt (car stack) 1)))
        (if (null (cdr stack))
            (car stack)
          (caml-types-make-node left-pos right-pos () (nreverse stack)))))))

(defun caml-types-not-in-file (l-file r-file target-file)
  (or (and (not (string= l-file target-file))
           (not (string= l-file "")))
      (and (not (string= r-file target-file))
           (not (string= r-file "")))))

(defun caml-types-make-node (left-pos right-pos annotation children)
  (let ((result (make-vector (+ 3 (length children)) ()))
        (i 3))
    (aset result 0 left-pos)
    (aset result 1 right-pos)
    (aset result 2 annotation)
    (while children
      (aset result i (car children))
      (setq children (cdr children))
      (setq i (1+ i)))
    result))

(defun caml-types-pos-contains (l-cnum r-cnum node)
  (and (<= l-cnum (elt (elt node 0) 3))
       (>= r-cnum (elt (elt node 1) 3))))

(defun caml-types-find-location (targ-pos kind curr node)
  (if (not (caml-types-pos-inside targ-pos node))
      curr
    (if (and (elt node 2) (assoc kind (elt node 2)))
        (setq curr node))
    (let ((i (caml-types-search node targ-pos)))
      (if (and (> i 3)
               (caml-types-pos-inside targ-pos (elt node (1- i))))
          (caml-types-find-location targ-pos kind curr (elt node (1- i)))
        curr))))

; trouve le premier fils qui commence apres la position
; ou (length node) si tous commencent avant
(defun caml-types-search (node pos)
  (let ((min 3)
        (max (length node))
        med)
    (while (< min max)
      (setq med (/ (+ min max) 2))
      (if (caml-types-pos<= (elt (elt node med) 0) pos)
          (setq min (1+ med))
        (setq max med)))
    min))

(defun caml-types-pos-inside (pos node)
  (let ((left-pos (elt node 0))
        (right-pos (elt node 1)))
    (and (caml-types-pos<= left-pos pos)
         (caml-types-pos> right-pos pos))))

(defun caml-types-find-interval (buf targ-pos node)
  (let ((nleft (elt node 0))
        (nright (elt node 1))
        (left ())
        (right ())
        i)
    (cond
     ((not (caml-types-pos-inside targ-pos node))
      (if (not (caml-types-pos<= nleft targ-pos))
          (setq right nleft))
      (if (not (caml-types-pos> nright targ-pos))
          (setq left nright)))
     (t
      (setq left nleft
            right nright)
      (setq i (caml-types-search node targ-pos))
      (if (< i (length node))
          (setq right (elt (elt node i) 0)))
      (if (> i 3)
          (setq left (elt (elt node (1- i)) 1)))))
     (cons (if left
               (caml-types-get-pos buf left)
             (with-current-buffer buf (point-min)))
           (if right
               (caml-types-get-pos buf right)
             (with-current-buffer buf (point-max))))))


;; 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<= (pos1 pos2)
  (let ((file1 (elt pos1 0))
        (line1 (elt pos1 1))
        (bol1 (elt pos1 2))
        (cnum1 (elt pos1 3))
        (file2 (elt pos2 0))
        (line2 (elt pos2 1))
        (bol2 (elt pos2 2))
        (cnum2 (elt pos2 3)))
    (if (string= file1 "")
        (<= cnum1 cnum2)
      (and (string= file1 file2)
           (or (< line1 line2)
               (and (= line1 line2)
                    (<= (- cnum1 bol1) (- cnum2 bol2))))))))

(defun caml-types-pos> (pos1 pos2)
  (let ((file1 (elt pos1 0))
        (line1 (elt pos1 1))
        (bol1 (elt pos1 2))
        (cnum1 (elt pos1 3))
        (file2 (elt pos2 0))
        (line2 (elt pos2 1))
        (bol2 (elt pos2 2))
        (cnum2 (elt pos2 3)))
    (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 pos)
  (save-excursion
    (set-buffer buf)
    (goto-line (elt pos 1))
    (forward-char (- (elt pos 3) (elt pos 2)))
    (point)))

; find-file-read-only-noselect seems to be missing from emacs...
(defun caml-types-find-file (name)
  (let (buf)
  (cond
   ((setq buf (get-file-buffer name))
    (unless (verify-visited-file-modtime buf)
      (if (buffer-modified-p buf)
          (find-file-noselect name)
        (with-current-buffer buf (revert-buffer t t)))
      ))
   ((and (file-readable-p name)
         (setq buf (find-file-noselect name)))
     (with-current-buffer buf (toggle-read-only 1))
     )
   (t
    (error (format "Can't read the annotation file `%s'" name)))
    )
  buf))

(defun caml-types-mouse-ignore (event)
  (interactive "e")
  nil)

(defun caml-types-time ()
  (let ((time (current-time)))
     (+ (* (mod (cadr time) 1000) 1000)
                  (/ (cadr (cdr time)) 1000))))

(defun caml-types-explore (event)
  "Explore type annotations by mouse dragging.

The expression under the mouse is highlighted and its type is displayed
in the minibuffer, until the move is released, much as `caml-types-show-type'.
The function uses two overlays.

 . One overlay delimits the largest region whose all subnodes
   are well-typed.
 . Another overlay delimits the current node under the mouse (whose type
   annotation is being displayed).
"
  (interactive "e")
  (set-buffer (window-buffer (caml-event-window event)))
  (let* ((target-buf (current-buffer))
         (target-file (file-name-nondirectory (buffer-file-name)))
         (target-line) (target-bol)
         target-pos
         Left Right limits cnum node mes type
         region
         (window (caml-event-window event))
         target-tree
         (speed 100)
         (last-time (caml-types-time))
         (original-event event)
         )
    (select-window window)
    (unwind-protect
        (progn
          (caml-types-preprocess (buffer-file-name))
          (setq target-tree caml-types-annotation-tree)
          (setq caml-types-buffer (get-buffer-create caml-types-buffer-name))
          ;; (message "Drag the mouse to explore types")
          (unwind-protect
              (caml-track-mouse
               (while event
                 (cond
                  ;; we ignore non mouse events
                  ((caml-ignore-event-p event))
                  ;; we stop when the original button is released
                  ((caml-release-event-p original-event event)
                   (setq event nil))
                  ;; we scroll when the motion is outside the window
                  ((and (caml-mouse-movement-p event)
                        (not (and (equal window (caml-event-window event))
                                  (integer-or-marker-p
                                   (caml-event-point-end event)))))
                   (let* ((win (caml-window-edges window))
                          (top (nth 1 win))
                          (bottom (- (nth 3 win) 1))
                          mouse
                          time
                          )
                     (while (and
                             (caml-sit-for 0 (/ 500 speed))
                             (setq time (caml-types-time))
                             (> (- time last-time) (/ 500 speed))
                             (setq mouse (caml-mouse-vertical-position))
                             (or (< mouse top) (>= mouse bottom))
                             )
                       (setq last-time time)
                       (cond
                        ((< mouse top)
                         (setq speed (- top mouse))
                         (condition-case nil
                             (scroll-down 1)
                           (error (message "Beginning of buffer!"))))
                        ((>= mouse bottom)
                         (setq speed (+ 1 (- mouse bottom)))
                         (condition-case nil
                             (scroll-up 1)
                           (error (message "End of buffer!"))))
                        )
                       (setq speed (* speed speed))
                       )))
                  ;; main action, when the motion is inside the window
                  ;; or on orginal button down event
                  ((or (caml-mouse-movement-p event)
                       (equal original-event event))
                   (setq cnum (caml-event-point-end event))
                   (if (and region
                            (<= (car region) cnum) (< cnum (cdr region)))
                       ;; mouse remains in outer region
                       nil
                     ;; otherwise, reset the outer region
                     (setq region
                           (caml-types-typed-make-overlay
                            target-buf (caml-event-point-start event))))
                   (if
                       (and limits
                            (>= cnum (car limits)) (< cnum (cdr limits)))
                       ;; inner region is unchanged
                       nil
                     ;; recompute the inner region and type annotation
                     (setq target-bol
                           (save-excursion
                             (goto-char cnum) (caml-line-beginning-position))
                           target-line (1+ (count-lines (point-min)
                                                        target-bol))
                           target-pos
                           (vector target-file target-line target-bol cnum))
                     (save-excursion
                       (setq node (caml-types-find-location target-pos "type" ()
                                                            target-tree))
                       (set-buffer caml-types-buffer)
                       (erase-buffer)
                       (cond
                        ((null node)
                         (delete-overlay caml-types-expr-ovl)
                         (setq type "*no type information*")
                         (setq limits
                               (caml-types-find-interval
                                target-buf target-pos target-tree)))
                        (t
                         (let ((left
                                (caml-types-get-pos target-buf (elt node 0)))
                               (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)
                               type (cdr (assoc "type" (elt node 2))))
                         ))
                        )
                       (setq mes (format "type: %s" type))
                       (insert type)
                       ))
                   (message mes)
                   )
                  )
                 ;; we read next event, unless it is nil, and loop back.
                 (if event (setq event (caml-read-event)))
                 )
               )
            ;; delete overlays at end of exploration
            (delete-overlay caml-types-expr-ovl)
            (delete-overlay caml-types-typed-ovl)
            ))
      ;; When an error occurs, the mouse release event has not been read.
      ;; We could wait for mouse release to prevent execution of
      ;; a binding of mouse release, such as cut or paste.
      ;; In most common cases, next event will be the mouse release.
      ;; However, it could also be a key stroke before mouse release.
      ;; Emacs does not allow to test whether mouse is up or down.
      ;; Not sure it is robust to loop for mouse release after an error
      ;; occured, as is done for exploration.
      ;; So far, we just ignore next event. (Next line also be uncommenting.)
      (if event (caml-read-event))
      )))

(defun caml-types-typed-make-overlay (target-buf pos)
  (interactive "p")
  (let ((start pos) (end pos) len node left right)
      (setq len (length caml-types-annotation-tree))
      (while (> len 3)
        (setq len (- len 1))
        (setq node (aref caml-types-annotation-tree len))
        (if (and (equal target-buf (current-buffer))
                 (setq left (caml-types-get-pos target-buf (elt node 0))
                       right (caml-types-get-pos target-buf (elt node 1)))
                 (<= left pos) (> right pos)
                 )
            (setq start (min start left)
                  end (max end right))
             ))
      (move-overlay caml-types-typed-ovl
                    (max (point-min) (- start 1))
                    (min (point-max) (+ end 1)) target-buf)
    (cons start end)))

(defun caml-types-version ()
  "internal version number of caml-types.el"
  (interactive)
  (message "4")
)

(provide 'caml-types)