caml-types: mouse track + little things

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5864 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

5 files changed, 84 insertions, 53 deletions

diff --git a/emacs/Makefile b/emacs/Makefile
index 9dd9b1e58f..d6c57f79ea 100644
--- a/emacs/Makefile
+++ b/emacs/Makefile
@@ -24,6 +24,7 @@ COMPILECMD=(progn \
               (byte-compile-file "caml.el") \
               (byte-compile-file "inf-caml.el") \
               (byte-compile-file "caml-help.el") \
+              (byte-compile-file "caml-types.el") \
               (byte-compile-file "camldebug.el"))
 
 install:
diff --git a/emacs/caml-emacs.el b/emacs/caml-emacs.el
index 25132eea56..b212db655c 100644
--- a/emacs/caml-emacs.el
+++ b/emacs/caml-emacs.el
@@ -8,7 +8,7 @@
 (defun caml-event-window (e) (posn-window (event-start e)))
 (defun caml-event-point-start (e) (posn-point (event-start e)))
 (defun caml-event-point-end (e) (posn-point (event-end e)))
-(defalias 'caml-track-mouse 'track-mouse)
 (defalias 'caml-read-event 'read-event)
+(defmacro caml-track-mouse (&rest body) (cons 'track-mouse body))
 
 (provide 'caml-emacs)
diff --git a/emacs/caml-types.el b/emacs/caml-types.el
index 30cd07b87b..018c17d5a1 100644
--- a/emacs/caml-types.el
+++ b/emacs/caml-types.el
@@ -21,6 +21,8 @@
       (require 'caml-xemacs)
     (require 'caml-emacs)))
 
+
+
 (defvar caml-types-location-re nil "Regexp to parse *.annot files.
 
 Annotation files *.annot may be generated with the \"-dtypes\" option 
@@ -161,7 +163,7 @@ See `caml-types-location-re' for annotation file format.
          (target-date (nth 5 (file-attributes target-file))))
     (unless (and caml-types-annotation-tree
                  (not (caml-types-date< caml-types-annotation-date type-date)))
-      (if (caml-types-date< type-date target-date)
+      (if (and type-date target-date (caml-types-date< type-date target-date))
           (error (format "%s is more recent than %s" target-file type-file)))
       (message "Reading annotation file...")
       (let* ((type-buf (caml-types-find-file type-file))
@@ -380,6 +382,9 @@ See `caml-types-location-re' for annotation file format.
     )
   buf))
 
+(defun caml-types-mouse-ignore (event)
+  (interactive "e")
+  nil)
 
 (defun caml-types-explore (event)
   "Explore type annotations by mouse dragging.
@@ -395,59 +400,81 @@ and its type is displayed in the minibuffer, until the move is released."
          (target-line) (target-bol)
          target-pos
          Left Right limits cnum node mes type
-         (tree caml-types-annotation-tree)
          region
          )
-    (caml-types-preprocess type-file)
-    (unless caml-types-buffer 
-      (setq caml-types-buffer (get-buffer-create caml-types-buffer-name)))
-      ;; (message "Drag the mouse to explore types")
     (unwind-protect
-        (caml-track-mouse
-         (setq region
-               (caml-types-typed-make-overlay target-buf
-                                        (caml-event-point-start event)))
-         (while (and event
-                     (integer-or-marker-p
-                      (setq cnum (caml-event-point-end event))))
-           (if (and region (<= (car region) cnum) (<= cnum (cdr region)))
-               (if (and limits (>= cnum (car limits)) (< cnum (cdr limits)))
-                   (message mes)
-                 (setq target-bol
-                       (save-excursion (goto-char cnum)
-                                       (caml-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
-                   (setq node (caml-types-find-location target-pos () tree))
-                   (set-buffer caml-types-buffer)
-                   (erase-buffer)
-                   (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 type (elt node 2))
-                     )
-                    (t
-                     (delete-overlay caml-types-expr-ovl)
-                     (setq type "*no type information*")
-                     (setq limits (caml-types-find-interval target-buf target-pos
-                                                            tree))
-                     ))
-                   (message (setq mes (format "type: %s" type)))
-                   (insert type)
-                   )))
-             (setq event (caml-read-event))
-             (unless (mouse-movement-p event) (setq event nil))
-             )
-         )
-      (delete-overlay caml-types-expr-ovl)
-      (delete-overlay caml-types-typed-ovl)
-      )))
+        (progn
+          (if type-file (caml-types-preprocess type-file)
+            (error
+             "No annotation file. You may compile with \"-dtypes\" option"))
+          (unless caml-types-buffer 
+            (setq caml-types-buffer
+                  (get-buffer-create caml-types-buffer-name)))
+          ;; (message "Drag the mouse to explore types")
+          (unwind-protect
+              (caml-track-mouse
+               (setq region
+                     (caml-types-typed-make-overlay
+                      target-buf (caml-event-point-start event)))
+               (while (and event
+                           (integer-or-marker-p
+                            (setq cnum (caml-event-point-end event))))
+                 (if (and region (<= (car region) cnum) (<= cnum (cdr region)))
+                     (if (and limits
+                              (>= cnum (car limits)) (< cnum (cdr limits)))
+                         (message mes)
+                       (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 () caml-types-annotation-tree))
+                         (set-buffer caml-types-buffer)
+                         (erase-buffer)
+                         (cond
+                          (node
+                           (setq 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 (elt node 2))
+                           )
+                          (t
+                           (delete-overlay caml-types-expr-ovl)
+                           (setq type "*no type information*")
+                           (setq limits
+                                 (caml-types-find-interval
+                                  target-buf target-pos
+                                  caml-types-annotation-tree))
+                           ))
+                         (message (setq mes (format "type: %s" type)))
+                         (insert type)
+                         )))
+                 (setq event (caml-read-event))
+                 (unless (mouse-movement-p event) (setq event nil))
+                 )
+               )
+            (delete-overlay caml-types-expr-ovl)
+            (delete-overlay caml-types-typed-ovl)
+            ))
+      ;; the mouse is down. One should prevent against mouse release,
+      ;; which could do something undesirable.
+      ;; In most common cases, next event will be mouse release.
+      ;; However, it could also be a character stroke before mourse release.
+      ;; Will then execute the action for mouse release (if bound).
+      ;; Emacs does not allow to test whether mouse is up or down.
+      ;; Same problem may happen abouve while exploring
+      (if (and event (caml-read-event)))
+      ))
 
 (defun caml-types-typed-make-overlay (target-buf pos)
   (interactive "p")
diff --git a/emacs/caml-xemacs.el b/emacs/caml-xemacs.el
index 9fae982c93..b1b01bd63e 100644
--- a/emacs/caml-xemacs.el
+++ b/emacs/caml-xemacs.el
@@ -12,8 +12,9 @@
 (defun caml-event-window (e) (event-window e))
 (defun caml-event-point-start (e) (event-closest-point e))
 (defun caml-event-point-end (e) (event-closest-point e))
-(defalias 'caml-track-mouse 'progn)
 (defalias 'caml-read-event 'next-event)
+(defmacro caml-track-mouse (&rest body) (cons 'progn body))
+
 (defun mouse-movement-p (e) (equal (event-type e) 'motion))
 
 (provide 'caml-xemacs)
diff --git a/emacs/caml.el b/emacs/caml.el
index 68b4ee43c3..74ad3731b2 100644
--- a/emacs/caml.el
+++ b/emacs/caml.el
@@ -283,6 +283,8 @@ have caml-electric-indent on, which see.")
 
   ;; caml-types
   (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type)
+  ;; to prevent misbehavior in case of error during exploration.
+  (define-key caml-mode-map [mouse-2] 'caml-types-mouse-ignore)
   (define-key caml-mode-map [down-mouse-2] 'caml-types-explore)
   ;; caml-help
   (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path)