[nongnu] externals/caml 5732aaa 077/197: Changes to caml-types.el:

[Stefan Monnier]

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

    Changes to caml-types.el:
     - added mouse exploration
     - revert annotation buffer when changed
     - narrow annotation buffer
     - added prefix arg to show annotation buffer
    
    Changers to ocaml.el:
     - made caml-types and caml-help autoloaded.
     - move bindings from  caml-help and caml-types into caml.el
    
    
    git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5732 
f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
---
 caml-help.el  |  52 +++++-----
 caml-types.el | 304 ++++++++++++++++++++++++++++++++++++++++++----------------
 caml.el       |  55 ++++++++++-
 3 files changed, 302 insertions(+), 109 deletions(-)

diff --git a/caml-help.el b/caml-help.el
index 881a557..5902abf 100644
--- a/caml-help.el
+++ b/caml-help.el
@@ -314,7 +314,7 @@ with an optional non-nil argument.
       )))
 
 (defun caml-complete (arg)
-  "Does completion for qualified identifiers. 
+  "Does completion for OCaml identifiers qualified. 
 
 It attemps to recognize an qualified identifier Module . entry 
 around point using function \\[ocaml-qualified-identifier].
@@ -607,7 +607,7 @@ current buffer using \\[ocaml-qualified-identifier]."
     ))
 
 (defun caml-help (arg)
-  "Find help for qualified identifiers. 
+  "Find documentation for OCaml qualified identifiers. 
 
 It attemps to recognize an qualified identifier of the form
 ``Module . entry'' around point using function `ocaml-qualified-identifier'.
@@ -770,30 +770,30 @@ buffer positions."
 
   
 
-;; bindings
-
-(and
- (boundp 'caml-mode-map)
- (keymapp caml-mode-map)
- (progn 
-   (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path)
-   (define-key caml-mode-map [?\C-c?]] 'ocaml-close-module)
-   (define-key caml-mode-map [?\C-c?[] 'ocaml-open-module)
-   (define-key caml-mode-map [?\C-c?\C-h] 'caml-help)
-   (define-key caml-mode-map [?\C-c?\t] 'caml-complete)
-   (let ((map (lookup-key caml-mode-map [menu-bar caml])))
-     (and
-      (keymapp map)
-      (progn
-        (define-key map [separator-help] '("---"))
-        (define-key map [open] '("Open add path" . ocaml-add-path ))
-        (define-key map [close]
-          '("Close module for help" . ocaml-close-module))
-        (define-key map [open] '("Open module for help" . ocaml-open-module))
-        (define-key map [help] '("Help for identifier" . caml-help))
-        (define-key map [complete] '("Complete identifier" . caml-complete))
-        ) 
-   ))))
+;; bindings ---now in caml.el
+
+; (and
+;  (boundp 'caml-mode-map)
+;  (keymapp caml-mode-map)
+;  (progn 
+;    (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path)
+;    (define-key caml-mode-map [?\C-c?]] 'ocaml-close-module)
+;    (define-key caml-mode-map [?\C-c?[] 'ocaml-open-module)
+;    (define-key caml-mode-map [?\C-c?\C-h] 'caml-help)
+;    (define-key caml-mode-map [?\C-c?\t] 'caml-complete)
+;    (let ((map (lookup-key caml-mode-map [menu-bar caml])))
+;      (and
+;       (keymapp map)
+;       (progn
+;         (define-key map [separator-help] '("---"))
+;         (define-key map [open] '("Open add path" . ocaml-add-path ))
+;         (define-key map [close]
+;           '("Close module for help" . ocaml-close-module))
+;         (define-key map [open] '("Open module for help" . ocaml-open-module))
+;         (define-key map [help] '("Help for identifier" . caml-help))
+;         (define-key map [complete] '("Complete identifier" . caml-complete))
+;         ) 
+;    ))))
 
 
 (provide 'caml-help)
diff --git a/caml-types.el b/caml-types.el
index 277d8e6..4f86bf8 100644
--- a/caml-types.el
+++ b/caml-types.el
@@ -12,35 +12,40 @@
 
 ;(* $Id$ *)
 
-
 ; An emacs-lisp complement to the "-dtypes" option of ocamlc and ocamlopt.
 
-; Format of the *.annot files:
 
-; 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
+(defvar caml-types-location-re nil "Regexp to parse *.annot files.
+
+Annotation files *.annot may be generated with the \"-dtypes\" option 
+of ocamlc and ocamlopt. 
+
+Their format is:
 
-; <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 O'Caml
-; 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.
+  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
 
-; 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.
+  <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 O'Caml
+  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.
 
-; For the moment, the only possible keyword is "type".
+- 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.
 
+For the moment, the only possible keyword is \"type\"."
+)
 
 (let* ((caml-types-filename-re "\"\\(\\([^\\\"]\\|\\\\.\\)*\\)\"")
        (caml-types-number-re "\\([0-9]*\\)")
@@ -49,15 +54,15 @@
                 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))
+  (setq caml-types-location-re 
+        (concat "^" caml-types-position-re " " caml-types-position-re)
+        ))
+(defvar 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))
+(defvar caml-types-type-ovl (make-overlay 1 1))
 (overlay-put caml-types-type-ovl 'face 'region)
 
-(defun caml-types-show-type ()
+(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
@@ -72,8 +77,12 @@
    . 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."
-  (interactive)
+     in the file, up to where the type checker failed.
+
+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-date (nth 5 (file-attributes (buffer-file-name))))
@@ -88,6 +97,7 @@
         (message (format "%s is more recent than %s" target-file type-file))
       (save-excursion
         (set-buffer type-buf)
+        (widen)
         (goto-char (point-min))
         (let ((loc (caml-types-find-location target-file target-line
                                              target-bol target-cnum)))
@@ -95,26 +105,35 @@
               (progn
                 (delete-overlay caml-types-expr-ovl)
                 (delete-overlay caml-types-type-ovl)
-                (message "Point is not within a typechecked expression or 
pattern."))
+                (message
+                 "Point is not within a typechecked expression or pattern.")
+                (narrow-to-region 1 1)
+                )
             (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))
-            (re-search-forward "^type(");; not strictly correct
-            (forward-line 1)
-            (re-search-forward "  \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)")
-            (move-overlay caml-types-type-ovl (match-beginning 1) (match-end 1)
-                          type-buf)
+            ;; not strictly correct
+            (re-search-forward
+             "^type(\n  \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)")
+             ;; (move-overlay caml-types-type-ovl
+             ;; (match-beginning 1) (match-end 1)
+             ;;   type-buf)
             (message (format "type: %s" (match-string 1)))
-            (set-mark (match-beginning 1)))))
-      (let
-          ((window (get-buffer-window type-buf))
-           (this-window (selected-window)))
-        (if window
-            (progn
-              (select-window window)
-              (goto-char (mark))
-              (select-window this-window))))
+            (narrow-to-region (match-beginning 0) (match-end 0))
+            ; (set-mark (match-beginning 1))
+            )))
+      (if (and (= arg 4)
+               (not (window-live-p (get-buffer-window type-buf))))
+          (display-buffer type-buf))
+ ;       (let
+ ;           ((window (get-buffer-window type-buf))
+ ;            (this-window (selected-window)))
+ ;         (if window
+ ;             (progn
+ ;               (select-window window)
+ ;               (goto-char (mark))
+ ;               (select-window this-window))))
       (unwind-protect
           (sit-for 60)
         (delete-overlay caml-types-expr-ovl)))))
@@ -125,23 +144,63 @@
            (< (nth 1 date1) (nth 1 date2)))))
 
 (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)
-        (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)))))))))
+  (catch 'exit
+    (while (re-search-forward caml-types-location-re () t)
+      (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))))))))
+
+(defun caml-types-find-inside ()
+  ;; durty code to retreive the matching Region determined by Left-Right
+  (goto-char (match-beginning 0))
+  (if (looking-at caml-types-location-re) nil
+    (error 'ocaml-types-find-inside))
+  (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)))
+        left right)
+  ;; we are searching for a region inside Region.
+   (catch 'exit
+     (while (and (or (not left) (not right))
+                 (re-search-backward caml-types-location-re nil t))
+       (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 (caml-types-pos<= right-file right-line right-bol right-cnum
+                               Left-file Left-line Left-bol Left-cnum)
+             (throw 'exit nil)
+           (if (caml-types-pos> Right-file Right-line Right-bol Right-cnum
+                                right-file right-line right-bol right-cnum)
+               (setq right (+ right-bol right-cnum)))
+           (if (caml-types-pos> left-file left-line left-bol left-cnum
+                                Left-file Left-line Left-bol Left-cnum)
+               (setq left (+ left-bol left-cnum)))
+           ))))
+   ;; if no region is found, make its intersection with Region is empty
+   (cons (or left (+ Right-bol Right-cnum))
+         (or right (+ Left-bol Left-cnum)))
+   ))
 
 
 ;; Warning: these comparison functions are not symmetric.
@@ -164,6 +223,7 @@
              (and (= line1 line2)
                   (> (- cnum1 bol1) (- cnum2 bol2)))))))
 
+
 (defun caml-types-get-pos (buf line col)
   (save-excursion
     (set-buffer buf)
@@ -173,28 +233,110 @@
 
 ; find-file-read-only-noselect seems to be missing from emacs...
 (defun caml-types-find-file (name)
-  (or (and (get-file-buffer name)
-           (find-file-noselect name))
-      (let ((buf (find-file-noselect name)))
-        (save-excursion
-          (set-buffer buf)
-          (toggle-read-only 1))
-        buf)))
+  (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 "No annotation file. You may compile with \"-dtypes\" option"))
+    )
+  buf))
+
+(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."
+  (interactive "e")
+  (set-buffer (window-buffer (posn-window (event-start event))))
+  (let* ((target-buf (current-buffer))
+         (target-file (file-name-nondirectory (buffer-file-name)))
+         (target-date (nth 5 (file-attributes (buffer-file-name))))
+         (type-file (concat (file-name-sans-extension (buffer-file-name))
+                            ".annot"))
+         (type-date (nth 5 (file-attributes type-file)))
+         (type-buf (caml-types-find-file type-file))
+         (target-line) (target-bol)
+         Left left Right right pos loc mes 
+         )
+    (if (caml-types-date< type-date target-date)
+        (error (format "%s is more recent than %s" target-file type-file)))
+    ; (message "Drap the mouse to explore types")
+    (unwind-protect
+        (track-mouse
+          (while (and event
+                      (integer-or-marker-p
+                       (setq pos (posn-point (event-start event)))))
+            (if (and Left Right (>= pos Left) (< pos Right)
+                     (<= pos left) (>= pos right))
+                (message mes)
+              (setq target-bol 
+                    (save-excursion (goto-char pos) (line-beginning-position)))
+              (setq target-line
+                    (1+ (count-lines (point-min) target-bol)))
+              (save-excursion
+                (set-buffer type-buf)
+                (widen)
+                (goto-char (point-min))
+                (setq loc
+                      (caml-types-find-location
+                       target-file target-line target-bol pos))
+                (cond
+                 (loc
+                  (setq Left (caml-types-get-pos
+                              target-buf (nth 0 loc) (nth 1 loc)))
+                  (setq Right (caml-types-get-pos
+                               target-buf (nth 2 loc) (nth 3 loc)))
+                  (move-overlay caml-types-expr-ovl Left Right
+                                target-buf)
+                  (save-excursion
+                    (let ((inside (caml-types-find-inside)))
+                    (setq left (car inside) right (cdr inside))))
+                  (re-search-forward
+                       "^type(\n  \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)")
+                  (setq mes (format "type: %s" (match-string 1)))
+                  (narrow-to-region (match-beginning 0) (match-end 0))
+                  )
+                 (t
+                  (delete-overlay caml-types-expr-ovl)
+                  (setq mes nil)
+                  (narrow-to-region 1 1)
+                  (setq Left (setq right nil)))
+                 ))
+              (message mes)
+              )
+              (setq event (read-event))
+              (unless (mouse-movement-p event) (setq event nil))
+            )
+          )
+    (delete-overlay caml-types-expr-ovl))
+    ))
+
 
 
 ;; bindings
 
-(and
- (boundp 'caml-mode-map)
- (keymapp caml-mode-map)
- (progn 
-   (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type)
-   (let ((map (lookup-key caml-mode-map [menu-bar caml])))
-     (and
-      (keymapp map)
-      (progn
-        (define-key map [separator-types] '("---"))
-        (define-key map [show-type]
-          '("Show type at point" . caml-types-show-type )))))))
+;; now in caml.el
+; (and
+;  (boundp 'caml-mode-map)
+;  (keymapp caml-mode-map)
+;  (progn 
+;    (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type)
+;    (define-key caml-mode-map [down-mouse-2] 'caml-types-explore)
+;    (let ((map (lookup-key caml-mode-map [menu-bar caml])))
+;      (and
+;       (keymapp map)
+;       (progn
+;         (define-key map [separator-types] '("---"))
+;         (define-key map [show-type]
+;           '("Show type at point" . caml-types-show-type )))))))
 
 (provide 'caml-types)
diff --git a/caml.el b/caml.el
index 752db2d..d6791b6 100644
--- a/caml.el
+++ b/caml.el
@@ -280,6 +280,17 @@ have caml-electric-indent on, which see.")
   (if running-xemacs
       (define-key caml-mode-map 'backspace 'backward-delete-char-untabify)
     (define-key caml-mode-map "\177" 'backward-delete-char-untabify))
+
+  ;; caml-types
+  (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type)
+  (define-key caml-mode-map [down-mouse-2] 'caml-types-explore)
+  ;; caml-help
+  (define-key caml-mode-map [?\C-c?i] 'ocaml-add-path)
+  (define-key caml-mode-map [?\C-c?]] 'ocaml-close-module)
+  (define-key caml-mode-map [?\C-c?[] 'ocaml-open-module)
+  (define-key caml-mode-map [?\C-c?\C-h] 'caml-help)
+  (define-key caml-mode-map [?\C-c?\t] 'caml-complete)
+  ;; others
   (define-key caml-mode-map "\C-cb" 'caml-insert-begin-form)
   (define-key caml-mode-map "\C-cf" 'caml-insert-for-form)
   (define-key caml-mode-map "\C-ci" 'caml-insert-if-form)
@@ -299,12 +310,29 @@ have caml-electric-indent on, which see.")
   (define-key caml-mode-map "\M-\C-h" 'caml-mark-phrase)
   (define-key caml-mode-map "\M-\C-q" 'caml-indent-phrase)
   (define-key caml-mode-map "\M-\C-x" 'caml-eval-phrase)
+
   (if running-xemacs nil ; if not running xemacs
     (let ((map (make-sparse-keymap "Caml"))
           (forms (make-sparse-keymap "Forms")))
       (define-key caml-mode-map "\C-c\C-d" 'caml-show-imenu)
       (define-key caml-mode-map [menu-bar] (make-sparse-keymap))
       (define-key caml-mode-map [menu-bar caml] (cons "Caml" map))
+      ;; caml-help
+
+      (define-key map [open] '("Open add path" . ocaml-add-path ))
+      (define-key map [close]
+         '("Close module for help" . ocaml-close-module))
+      (define-key map [open] '("Open module for help" . ocaml-open-module))
+      (define-key map [help] '("Help for identifier" . caml-help))
+      (define-key map [complete] '("Complete identifier" . caml-complete))
+      (define-key map [separator-help] '("---"))
+
+      ;; caml-types
+      (define-key map [show-type]
+          '("Show type at point" . caml-types-show-type ))
+      (define-key map [separator-types] '("---"))
+
+      ;; others
       (define-key map [run-caml] '("Start subshell..." . run-caml))
       (define-key map [compile] '("Compile..." . compile))
       (define-key map [switch-view]
@@ -345,7 +373,16 @@ have caml-electric-indent on, which see.")
         "---"
         [ "Switch view" caml-find-alternate-file t ]
         [ "Compile..." compile t ]
-        [ "Start subshell..." run-caml t ]))
+        [ "Start subshell..." run-caml t ]
+        "---"
+        [ "Show type at point" caml-types-show-type t ]
+        "---"
+        [ "Complete identifier" caml-complete t ]
+        [ "Help for identifier" caml-help t ]
+        [ "Add path for documentation" ocaml-add-path t ]
+        [ "Open module for documentation" ocaml-open t ]
+        [ "Close module for documentation" ocaml-close t ]
+        ))
   "Menu to add to the menubar when running Xemacs")
 
 (defvar caml-mode-syntax-table nil
@@ -1835,7 +1872,21 @@ with prefix arg, indent that many phrases starting with 
the current phrase."
 
 (autoload 'run-caml "inf-caml" "Run an inferior Caml process." t)
 
-(load "caml-types")
+(autoload 'caml-types-show-type "caml-types"
+  "Show the type of expression or pattern at point." t)
+(autoload 'caml-types-explore "caml-types"
+  "Explore type annotations by mouse dragging." t)
+
+(autoload 'caml-help "caml-help"
+  "Show documentation for qualilifed OCaml identifier." t)
+(autoload 'caml-complete "caml-help"
+  "Does completion for documented qualified OCaml identifier." t)
+(autoload 'ocaml-open-module "caml-help"
+  "Add module in documentation search path." t)
+(autoload 'ocaml-close-module "caml-help"
+  "Remove module from documentation search path." t)
+(autoload 'ocaml-add-path "caml-help"
+  "Add search path for documentation." t)
 
 ;;; caml.el ends here