amelioration .mly .mll

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

1 files changed, 104 insertions, 42 deletions

diff --git a/emacs/caml-types.el b/emacs/caml-types.el
index 86e1706a11..36978c54f7 100644
--- a/emacs/caml-types.el
+++ b/emacs/caml-types.el
@@ -23,16 +23,35 @@
 ; which is convenient if the type doesn't fit on a line.
 ; (doesn't work very well).
 
+
+; Hints on using the type display:
+
+; . If you want the type of an identifier, put the cursor in any
+;   occurrence of this identifier (as expression or as pattern) and
+;   type C-c C-t
+; . If you want the result type of a function application, put the
+;   cursor at the first space after the function name
+; . If you want the type of a parenthesized expression, put the
+;   cursor at the first space after the open parenthesis
+; . If you want the type of a list, put the cursor on a bracket,
+;   or on a semicolon, or on the :: constructor
+; . Even if type checking fails, you can still look at the types
+;   in the file, up to and including where the type checker failed.
+
+
+
 ; TO DO:
+; - make it work with camlp4-processed files
 ; - make emacs scroll the .types file when we move the point there,
 ;   even if the file is already displayed
-; - emit a warning when the .ml file is more recent than the .types
-; - make the command work only in caml-mode
-; - integrate this file into caml.el (?)
-; - write a proper documentation string for caml-types-show-type
-; - make it work correctly for preprocessed files (.mly, .mll)
+; - (?) integrate this file into caml.el
+; - (?) use dichotomy to find the location faster in the .types file
 
-(setq caml-types-filename-re "\"\\([^\\\"]\\|\\\\.\\)*\"")
+      
+; (global-set-key "\C-c\C-t" 'caml-types-show-type)
+
+
+(setq caml-types-filename-re "\"\\(\\([^\\\"]\\|\\\\.\\)*\\)\"")
 (setq caml-types-number-re "\\([0-9]*\\)")
 (setq caml-types-position-re
       (concat caml-types-filename-re " "
@@ -45,46 +64,89 @@
 (overlay-put caml-types-expr-ov 'face 'region)
 (setq caml-types-type-ov (make-overlay 1 1))
 (overlay-put caml-types-type-ov 'face 'region)
+(setq caml-types-not-found-msg
+      "The cursor is not within a typechecked expression or pattern.")
 
 (defun caml-types-show-type ()
-  "blah"
+  "Highlight the smallest expression that contains the cursor,
+   and display its type in the minibuffer."
   (interactive)
   (let* (type-point
-         (target (point))
-         (targetbuf (current-buffer))
-         (typefile (concat (file-name-sans-extension (buffer-file-name))
-                           ".types"))
-         (tbuf (or (get-file-buffer typefile)
-                   (find-file-noselect typefile))))
-    (save-excursion
-      (set-buffer tbuf)
-      (goto-char (point-min))
-      (let ((loc (caml-types-find-location target)))
-        (if (null loc)
-            (progn
-              (move-overlay caml-types-expr-ov 1 1)
-              (move-overlay caml-types-type-ov 1 1)
-              (message "The cursor is not within an expression."))
-          (move-overlay caml-types-expr-ov (car loc) (cdr loc) targetbuf)
-          (forward-line 2)
-          (re-search-forward "  \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)")
-          (move-overlay caml-types-type-ov (match-beginning 1) (match-end 1)
-                        (current-buffer))
-          (message (concat "type: " (match-string 1)))
-          (setq type-point (match-beginning 1)))))
-    (if (null type-point)
-        ()
-      (set-buffer tbuf)
-      (goto-char type-point)
-      (set-buffer targetbuf))))
-
-(defun caml-types-find-location (target)
-  (let (left right found)
+         (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-col (- (point) (line-beginning-position)))
+         (target-buf (current-buffer))
+         (type-file (concat (file-name-sans-extension (buffer-file-name))
+                            ".types"))
+         (type-date (nth 5 (file-attributes type-file)))
+         (type-buf (find-file-noselect 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)
+        (goto-char (point-min))
+        (let ((loc (caml-types-find-location target-file target-line
+                                             target-col)))
+          (if (null loc)
+              (progn
+                (move-overlay caml-types-expr-ov 1 1)
+                (move-overlay caml-types-type-ov 1 1)
+                (message caml-types-not-found-msg))
+            (let ((left (caml-types-get-pos target-buf (car loc)))
+                  (right (caml-types-get-pos target-buf (cdr loc))))
+              (move-overlay caml-types-expr-ov left right target-buf))
+            (forward-line 2)
+            (re-search-forward "  \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)")
+            (move-overlay caml-types-type-ov (match-beginning 1) (match-end 1)
+                          type-buf)
+            (message (format "type: %s" (match-string 1)))
+            (setq type-point (match-beginning 1)))))
+      (if (null type-point)
+          ()
+        (set-buffer type-buf)
+        (goto-char type-point)
+        (set-buffer target-buf)))))
+
+(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-pair=< (p1 p2)
+  (or (< (car p1) (car p2))
+      (and (= (car p1) (car p2))
+           (<= (cdr p1) (cdr p2)))))
+
+(defun caml-types-find-location (target-file target-line target-col)
+  (let (left-file left-line left-bol left-char
+        right-file right-line right-bol right-char
+        found)
     (catch 'exit
       (while (re-search-forward caml-types-location-re () t)
-        (setq left (1+ (string-to-int (match-string 4))))
-        (setq right (1+ (string-to-int (match-string 8))))
-        (if (and (<= left target) (< target right))
-            (throw 'exit (cons left right)))))))
+        (setq left-file (file-name-nondirectory (match-string 1)))
+        (setq left-line (string-to-int (match-string 3)))
+        (setq left-bol (string-to-int (match-string 4)))
+        (setq left-cnum (string-to-int (match-string 5)))
+        (setq right-file (file-name-nondirectory (match-string 6)))
+        (setq right-line (string-to-int (match-string 8)))
+        (setq right-bol (string-to-int (match-string 9)))
+        (setq right-cnum (string-to-int (match-string 10)))
+        (let ((left-col (- left-cnum left-bol))
+              (right-col (- right-cnum right-bol))
+              (target-line-col (cons target-line target-col)))
+          (if (and (string= left-file target-file)
+                   (string= right-file target-file)
+                   (caml-types-pair=< (cons left-line left-col) target-line-col)
+                   (not (caml-types-pair=< (cons right-line right-col)
+                                           target-line-col)))
+              (throw 'exit (cons (cons left-line left-col)
+                                 (cons right-line right-col))))))
+      ())))
 
-(global-set-key "\C-c\C-t" 'caml-types-show-type)
+(defun caml-types-get-pos (buf pos)
+  (save-excursion
+    (set-buffer buf)
+    (goto-line (car pos))
+    (forward-char (cdr pos))
+    (point)))