[nongnu] externals/caml 099dbf5 067/197: -stypes -> -dtypes; meilleur mode emacs

[Stefan Monnier]

branch: externals/caml
commit 099dbf535b47f9c098f94ebdc4a4bc6b827690eb
Author: Damien Doligez <damien.doligez-inria.fr>
Commit: Damien Doligez <damien.doligez-inria.fr>

    -stypes -> -dtypes; meilleur mode emacs
    
    
    git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5494 
f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
---
 caml-types.el | 170 ++++++++++++++++++++++++++++++++--------------------------
 1 file changed, 95 insertions(+), 75 deletions(-)

diff --git a/caml-types.el b/caml-types.el
index 36978c5..f08fa21 100644
--- a/caml-types.el
+++ b/caml-types.el
@@ -15,13 +15,12 @@
 ; WARNING:
 ; This code is experimental.  Everything may change at any time.
 
-; An emacs-lisp complement to the "-stypes" option of ocamlc and ocamlopt.
+; An emacs-lisp complement to the "-dtypes" option of ocamlc and ocamlopt.
 ; Load this file in your emacs, then C-c C-t will show you the
-; type of the expression that contains the cursor.
+; type of the expression (or pattern) that contains the cursor.
 ; The expression is highlighted in the current buffer.
 ; The type is highlighted in "foo.types" (if your file is "foo.ml"),
-; which is convenient if the type doesn't fit on a line.
-; (doesn't work very well).
+; which is convenient when the type doesn't fit on a line.
 
 
 ; Hints on using the type display:
@@ -31,122 +30,143 @@
 ;   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.
+; . The system doesn't "see" parentheses and begin/end.  If you
+;   put the cursor on a parenthesis, you will have the type of
+;   the expression that contains the parenthesized expression.
+;   If you want the parenthesized expression, you need to put the
+;   cursor inside it (for example, in a space between its words).
+; . To get rid of the highlighting, put the cursor in a comment
+;   and type C-c C-t.
+; . The mark in the .types file is set to the beginning of the
+;   type, so you can type C-x C-x to view the type in that file.
 
 
 
 ; 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
+; - make emacs scroll the .types file to show the type
 ; - (?) integrate this file into caml.el
-; - (?) use dichotomy to find the location faster in the .types file
 
       
 ; (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 " "
-              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))
-(setq caml-types-expr-ov (make-overlay 1 1))
-(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.")
+(let* ((caml-types-filename-re "\"\\(\\([^\\\"]\\|\\\\.\\)*\\)\"")
+       (caml-types-number-re "\\([0-9]*\\)")
+       (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)))
+
+(setq caml-types-expr-ovl (make-overlay 1 1))
+(overlay-put caml-types-expr-ovl 'face 'region)
+(setq caml-types-type-ovl (make-overlay 1 1))
+(overlay-put caml-types-type-ovl 'face 'region)
 
 (defun caml-types-show-type ()
   "Highlight the smallest expression that contains the cursor,
    and display its type in the minibuffer."
   (interactive)
-  (let* (type-point
+  (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-col (- (point) (line-beginning-position)))
-         (target-buf (current-buffer))
+         (target-bol (line-beginning-position))
+         (target-cnum (point))
          (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)))
+         (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)
         (goto-char (point-min))
         (let ((loc (caml-types-find-location target-file target-line
-                                             target-col)))
+                                             target-bol target-cnum)))
           (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))
+                (move-overlay caml-types-expr-ovl 1 1)
+                (move-overlay caml-types-type-ovl 1 1)
+                (message "The cursor is not within a typechecked expression or 
pattern."))
+            (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))
             (forward-line 2)
             (re-search-forward "  \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)")
-            (move-overlay caml-types-type-ov (match-beginning 1) (match-end 1)
+            (move-overlay caml-types-type-ovl (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)))))
+            ; *** this doesn't seem to work, I don't know why...
+            ; *** (goto-char type-point)
+            ; *** workaround: set the mark instead
+            (set-mark (match-beginning 1))
+            (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)
+(defun caml-types-find-location (targ-file targ-line targ-bol targ-cnum)
+  (let (found)
     (catch 'exit
       (while (re-search-forward caml-types-location-re () t)
-        (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))))))
-      ())))
-
-(defun caml-types-get-pos (buf pos)
+        (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)))))))))
+
+
+;; 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 (car pos))
-    (forward-char (cdr pos))
+    (goto-line line)
+    (forward-char col)
     (point)))
+
+; find-file-read-only-noselect seems to be missing from emacs...
+(defun caml-types-find-file (name)
+  (or (get-file-buffer name)
+      (let ((buf (find-file-noselect name)))
+        (save-excursion
+          (set-buffer buf)
+          (toggle-read-only 1))
+        buf)))