[nongnu] externals/caml d7bde19 088/197: Modified `caml-types-explore' so that all well-typed subexpressions of the

[Stefan Monnier]

branch: externals/caml
commit d7bde19e34559e9ed2f797d96d5f7e68a2719082
Author: Didier Rémy <Didier.Remy@inria.fr>
Commit: Didier Rémy <Didier.Remy@inria.fr>

    Modified `caml-types-explore' so that all well-typed subexpressions of the
    current phrase are colored during exploration. -Didier
    
    
    git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5760 
f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
---
 caml-emacs.el |   2 +-
 caml-help.el  |   2 +-
 caml-types.el | 116 ++++++++++++++++++++++++++++++++++++++--------------------
 3 files changed, 78 insertions(+), 42 deletions(-)

diff --git a/caml-emacs.el b/caml-emacs.el
index 01a575e..571dd78 100644
--- a/caml-emacs.el
+++ b/caml-emacs.el
@@ -6,7 +6,7 @@
 (defalias 'caml-line-beginning-position 'line-beginning-position)
 
 (defun caml-event-window (e) (posn-window (event-start e)))
-(defun caml-event-point-start (e) (posn-point (event-stact 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)
diff --git a/caml-help.el b/caml-help.el
index 69e5b1c..d2a448b 100644
--- a/caml-help.el
+++ b/caml-help.el
@@ -720,7 +720,7 @@ buffer positions."
 (defun ocaml-link-goto (click)
   (interactive "e")
   (let* ((pos (caml-event-point-start click))
-         (buf (caml-event-window click))
+         (buf (window-buffer (caml-event-window click)))
          (window (selected-window))
          (link))
     (setq link
diff --git a/caml-types.el b/caml-types.el
index 01167b5..77612eb 100644
--- a/caml-types.el
+++ b/caml-types.el
@@ -71,6 +71,12 @@ For the moment, the only possible keyword is \"type\"."
 (if (not (face-differs-from-default-p 'caml-types-face))
     (set-face-background 'caml-types-face "#88FF44"))
 
+(make-face 'caml-typed-face)
+(set-face-doc-string 'caml-typed-face
+                     "face for hilighting typed expressions")
+(if (not (face-differs-from-default-p 'caml-typed-face))
+    (set-face-background 'caml-typed-face "#FF8844"))
+
 (overlay-put caml-types-expr-ovl 'face 'caml-types-face)
 
 
@@ -374,51 +380,81 @@ and its type is displayed in the minibuffer, until the 
move is released."
          target-pos
          Left Right limits cnum node mes type
          (tree caml-types-annotation-tree)
+         (unlocked font-lock-mode)
+         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")
+                                        ; (message "Drag the mouse to explore 
types")
     (unwind-protect
         (caml-track-mouse
-          (while (and event
-                      (integer-or-marker-p
-                       (setq cnum (caml-event-point-end event))))
-            (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))
-    ))
+         (setq region (caml-types-typed-region
+                       target-buf
+                       (caml-event-point-start event)))
+         (while (and event
+                     (integer-or-marker-p
+                      (setq cnum (caml-event-point-end event))))
+           (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)
+      (if unlocked (font-lock-mode 1)
+        (remove-text-properties (car region) (cdr region) '(face)))
+      )))
+
+(defun caml-types-typed-region (target-buf pos)
+  (interactive "p")
+  (if  (functionp 'caml-find-phrase)
+      (save-excursion
+        (goto-char pos)
+        (setq start (caml-find-phrase))
+        (setq end (point)))
+    (setq  start (point-min))
+    (setq end (point-max)))
+  (message "%S %S" start end)
+  (let (len node)
+      (setq len (length caml-types-annotation-tree))
+      (if font-lock-mode (font-lock-mode 0))
+      (while (> len 3)
+        (setq len (- len 1))
+        (setq node (aref caml-types-annotation-tree len))
+        (if (caml-types-pos-contains start end node)
+            (put-text-property
+             (caml-types-get-pos target-buf (elt node 0))
+             (caml-types-get-pos target-buf (elt node 1))
+             'face 'caml-typed-face))))
+    (cons start end))
 
 (provide 'caml-types)