Commits

camlspotter committed c808297 Merge

merge + dispatch application for type_expect

Comments (0)

Files changed (21)

boot/myocamlbuild.boot

Binary file modified.

boot/ocamlc

Binary file modified.

boot/ocamldep

Binary file modified.

boot/ocamllex

Binary file modified.

byterun/io.c

File contents unchanged.

ocamldoc/odoc_analyse.ml

File contents unchanged.

ocamlspot/Changes

 
 
 ocamlspot.el
+* ocamlspot-path is now ocamlspot-command. Please fix your .emacs.
+- defcustom'ed and code clean-ups (thanks to Sam Steingold) 
 - various elisp bug fixes
 - multi-byte character support in emacs
 

ocamlspot/ocamlspot.el

 ; (***********************************************************************)
 
 ; How-to-use
-; 
+;
 ; Write the following to your .emacs
 ;
-; ; load-path
+;; load-path
 ; (setq load-path (cons "WHERE-YOU-HAVE-INSTALLED-THE-ELISP" load-path))
 ;
-; ; set the path of the ocamlspot binary
-; (setq ocamlspot-path "WHERE-YOU-HAVE-INSTALLED-THE-BINARIES/ocamlspot")
+;; set the path of the ocamlspot binary
+;; this can be a shell command, e.g., "ocamlfind ocamlspot"
+; (setq ocamlspot-command "WHERE-YOU-HAVE-INSTALLED-THE-BINARIES/ocamlspot")
 ;
-; ; autoload
+;; autoload
 ; (autoload 'ocamlspot-query "ocamlspot" "OCamlSpot")
 ;
-; ; tuareg mode hook (use caml-mode-hook instead if you use caml-mode)
-;   (add-hook 'tuareg-mode-hook 
-;   	  '(lambda ()
-; 	     (local-set-key "\C-c;" 'ocamlspot-query)
-; 	     (local-set-key "\C-c\C-t" 'ocamlspot-type)
+;; tuareg mode hook (use caml-mode-hook instead if you use caml-mode)
+;   (add-hook 'tuareg-mode-hook
+;         '(lambda ()
+;            (local-set-key "\C-c;" 'ocamlspot-query)
+; 	     (local-set-key "\C-c:" 'ocamlspot-query-interface)
+;            (local-set-key "\C-c\C-t" 'ocamlspot-type)
 ;            (local-set-key "\C-c\C-y" 'ocamlspot-type-and-copy)
-; 	     (local-set-key "\C-c\C-u" 'ocamlspot-use)
-; 	     (local-set-key "\C-ct" 'caml-types-show-type)))
- 
-(defvar ocamlspot-buffer "*ocamlspot*")
+;            (local-set-key "\C-c\C-u" 'ocamlspot-use)
+;            (local-set-key "\C-ct" 'caml-types-show-type)))
+;
+;; You can also change overlay colors as follows:
+; (set-face-background 'ocamlspot-spot-face "#660000")
+; (set-face-background 'ocamlspot-tree-face "#006600")
+;
+; ocamlspot-query
+;   Show the type of the inner-most subexpression under the cursor.
+;   If there is an identifier under the cursor, browse and show its definition
+;
+; ocamlspot-query-interface
+;   Same as ocamlspot-query but browse identifier's interface rather than its defintion
+;   This is currently under construction and does not work properly.
+;
+; ocamlspot-type
+;   Show the type of the inner-most subexpression under the cursor.
+;
+; ocamlspot-type-and-copy
+;   Same as ocamlspot-type but it also copies the type expression to the kill buffer.
+;
+; ocamlspot-use
+;   Show the use information of the identifier under the cursor.
 
-(defvar ocamlspot-path "OCAML-SOURCE-TREE/ocamlspot/ocamlspot"
-  "ocamlspot program path")
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Configurable variables
 
-;; debug
+(eval-when-compile (require 'cl)) ; for `destructuring-bind'
 
-(defvar ocamlspot-debug nil "turn on debug output")
+(defgroup ocamlspot ()
+  "OCamlSpotter: find the definition and type of variables."
+  :group 'languages)
 
-(defvar ocamlspot-debug-buffer "*ocamlspot-debug*")
+(defcustom ocamlspot-command "OCAML-SOURCE-TREE/ocamlspot/ocamlspot"
+  "*The command which invokes ocamlspot."
+  :type 'string :group 'ocamlspot)
+
+(defcustom ocamlspot-debug nil
+  "*Turn on ocamlspot debug output."
+  :type 'boolean :group 'ocamlspot)
+
+(defcustom ocamlspot-support-older-version nil
+  "*If t, support an older command line interface for the first versions of ocamlspot, with an overhead of version detection. Useful with multiple versions of ocamlspot."
+  :type 'boolean :group 'ocamlspot)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Constants
+
+(defconst ocamlspot-buffer "*ocamlspot*"
+  "The name of ocamlspot communication buffer")
+
+(defconst ocamlspot-debug-buffer "*ocamlspot-debug*"
+  "The name of ocamlspot debugging buffer")
+
+(defconst ocamlspot-message-buffer "*ocamlspot-message*"
+  "The name of ocamlspot message buffer")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ocamlspot-path
+
+; ocamlspot-path is superceded by ocamlspot-command, but if it exists,
+; it overrides ocamlspot-command
+
+(defun ocamlspot-get-command ()
+  (if (boundp 'ocamlspot-path) ocamlspot-path ocamlspot-command))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Debugging
+
 (defun ocamlspot-debug-message (s)
-  (save-excursion
-    (if (get-buffer ocamlspot-debug-buffer) ()
-      (generate-new-buffer ocamlspot-debug-buffer))
-    (set-buffer ocamlspot-debug-buffer)
+  (with-current-buffer (get-buffer-create ocamlspot-debug-buffer)
     (insert s)
     (insert "\n")))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; column chars => column bytes
+
+; This looks complicated, but we need this conversion for multi-byte characters
+
+(defun ocamlspot-string-of-line-to-point ()
+  (buffer-substring-no-properties
+   (line-beginning-position) (point)))
+
+(defun ocamlspot-bytes-of-line-to-point ()
+  (length
+   (encode-coding-string
+    (ocamlspot-string-of-line-to-point) buffer-file-coding-system)))
+
+; It count one line less when the cursor is at (point-max) 
+; and it is at the top of the line.
+(defun ocamlspot-lines-of-point ()
+  (count-lines (point-min) (min (1+ (point)) (point-max))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; column bytes => column chars
+
+; This looks complicated, but we need this conversion for multi-byte characters
+
+; goto-line set mark and we see the result in the minibuffer
+(defun ocamlspot-goto-line (line)
+  (goto-char (point-min))
+  (forward-line (1- line)))
+
+;; get the string at line
+(defun ocamlspot-buffer-substring-at-line (line)
+  ; no need of save-excursion
+  (ocamlspot-goto-line line)
+  (buffer-substring-no-properties (line-beginning-position)
+                                  (line-end-position)))
+
+(defun ocamlspot-chars-of-bytes-of-string (str bytes)
+  (length
+   (decode-coding-string
+    (substring (encode-coding-string str buffer-file-coding-system)
+               0 bytes)
+    buffer-file-coding-system)))
+
+(defun ocamlspot-pos-of-bytes-at-line (line bytes)
+  ; no need of save-excursion
+  (ocamlspot-goto-line line)
+  (let ((pos-at-beginning-of-line (line-beginning-position))
+        (chars-from-beginning-of-line
+         (ocamlspot-chars-of-bytes-of-string
+          (ocamlspot-buffer-substring-at-line line) bytes)))
+    (+ pos-at-beginning-of-line chars-from-beginning-of-line)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; location parser
+
+; parses lxxxcxxxbxxx and returns the triplet
+(defun ocamlspot-parse-location (s)
+  (if (string-match "^l\\([\-0-9]+\\)c\\([\-0-9]+\\)b\\([\-0-9]+\\)$" s)
+      (let ((line (string-to-number
+                   (substring s (match-beginning 1) (match-end 1))))
+            (colbytes (string-to-number
+                       (substring s (match-beginning 2) (match-end 2))))
+            (bytes (string-to-number
+                       (substring s (match-beginning 3) (match-end 3)))))
+        (list line colbytes bytes))
+    ; older version
+    (if (string-match "^\\([\-0-9]+\\)$" s)
+        (let ((line -1)
+              (colbytes -1)
+              (bytes (string-to-number
+                      (substring s (match-beginning 1) (match-end 1)))))
+          (list line colbytes (+ bytes 1)))
+      nil)))
+
+(defun ocamlspot-pos-of-location (buffer s)
+  (destructuring-bind (line colbytes bytes) (ocamlspot-parse-location s)
+    (if (= line -1) bytes
+      (with-current-buffer buffer
+        (ocamlspot-pos-of-bytes-at-line line colbytes)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Messaging
+
+(defun ocamlspot-message-init ()
+  (setq ocamlspot-message-errors nil)
+  (with-current-buffer (get-buffer-create ocamlspot-message-buffer)
+    (erase-buffer)))
+
+(defun ocamlspot-message-add (mes)
+  (with-current-buffer (get-buffer-create ocamlspot-message-buffer)
+    (if (/= 0 (current-column))
+        (insert "\n"))
+    (insert mes)))
+
+; display message in the echo area if it is enough short, then return the string
+; otherwise, pop a buffer of the message if may-pop is t and return the buffer 
+; otherwise, returns nil
+(defun ocamlspot-message-display (&optional may-pop)
+  (with-current-buffer (get-buffer-create ocamlspot-message-buffer)
+    (let ((lines ; how many lines in minibuffer-window ? 
+           (count-screen-lines nil nil nil (minibuffer-window)))
+          (max-echo-height 
+           (if resize-mini-windows
+               (cond ((floatp max-mini-window-height)
+                      (* (frame-height) max-mini-window-height))
+                     ((integerp max-mini-window-height)
+                      max-mini-window-height)
+                     (t 1)))))
+
+      (if (or (<= lines  1)
+              (<= lines max-echo-height))
+          (progn
+            (let ((mes (buffer-string)))
+              (message mes)
+              mes))
+        (if may-pop ; buffer layout may change... no way to recover ?
+            (progn
+              (display-buffer ocamlspot-message-buffer)
+              ocamlspot-message-buffer)
+          ;; display the first max-echo-height lines
+          (let ((lines (max 1 (1- max-echo-height))))
+            (goto-char (point-min))
+            (forward-visible-line (max 1 (- max-echo-height 2)))
+            (message (concat (buffer-substring (point-min) (point)) "... Result is too long. Truncated."))
+            nil))))))
+    
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Overlays
+
 ;; the spot overlay
 (defvar ocamlspot-spot-overlay (make-overlay 1 1))
-(make-face 'ocamlspot-spot-face)
-(set-face-doc-string 'ocamlspot-spot-face "face for ocamlspot spot highlight")
-(set-face-background 'ocamlspot-spot-face "#88FF44")
+(defface ocamlspot-spot-face
+    '((t (:foreground "#88FF44")))
+  "Face for ocamlspot spot highlight"
+  :group 'ocamlspot)
 (overlay-put ocamlspot-spot-overlay 'face 'ocamlspot-spot-face)
 
 ;; the tree overlay
 (defvar ocamlspot-tree-overlay (make-overlay 1 1))
-(make-face 'ocamlspot-tree-face)
-(set-face-doc-string 'ocamlspot-tree-face "face for ocamlspot tree highlight")
-(set-face-background 'ocamlspot-tree-face "#FF88FF")
+(defface ocamlspot-tree-face
+    '((t (:foreground "#FF88FF")))
+  "Face for ocamlspot tree highlight"
+  :group 'ocamlspot)
 (overlay-put ocamlspot-tree-overlay 'face 'ocamlspot-tree-face)
 
 (defun ocamlspot-delete-overlays-now ()
       (sit-for 10)
     (ocamlspot-delete-overlays-now)))
 
-; (defun ocamlspot-cnum-of-point () (1- (point)))
-; (defun ocamlspot-char-of-cnum (n) (1+ n))
-
-(defun ocamlspot-find-file-existing (path)
-  (if (file-exists-p path)
-      (find-file-other-window path)
-    (message "ERROR: source file %s was not found" path)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; column chars => column bytes
-
-(defun ocamlspot-pos-beginning-of-line ()
-  (save-excursion
-    (beginning-of-line)
-    (point)))
- 
-(defun ocamlspot-string-of-line-to-point ()
-  (buffer-substring-no-properties 
-   (ocamlspot-pos-beginning-of-line) (point)))
-
-(defun ocamlspot-bytes-of-line-to-point ()
-  (length 
-   (encode-coding-string 
-    (ocamlspot-string-of-line-to-point) buffer-file-coding-system)))
-
-(defun ocamlspot-lines-of-point ()
-  (count-lines (point-min) (point)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; column bytes => column chars  
-
-; goto-line set mark and we see the result in the minibuffer
-(defun ocamlspot-goto-line (line)
-  (goto-char (point-min))
-  (forward-line (- line 1)))
-
-;; get the string at line
-(defun ocamlspot-buffer-substring-at-line (line)
-  ; no need of save-excursion
-  (ocamlspot-goto-line line)
-  (beginning-of-line)
-  (let ((start (point)))
-    (end-of-line)
-    (buffer-substring-no-properties start (point))))
-
-(defun ocamlspot-chars-of-bytes-of-string (str bytes)
-  (length 
-   (decode-coding-string 
-    (substring (encode-coding-string str buffer-file-coding-system)
-               0 bytes)
-    buffer-file-coding-system)))
-
-(defun ocamlspot-pos-of-bytes-at-line (line bytes)
-  ; no need of save-excursion
-  (ocamlspot-goto-line line)
-  (let ((pos-at-beginning-of-line (ocamlspot-pos-beginning-of-line))
-        (chars-from-beginning-of-line 
-         (ocamlspot-chars-of-bytes-of-string 
-          (ocamlspot-buffer-substring-at-line line) bytes)))
-    (+ pos-at-beginning-of-line chars-from-beginning-of-line)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; location parser
-
-; parses lxxxcxxxbxxx and returns the triplet
-(defun ocamlspot-parse-location (s)
-  (if (string-match "^l\\([\-0-9]+\\)c\\([\-0-9]+\\)b\\([\-0-9]+\\)$" s)
-      (let ((line (string-to-int 
-                   (substring s (match-beginning 1) (match-end 1))))
-            (colbytes (string-to-int
-                       (substring s (match-beginning 2) (match-end 2))))
-            (bytes (string-to-int
-                       (substring s (match-beginning 3) (match-end 3)))))
-        (list line colbytes bytes))
-    ; older version
-    (if (string-match "^\\([\-0-9]+\\)$" s)
-        (let ((line -1)
-              (colbytes -1)
-              (bytes (string-to-int
-                      (substring s (match-beginning 1) (match-end 1)))))
-          (list line colbytes bytes))
-      nil)))
-
-(defun ocamlspot-pos-of-location (buffer s)
-  (destructuring-bind (line colbytes bytes) (ocamlspot-parse-location s)
-    (if (= line -1) bytes
-      (save-excursion
-        (set-buffer buffer)
-        (ocamlspot-pos-of-bytes-at-line line colbytes)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; overlay handling
-
+; obsolete code, but probably useful in future
 ; (defun ocamlspot-display-overlay (filename position overlay)
 ;   (if (string-match "\.cm[ioxa]$" filename)
 ;       ;; It is not an .ml or .mli. Packed module.
-;       (progn 
+;       (progn
 ;         (message "Packed module: %s" filename)
 ;         ;; CR jfuruse: opening a binary file is not good
 ;         (setq target-buffer (ocamlspot-find-file-existing filename)))
 ;                 (move-overlay overlay start end target-buffer))))))))
 
 (defun ocamlspot-display-overlay (buffer position overlay)
-  (if (string-match "^\\(l[\-0-9]+c[\-0-9]+b[\-0-9]+\\|[\-0-9]+\\):\\(l[\-0-9]+c[\-0-9]+b[\-0-9]+\\|[\-0-9]+\\)$" position)
+  (if (string-match "^\\(l[\-0-9]+c[\-0-9]+b[\-0-9]+\\|[0-9]+\\):\\(l[\-0-9]+c[\-0-9]+b[\-0-9]+\\|[0-9]+\\)$" position)
       (let ((start (substring position (match-beginning 1) (match-end 1)))
             (end   (substring position (match-beginning 2) (match-end 2))))
         (let ((start (ocamlspot-pos-of-location buffer start))
           (goto-char start)
           (move-overlay overlay start end buffer)))
     ; this should be all
-    (progn
-      (display-buffer buffer)
-      (move-overlay overlay (point-min) (point-max) buffer))))
+    (display-buffer buffer)
+    (move-overlay overlay (point-min) (point-max) buffer)))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Warnings
 
 (defun ocamlspot-warning ()
-  (if (re-search-forward "^\\(Warning: .*\\)$" nil t)
-      (buffer-substring-no-properties (match-beginning 1) (match-end 1))
-    nil))
+  (and (re-search-forward "^\\(Warning: .*\\)$" nil t)
+       (buffer-substring-no-properties (match-beginning 1) (match-end 1))))
 
 (defun ocamlspot-warnings-rev (lst)
   (let ((warning (ocamlspot-warning)))
   (goto-char (point-min))
   (ocamlspot-warnings-rev ""))
 
-; launch ocamlspot 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; File access
+
+(defun ocamlspot-find-file-existing (path)
+  (if (file-exists-p path)
+      (find-file-other-window path)
+    (ocamlspot-message-add (format "ERROR: source file %s was not found" path))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Queries
+
+; It is all my failure, but the first versions of ocamlspot lacks clear notion
+; of versions. This function infers the command option interface of the command
+; from the help string. If t, ocamlspot cannot take line-bytes specifications.
+(defun ocamlspot-older-version ()
+  (if ocamlspot-support-older-version
+      (with-current-buffer (get-buffer-create ocamlspot-buffer)
+        (erase-buffer)
+        (call-process shell-file-name nil t nil shell-command-switch
+                      (concat (ocamlspot-get-command) " -help"))
+        (goto-char (point-min))
+        (re-search-forward "^ocamlspot path:charpos" nil t))
+    nil))
+
+; launch ocamlspot
 ; result is stored in the buffer "ocamlspot-buffer"
 ; the current buffer is stored in source_buffer
 (defun ocamlspot-gen-query (extra_args)
   (interactive)
+  (ocamlspot-message-init)
   (save-excursion
     (ocamlspot-delete-overlays-now)
     ;; arguments
     (let ((file-name (buffer-file-name))
-          (arg
-           (format "%s:l%dc%d"
-                   (buffer-file-name)
-                   (ocamlspot-lines-of-point)
-                   (ocamlspot-bytes-of-line-to-point))
-           ))
-      ;; ocamlspot buffer
-      (setq source-buffer (current-buffer))
-      (save-current-buffer
-        (set-buffer (get-buffer-create ocamlspot-buffer))
+          (arg (if (ocamlspot-older-version)
+                   ; older pos spec
+                   (format "%s:%d"
+                           (buffer-file-name)
+                           (1- (point)))
+                   ; newer pos spec
+                   (format "%s:l%dc%d"
+                           (buffer-file-name)
+                           (ocamlspot-lines-of-point)
+                           (ocamlspot-bytes-of-line-to-point))))
+          (source-buffer (current-buffer))) ; ocamlspot buffer
+      (with-current-buffer (get-buffer-create ocamlspot-buffer)
         (erase-buffer)
-        (let* ((debug
-  	      ; (if ocamlspot-debug '("--debug") nil))
-                (if ocamlspot-debug '("-debug") nil))
-  	     (command 
-  	      (append '(call-process ocamlspot-path nil ocamlspot-buffer nil)
-                        ; '("--version") ; it's new
-  		      debug
-  		      extra_args
-  		      '(arg))))
-          ;; chdir is required
-          (cd (file-name-directory file-name))
-  	(eval command))
+        ;; chdir is required
+        (cd (file-name-directory file-name))
+        (call-process shell-file-name nil t nil shell-command-switch
+                      (concat (ocamlspot-get-command) " " arg
+                              (if ocamlspot-debug " -debug " " ")
+                              extra_args))
         ;; search the found tree element
         (goto-char (point-min))
-        (if (re-search-forward "^Tree: \\(l[\-0-9]+c[\-0-9]+b[\-0-9]+:l[\-0-9]+c[\-0-9]+b[\-0-9]+\\)$" 
-  			     nil t)
+        (if (re-search-forward "^Tree: \\(l[\-0-9]+c[\-0-9]+b[\-0-9]+:l[\-0-9]+c[\-0-9]+b[\-0-9]+\\|[0-9]+:[0-9]+\\)$"
+                               nil t)
             (let ((pos (buffer-substring (match-beginning 1) (match-end 1))))
               ;; display the result
               (save-current-buffer
                 (ocamlspot-display-overlay source-buffer pos ocamlspot-tree-overlay))
-              (message (ocamlspot-warnings))
+              (ocamlspot-message-add (ocamlspot-warnings))
               t)
-          (progn 
-            (if (re-search-forward "^\\(Error: .*\\)" nil t)
-                (message (buffer-substring (match-beginning 1) (match-end 1)))
+          (if (re-search-forward "^\\(Error: .*\\)" nil t)
+              (ocamlspot-message-add (buffer-substring (match-beginning 1) (match-end 1)))
               ;; display debug info
-              (message "ERROR: no tree node found there"))
-            nil))))))
+            (ocamlspot-message-add "ERROR: no tree node found there"))
+          nil)))))
 
 (defun ocamlspot-jump-to-spot (filename position)
   (if (string-match "\.cm[ioxa]$" filename)
       ;; It is not an .ml or .mli. Packed module.
-      (progn 
-        (message "Packed module: %s" filename)
-        ;; CR jfuruse: opening a binary file is not good
-        )
-    (ocamlspot-display-overlay 
+      ;; CR jfuruse: opening a binary file is not good
+      (ocamlspot-message-add "Packed module: %s" filename)
+    (ocamlspot-display-overlay
      (ocamlspot-find-file-existing filename)
      position ocamlspot-spot-overlay)))
 
   (goto-char (point-min))
   (if (re-search-forward "^Type: \\(.*\\(\n +.*\\)*\\)" nil t)
       (let ((type (buffer-substring (match-beginning 1) (match-end 1))))
-	(if to-kill (kill-new type))
-	(message "Type: %s" type)
-	type)
-    (progn 
-      (message "no type found here")
-      nil)))
+        (if to-kill (kill-new type))
+        (ocamlspot-message-add (format "Type: %s" type))
+        type)
+    (ocamlspot-message-add "no type found here")
+    nil))
 
 (defun ocamlspot-find-val-or-type-in-buffer (&optional to-kill)
   (set-buffer (get-buffer-create ocamlspot-buffer))
   (goto-char (point-min))
   (if (re-search-forward "^Val: \\(.*\\(\n +.*\\)*\\)" nil t)
       (let ((type (buffer-substring (match-beginning 1) (match-end 1))))
-	(if to-kill (kill-new type))
-	(message "Val: %s" type)
-	type)
+        (if to-kill (kill-new type))
+        (ocamlspot-message-add (format "Val: %s" type))
+        type)
     (ocamlspot-find-type-in-buffer to-kill)))
 
 (defun ocamlspot-find-spot-in-buffer ()
   (set-buffer (get-buffer-create ocamlspot-buffer))
   (goto-char (point-min))
-  (if (re-search-forward "^Spot: \\(.*\\):\\(l[\-0-9]+c[\-0-9]+b[\-0-9]+:l[\-0-9]+c[\-0-9]+b[\-0-9]+\\|all\\)$" 
-			 nil t)
-      (let ((filename (buffer-substring (match-beginning 1) 
-					(match-end 1)))
-	    (position (buffer-substring (match-beginning 2)
-					(match-end 2))))
-	;; display the result
-	(let ((type (ocamlspot-find-val-or-type-in-buffer)))
-	  (ocamlspot-jump-to-spot filename position)
-	  (if type (message "Type: %s" type))))
-    (progn
-      (if (re-search-forward "^Spot: \\(.*\\)" nil t)
-	  (message (buffer-substring (match-beginning 1) (match-end 1)))
-	(if (re-search-forward "^\\(Error: .*\\)" nil t)
-	    (message (buffer-substring (match-beginning 1) (match-end 1)))
-	  (progn
-	    ;; display debug info
-	    (message "No spot found there") 
-	    (ocamlspot-find-val-or-type-in-buffer)
-	    ;; (display-buffer ocamlspot-buffer)
-	    ))))))
+  ;; all and -1:-1 mean the whole file
+  (if (re-search-forward "^Spot: \\(.*\\):\\(l[\-0-9]+c[\-0-9]+b[\-0-9]+:l[\-0-9]+c[\-0-9]+b[\-0-9]+\\|[0-9]+:[0-9]+\\|all\\|-1:-1\\)$"
+                         nil t)
+      (let ((filename (buffer-substring (match-beginning 1)
+                                        (match-end 1)))
+            (position (buffer-substring (match-beginning 2)
+                                        (match-end 2))))
+        ;; display the result
+        (let ((type (ocamlspot-find-val-or-type-in-buffer)))
+          (ocamlspot-jump-to-spot filename position)
+          (if type (ocamlspot-message-add (format "Type: %s" type)))))
+    (if (re-search-forward "^Spot: \\(.*\\)" nil t)
+        (ocamlspot-message-add (buffer-substring (match-beginning 1) (match-end 1)))
+      (if (re-search-forward "^\\(Error: .*\\)" nil t)
+          (ocamlspot-message-add (buffer-substring (match-beginning 1) (match-end 1)))
+        ;; display debug info
+        (ocamlspot-message-add "No spot found there")
+        (ocamlspot-find-val-or-type-in-buffer)
+        ))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Interactives
+
+(defun ocamlspot-wait (&optional may-pop)
+  (ocamlspot-message-display may-pop)
+  (ocamlspot-delete-overlays))
 
 (defun ocamlspot-query ()
   (interactive)
   (let ((sel-window (selected-window)))
   (save-selected-window
-    (if (ocamlspot-gen-query nil)
+    (when (ocamlspot-gen-query nil)
+      ;; search the result
+      (ocamlspot-find-spot-in-buffer))
+    (ocamlspot-wait))
+  ; I dunno why but we need the following line to list-buffers work nicely
+  (select-window sel-window)))
+
+; CR dup code
+(defun ocamlspot-query-interface ()
+  (interactive)
+  (let ((sel-window (selected-window)))
+  (save-selected-window
+    (if (ocamlspot-gen-query "--interface")
         (progn ;save-excursion
           ;; search the result
           (ocamlspot-find-spot-in-buffer)))
-    (ocamlspot-delete-overlays)) ; CR jfuruse: it depends on one's taste
+    (ocamlspot-wait))
   ; I dunno why but we need the following line to list-buffers work nicely
   (select-window sel-window)))
 
 (defun ocamlspot-type (&optional to-kill)
   (interactive)
-  (if (ocamlspot-gen-query '("-n"))
-      (save-current-buffer 
-	(ocamlspot-find-val-or-type-in-buffer to-kill)))
-  (ocamlspot-delete-overlays))
+  (if (ocamlspot-gen-query "-n")
+      (save-current-buffer
+        (ocamlspot-find-val-or-type-in-buffer to-kill)))
+  (ocamlspot-wait t))
 
 (defun ocamlspot-type-and-copy ()
   (interactive)
 ; CR can be shared with ocamlspot-type
 (defun ocamlspot-use ()
   (interactive)
-  (if (ocamlspot-gen-query '("-n"))
-      (save-current-buffer 
-	(set-buffer (get-buffer-create ocamlspot-buffer))
-	(goto-char (point-min))
-	(if (re-search-forward "^Use: \\(.*\\(\n +.*\\)*\\)" nil t)
-	    (let ((type (buffer-substring (match-beginning 1) (match-end 1))))
-	      (message type))
-	  (message "no use information found here"))))
-  (ocamlspot-delete-overlays))
+  (if (ocamlspot-gen-query "-n")
+      (save-current-buffer
+        (set-buffer (get-buffer-create ocamlspot-buffer))
+        (goto-char (point-min))
+        (if (re-search-forward "^Use: \\(.*\\(\n +.*\\)*\\)" nil t)
+            (let ((type (buffer-substring (match-beginning 1) (match-end 1))))
+              (ocamlspot-message-add type))
+          (ocamlspot-message-add "no use information found here"))))
+  (ocamlspot-wait t))
+
+(defun ocamlspot-display-ocamlspot-buffer ()
+  (interactive)
+  (display-buffer ocamlspot-buffer))
 
 (provide 'ocamlspot)

ocamlspot/ocamlspot.ml

     val type_expr : Types.type_expr -> Types.type_expr
       (** put pos and stamps to type_expr *)
 
+    val module_type : Types.module_type -> Types.module_type
+
   end = struct
     let ident id = Ident.create_persistent (Ident.name id)
   
         | _ -> default t
       in
       f
+
+    let value_description vdesc = 
+      { vdesc with val_type = type_expr vdesc.val_type }
+
+    let type_declaration tdecl = 
+      { tdecl with type_params = List.map type_expr tdecl.type_params;
+        type_manifest = Option.map ~f:type_expr tdecl.type_manifest }
+
+    let exception_declaration = List.map type_expr
+
+    let rec class_type = function
+      | Tcty_constr (p, tys, clty) ->
+          Tcty_constr (path p, List.map type_expr tys, class_type clty)
+      | Tcty_signature clsig -> Tcty_signature (class_signature clsig)
+      | Tcty_fun (l, ty, clty) -> Tcty_fun (l, type_expr ty, class_type clty)
+
+    and class_signature clsig = 
+      { clsig with cty_self = type_expr clsig.cty_self;
+        cty_vars = Vars.map (fun (f1,f2,ty) -> (f1,f2, type_expr ty)) clsig.cty_vars;
+        cty_inher = 
+          List.map (fun (p, tys) -> path p, List.map type_expr tys)
+            clsig.cty_inher }
+
+    let class_declaration cldecl = 
+      { cldecl with cty_params = List.map type_expr cldecl.cty_params;
+        cty_type = class_type cldecl.cty_type;
+        cty_path = path cldecl.cty_path;
+        cty_new = Option.map cldecl.cty_new ~f:type_expr }
+
+    let cltype_declaration _ = assert false
+
+    let rec module_type = function
+      | Tmty_ident p -> Tmty_ident (path p)
+      | Tmty_signature sg -> Tmty_signature (signature sg)
+      | Tmty_functor (id, mty, mty') ->
+          Tmty_functor (ident id, module_type mty, module_type mty')
+
+    and signature sg = List.map signature_item sg
+
+    and signature_item = function
+      | Tsig_value (id, vdesc) -> Tsig_value (ident id, value_description vdesc)
+      | Tsig_type (id, tdecl, rec_status) -> 
+          Tsig_type (ident id, type_declaration tdecl, rec_status)
+      | Tsig_exception (id, edecl) ->
+          Tsig_exception (ident id, exception_declaration edecl)
+      | Tsig_module (id, mty, rec_status) ->
+          Tsig_module (ident id, module_type mty, rec_status)
+      | Tsig_modtype (id, mty_decl) -> 
+          Tsig_modtype (ident id, modtype_declaration mty_decl)
+      | Tsig_class (id, cldecl, rec_status) ->
+          Tsig_class (ident id, class_declaration cldecl, rec_status)
+      | Tsig_cltype (id, cltdecl, rec_status) ->
+          Tsig_cltype (ident id, cltype_declaration cltdecl, rec_status)
+
+    and modtype_declaration = function
+      | Tmodtype_abstract -> Tmodtype_abstract
+      | Tmodtype_manifest mty -> Tmodtype_manifest (module_type mty)
+
   end
 
   module Parse : sig
       : ?with_pos: bool -> Format.formatter -> Types.type_expr -> unit
       (** type scheme printer with position *)
 
+    val modtype 
+      : ?with_pos: bool -> Format.formatter -> Types.module_type -> unit
+
   end = struct
     let make f ?(with_pos=false) ty =
       let ty = if with_pos then With_pos.Fix.type_expr ty else ty in
       f ty
 
     let type_sch ?with_pos ppf = make (type_sch ppf) ?with_pos
+
+    let modtype ?(with_pos=false) ppf mty = 
+      let mty = if with_pos then With_pos.Fix.module_type mty else mty in
+      modtype ppf mty
   end
   include XPrinttyp
 end
       | Mod_functor (id, mty, mexp) ->
           Format.fprintf ppf "\\(%s:@[%a@]) -> %a" 
             (Ident.name id)
-            Printtyp.modtype mty
+            (Printtyp.modtype ~with_pos:true) mty
             module_expr (* ? format_module_expr *) mexp
       | Mod_apply (mexp1, mexp2) ->
           Format.fprintf ppf "%a(%a)"
       | Mod_constraint (mexp, mty) ->
           Format.fprintf ppf "@[%a@ :constraint:@ @[%a@]@]"
             module_expr mexp
-            Printtyp.modtype mty
+            (Printtyp.modtype ~with_pos:true) mty
       | Mod_abstract -> Format.fprintf ppf "<abst>"
 
     and (* format_structure => *) structure (* <= format_structure *) ppf items = 
 	Printtyp.reset ();
 	Printtyp.mark_loops typ;
         (* CR jfuruse: not fancy having @. *)
-	Format.fprintf ppf "Type: %a@." (Printtyp.type_sch ~with_pos:false) typ;
+	Format.fprintf ppf "Type: %a@ " (Printtyp.type_sch ~with_pos:false) typ;
 	Format.fprintf ppf "XType: %a" (Printtyp.type_sch ~with_pos:true) typ
+    | Mod_type mty -> 
+        (* CR jfuruse: not fancy having @. *)
+	Format.fprintf ppf "Type: %a@ " (Printtyp.modtype ~with_pos:false) mty;
+	(* Format.fprintf ppf "XType: %a" (Printtyp.type_sch ~with_pos:true) mty *)
     | Str str ->
 	Format.fprintf ppf "Str: %a"
 	  Abstraction.Format.structure_item str
   let compare { loc = l1 } { loc = l2 } = Location.compare l1 l2
 
   let format f ppf { loc = l; value = v } =
-    Format.fprintf ppf "%s: %a" 
+    Format.fprintf ppf "@[<2>%s:@ %a@]" 
       (Location.to_string l) 
       f v
 end
   let dummy loc = { loc = loc; value = LAnnot.dummy loc }
 
   let split { loc = l1; value = v } ~by:{ loc = l2 } = 
-    match Location.split l1 ~by: l2 with
-    | None -> None
-    | Some (l11,l12) -> Some ({ loc = l11; value = v },
-			      { loc = l12; value = v })
+    Option.map (Location.split l1 ~by: l2) ~f:(fun (l11, l12) -> 
+      { loc = l11; value = v },
+      { loc = l12; value = v }) 
 
   let point_by_byte pos : t = dummy (Location.point_by_byte pos)
 
 	  | None -> fprintf ppf "ROOT"
 	  | Some lspot -> LLAnnot.format ppf lspot
 	in
-	Format.eprintf "%a => %a@."
+	Format.eprintf "@[<2>%a =>@ %a@]@."
 	  format_parent parent
 	  LLAnnot.format lspot) t
 end
 
   type t = 
     | Ident of PIdent.t
-    | Structure of PIdent.t * structure
+    | Structure of PIdent.t * structure * structure option (* sig part *)
     | Closure of PIdent.t * env * Ident.t * Types.module_type * Abstraction.module_expr
     | Parameter of PIdent.t
     | Error of exn 
     path : string;
     cwd : string;
     load_paths : string list;
-    binding : binding 
+    binding : binding;
   } 
 
   and binding
 
   type (* Value.t => *) t = 
     | Ident of PIdent.t (* ? PIdent.t *)
-    | Structure of PIdent.t * structure
+    | Structure of PIdent.t * structure * structure option (* sig part *)
     | Closure of PIdent.t * env * Ident.t * Types.module_type * Abstraction.module_expr
     | Parameter of PIdent.t
     | Error of exn 
     path : string;
     cwd : string;
     load_paths : string list;
-    binding : binding 
+    binding : binding;
   } (* <= Value.env *)
 
   (* dirty hack for flat recursion *)
     (* prevent looping forever *)
     let cache = ref []
     let rec t = function
-      | Structure (_, str) -> structure str
+      | Structure (_, str, str_opt) -> 
+          structure str;
+          Option.iter str_opt ~f:structure
       | Closure (_, e, _, _, _) -> env e
       | Ident _ | Error _ | Parameter _ -> ()
     and env e = binding e.binding
     let rec t ppf = function
       | Ident id -> Format.fprintf ppf "Ident(%a)" PIdent.format id
       | Parameter id -> Format.fprintf ppf "Parameter(%a)" PIdent.format id
-      | Structure (pid, str) -> 
-	    Format.fprintf ppf "@[<v2>Module(%a)@ %a@]"
+      | Structure (pid, str, None) -> 
+	    Format.fprintf ppf "@[<v2>Module(%a)@ %a None@]"
 	      PIdent.format pid
             structure str
+      | Structure (pid, str, Some str') -> 
+	    Format.fprintf ppf "@[<v2>Module(%a)@ %a (Some %a)@]"
+	      PIdent.format pid
+            structure str
+            structure str'
       | Closure (pid, _, id, _mty, module_expr) ->
 	    Format.fprintf ppf "(@[<2>(%a =)fun %s ->@ @[%a@]@])" 
 	      PIdent.format pid
     path : string;
     cwd : string;
     load_paths : string list;
-    binding : Binding.t
+    binding : Binding.t;
   } 
   (* <= Env.t *)
   let format = Format.env
 		!str_of_global_ident ~load_paths:env.load_paths id
 	      in
               let str = Structure ( { PIdent.path = path; ident = None }, 
-				  str ) 
+				  str,
+                                  None (* CR jfuruse: todo (read .mli *))
 	      in
               Debug.format "@[<2>LOAD SUCCESS %s =@ %a@]@."
                 (Ident.name id)
           | Parameter pid -> Parameter pid
 	  | Closure _ -> (try assert false with e -> Error e)
           | Error exn -> Error exn
-	  | Structure (pid, str) -> 
+	  | Structure (pid, str, _ (* CR jfuruse *)) -> 
               Debug.format "Module %s found (%a)@." (Path.name p) PIdent.format pid;
               try
                 !!(find_ident str (kind, name, pos))
     | Mod_structure str -> 
         lazy begin
           let str = structure env str in
-          Structure ({ PIdent.path= env.path; ident = idopt }, str)
+          Structure ({ PIdent.path= env.path; ident = idopt }, str, None)
         end
     | Mod_functor (id, mty, mexp) -> 
 	Debug.format "evaluating functor (arg %s) under %s@."
 	eager (Closure ({ PIdent.path = env.path; ident = idopt }, 
                        env, id, mty, mexp))
     | Mod_constraint (mexp, _mty) -> 
-        (* [_mty] may not be a simple signature but an ident which is
+        (* [mty] may not be a simple signature but an ident which is
            hard to get its definition at this point. 
            Therefore we do not constrain our result here. 
            Only the sensitive case is when a constrained module is
           end in
           let kname_ztbl = 
             lazy begin match !!v with
-	    | Structure (_, str) -> 
+	    | Structure (_, str, _ (* CR jfuruse *) ) -> 
                 List.map (fun (id, (k, v)) -> (k, Ident0.name id), v) str
             | Parameter pid -> 
                 List.map (fun (k,id) -> 
   let no_definition_analysis = ref false
   let strict_time_stamp = ref false
   let print_file_info = ref false
+  let print_interface = ref false
 
   let _ = 
     Arg.parse 
         "--dump-top", Arg.Set dump_top, " dump top"; 
         "--dump-flat", Arg.Set dump_flat, " dump flat"; 
         "--eager-dump", Arg.Set eager_dump, " eager evaluation at dump";
+
         "-n", Arg.Set no_definition_analysis, " no definition analysis";
+        "--no-analysis", Arg.Set no_definition_analysis, " no definition analysis";
+        
+        "-i", Arg.Set print_file_info, " print file information";
+        "--info", Arg.Set print_file_info, " print file information";
+
+        "--interface", Arg.Set print_interface, " show the interface rather than the definition";
+
         "--strict-time-stamp", Arg.Set strict_time_stamp, " error at newer source files than their spots";
-        "-i", Arg.Set print_file_info, " print file information";
       ]
       (fun s -> 
 	match !spec with
   let no_definition_analysis = !no_definition_analysis
   let strict_time_stamp = !strict_time_stamp
   let print_file_info = !print_file_info
-      
+  let print_interface = !print_interface
+
   let dump_any = 
     dump_file (* ? dump_file *) || dump_lannots || dump_tree || dump_top || dump_flat
 
   module Load : sig
     exception Old_spot of string (* spot *) * string (* source *)
     val load : load_paths:string list -> string -> file
-    val load_module : load_paths:string list -> string -> file
+    val load_module : ?spit:bool -> load_paths:string list -> string -> file
   end = struct
 
     let check_time_stamp ~spot source =
 	    | Annot.Str ( Abstraction.Str_include _ ) -> ()
             | Annot.Functor_parameter id ->
 		Hashtbl.add tbl id loc
-            | _ -> ()) lannots;
+            | Annot.Type _ | Annot.Use _ | Annot.Module _ 
+            | Annot.Non_expansive _ | Annot.Mod_type _ -> ()) lannots;
 	  tbl
       in
       let flat = 
             | Annot.Use _
 	    | Annot.Module _ 
             | Annot.Functor_parameter _
-	    | Annot.Non_expansive _ -> st ) [] lannots
+	    | Annot.Non_expansive _ 
+            | Annot.Mod_type _ -> st ) [] lannots
       in
       { version = version;
 	path = source_path;
       let alternate_spotname = 
         if Filename.is_relative spotname then None
         else
-          match Dotfile.find_and_load (Filename.dirname spotname) with
-          | None -> None
-          | Some (found_dir, dotfile) ->
-              match dotfile.Dotfile.build_dir with
-              | None -> None
-              | Some build_dir -> 
-                  let length_found_dir = String.length found_dir in
-                  let found_dir' = 
-                    String.sub spotname 0 length_found_dir
-                  in
-                  let rel_spotname =
-                    String.sub spotname 
-                      (length_found_dir + 1)
-                      (String.length spotname - length_found_dir - 1)
-                  in
-                  assert (found_dir = found_dir');
-                  let dir = 
-                    if Filename.is_relative build_dir then 
-                      Filename.concat found_dir build_dir
-                    else build_dir
-                  in
-                  Some (Filename.concat dir rel_spotname)
+          Option.bind (Dotfile.find_and_load (Filename.dirname spotname)) 
+            (fun (found_dir, dotfile) ->
+              Option.map dotfile.Dotfile.build_dir ~f:(fun build_dir ->
+                let length_found_dir = String.length found_dir in
+                let found_dir' = 
+                  String.sub spotname 0 length_found_dir
+                in
+                let rel_spotname =
+                  String.sub spotname 
+                    (length_found_dir + 1)
+                    (String.length spotname - length_found_dir - 1)
+                in
+                assert (found_dir = found_dir');
+                let dir = 
+                  if Filename.is_relative build_dir then 
+                    Filename.concat found_dir build_dir
+                  else build_dir
+                in
+                Filename.concat dir rel_spotname))
       in
       try load ~load_paths spotname with
       | e -> 
           | None -> raise e
 
     (* CR jfuruse: searching algorithm must be reconsidered *)        
-    let load_module ~load_paths name =
-      let spotname = name ^ ".spot" in
+    let load_module ?(spit=false) ~load_paths name =
+      let spotname = name ^ if spit then ".spit" else ".spot" in
       try
         load ~load_paths spotname
       with
       | Failure s ->
-	  let spitname = name ^ ".spit" in
+	  let spitname = name ^ if spit then ".spot" else ".spit" in
           Format.printf "%s load failed. Try to load %s@."
             spotname spitname;
           try
       match v with
       | Value.Ident id -> id, find_loc id
       | Value.Parameter id -> id, find_loc id
-      | Value.Structure (id, _)  -> id, find_loc id
+      | Value.Structure (id, _, _)  -> id, find_loc id
       | Value.Closure (id, _, _, _, _) -> id, find_loc id
       | Value.Error (Failure s) -> Format.eprintf "Error: %s@." s; assert false
       | Value.Error (Load.Old_spot _ as exn) -> raise exn
 
   let str_of_global_ident ~load_paths id =
     assert (Ident.global id);
-    let file = Load.load_module ~load_paths (Ident0.name id) in
+    let file = Load.load_module ~spit:Config.print_interface ~load_paths (Ident0.name id) in
     file.path,
     Eval.structure (empty_env file) file.top
 
   let eval_packed env file =
     let f = Load.load ~load_paths:[""] (spot_of_file (env.Env.cwd ^/ file)) in
     Value.Structure ({ PIdent.path = f.path; ident = None },
-		    Eval.structure (empty_env f) f.top)
+		    Eval.structure (empty_env f) f.top,
+                    None (* packed has no .mli *))
 
   let _ = Eval.packed := eval_packed
 

ocamlspot/tests/.depend

 bigmodtest.cmi: target.cmo 
 open_in_mli.cmi: target.cmo 
 siginclude.cmi: 
+siginclude2.cmi: 
 signature2.cmi: 
 test15.cmi: 
 applied_sig.cmo: 
 types_in_type_def.cmx: type_def.cmx 
 use_record.cmo: record.cmo 
 use_record.cmx: record.cmx 
+utf8.cmo: 
+utf8.cmx: 
 variant.cmo: 
 variant.cmx: 
 variant_external.cmo: variant.cmo 
 variant_external.cmx: variant.cmx 
+with_type.cmo: 
+with_type.cmx: 
+with_type2.cmo: 
+with_type2.cmx: 
 dir1/test4.cmo: test.cmo 
 dir1/test4.cmx: test.cmx 
 dir2/test6.cmo: test5.cmo 

ocamlspot/tests/Makefile.targets

File contents unchanged.

ocamlspot/tests/interface.ml

+module M : sig 
+  exception E
+  val x : int
+end = struct
+  exception E
+  let x = 1
+  let _ = x
+end
+
+module N = struct
+  let y = 1
+end
+
+let _ = M.x
+let _ = N.y
+
+module O : sig
+  module P : sig
+    val z : int
+  end 
+end = struct
+  module P = struct
+    let z = 1
+  end
+end
+
+let _ = O.P.z

ocamlspot/utils.ml

     else Format.fprintf ppf "lazy"
 end
 
+module Option = struct
+  let map ~f = function
+    | None -> None
+    | Some v -> Some (f v)
+
+  let bind v f = match v with
+    | None -> None
+    | Some v -> f v
+
+  let iter ~f = function
+    | None -> ()
+    | Some v -> f v
+end
+
+    

otherlibs/bigarray/mmap_unix.c

File contents unchanged.

otherlibs/unix/lseek.c

File contents unchanged.

typing/dispatch.ml

 
 
   (* [env] is the initial type environment to type patterns.
-     After the typing [new_env] and [pat] are obtained.
+     After the typing [new_env] and [pat] are obtained,
      [add_typed_patterns] extends [env] with [pat], adding 
      implicit $-arrows if necessary. *)
   let add_typed_patterns ~env ~new_env pats =
 
     (* CR jfuruse: more fancy error messages! *)            
     let rec resolve : (Env.t * type_expr) list -> expression list list = function
-      | [] -> [[]] (* nothing to resolve! one solution with no expr *)
+      | [] -> [[]]
       | (env, typ)::typs ->
           try
             let mpath_t, mpath, mty =
     ) (fun () -> checks := [])
   end
 
+  (* [apply env exp] removes all the $-abstractions which [exp] has its type
+     by applying [Texp_dispatch] placeholder arguments. The actual values for
+     disptach are determined by the module [Resolve] *)
   let apply env exp =
-    (* $label:t -> elimination *)
     let (rev_non_disps, rev_disps, rev_apps, _), ty_non_arrow =
       fold_arrow env (fun (rev_non_disps, rev_disps, rev_apps, pos) ty l t _c ->
         (* we cannot fix the variable yet, since it can be shared. *)
     | Module of Abstraction.module_expr
     | Functor_parameter of Ident.t
     | Non_expansive of bool
+    | Mod_type of Types.module_type
 
   let equal t1 t2 =
     match t1, t2 with
     | Type t1, Type t2 -> t1 == t2
+    | Mod_type mty1, Mod_type mty2 -> mty1 == mty2
     | Str sitem1, Str sitem2 -> Abstraction.Structure_item.equal sitem1 sitem2
     | Module mexp1, Module mexp2 -> mexp1 == mexp2
     | Use (k1,p1), Use (k2,p2) -> k1 = k2 && p1 = p2
     | Non_expansive b1, Non_expansive b2 -> b1 = b2
     | Functor_parameter id1, Functor_parameter id2 -> id1 = id2
-    | (Type _ | Str _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _),
-      (Type _ | Str _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _) -> false 
+    | (Type _ | Str _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _ 
+          | Mod_type _),
+      (Type _ | Str _ | Module _ | Functor_parameter _ | Use _ | Non_expansive _
+          | Mod_type _) -> false 
 
   (* CR jfuruse: A Location.t contains a filename, though it is always
      unique. Waste of 4xn bytes. *)
-  let recorded = (Hashtbl.create 1023 : (Location.t, t) Hashtbl.t)
+  let recorded = (Hashtbl.create 1023 : (Location.t, (int * t list)) Hashtbl.t)
 
   let clear () = Hashtbl.clear recorded
 
   let record loc t = 
     if !Clflags.annotations then begin
-(* This caching works horribly when too many things are defined 
-   at the same locations. For example, a type definition of more than 
-   3000 variants, with sexp camlp4 extension, the compile time explodes
-   from 10secs to 4mins! Therefore this is commented out.
-
-   if List.exists (equal t) (Hashtbl.find_all recorded loc) then ()
-      else Hashtbl.add recorded loc t
-*)
-      Hashtbl.add recorded loc t
+      let num_records, records = 
+        try Hashtbl.find recorded loc with Not_found -> 0, []
+      in
+      (* This caching works horribly when too many things are defined 
+         at the same locations. For example, a type definition of more than 
+         3000 variants, with sexp camlp4 extension, the compile time explodes
+         from 10secs to 4mins! Therefore this works 
+         only if [num_records <= 10] 
+      *)
+      if num_records <= 10 && List.exists (equal t) records then ()
+      else Hashtbl.replace recorded loc (num_records + 1, t :: records)
     end
 
   let record_constr_type_use loc ty =
     
   let record_module_expr_use loc modl =
     protect "Spot.Annot.record_module_expr_use" (fun () ->
-      record loc (Module (Abstraction.module_expr modl)))
+      record loc (Module (Abstraction.module_expr modl));
+      record loc (Mod_type modl.Typedtree.mod_type))
       ()
 
   let record_include loc modl sg =
     protect "Spot.Annot.record_module_expr_def" (fun () ->
       record loc (Str (Abstraction.Str_module 
 	                  (id, 
-	                  (Abstraction.module_expr modl)))))
+	                  (Abstraction.module_expr modl))));
+      record loc (Mod_type modl.Typedtree.mod_type))
       ()
     
   let record_module_type_def loc id mty =
                           Abstraction.module_type mty))))
       ()
       
-  let recorded () = Hashtbl.fold (fun k v st -> (k,v)::st) recorded []
+  let recorded () = Hashtbl.fold (fun k (_,vs) st -> 
+    List.map (fun v -> k,v) vs @ st) recorded []
 end
 
 module Top = struct
     | Str_class of Ident.t
     | Str_cltype of Ident.t
     | Str_include of module_expr * (Kind.t * Ident.t) list
-    (* add things here at the end for future extension *)
 
 end
 
     | Module of Abstraction.module_expr
     | Functor_parameter of Ident.t
     | Non_expansive of bool
+    | Mod_type of Types.module_type
 
   val record : Location.t -> t -> unit
     
 
 (* Spot file *)
 module File : sig
-  (* not record but list for future exetensibility *)
   type elem =
     | Argv of string array
     | Source_path of string option
     | Load_paths of string list
     | Top of Abstraction.structure option
     | Annots of (Location.t * Annot.t) list
-(*
-    | Compile_option of string list
-*)    (* add things here at the end for future extension *)
 
   (* marshalled type *)
   type t = elem list

typing/typecore.ml

 
 module Dispatch = Dispatch.Make(D)
   
-(* let rec type_exp env sexp = type_exp_ env sexp  *)
-let rec type_exp env sexp = Dispatch.apply env (type_exp_ env sexp)
+let rec type_exp env sexp = 
+  (* type_exp_ + dispatch applications *)
+  Dispatch.apply env (type_exp_ env sexp)
 
 and type_exp_ env sexp =
   match sexp.pexp_desc with
       else
         type_args [] [] ty ty sargs []
 
-and type_construct env loc lid sarg explicit_arity ty_expected =
+and type_construct ?(dispatch_apply=false) env loc lid sarg explicit_arity ty_expected =
   let constr =
     try
       Env.lookup_constructor lid env
       exp_loc = loc;
       exp_type = instance ty_res;
       exp_env = env } in
+  let texp = if dispatch_apply then Dispatch.apply env texp else texp in
   unify_exp env texp ty_expected;
   let args = List.map2 (type_argument env) sargs ty_args in
   if constr.cstr_private = Private then
 (* Typing of an expression with an expected type.
    Some constructs are treated specially to provide better error messages. *)
 
-and type_expect ?in_function env sexp ty_expected =
+and type_expect ?in_function ?(dispatch_apply=false) env sexp ty_expected =
   match sexp.pexp_desc with
     Pexp_constant(Const_string s as cst) ->
       let exp =
             | _ -> instance Predef.type_string
             end;
           exp_env = env } in
+      let exp = if dispatch_apply then Dispatch.apply env exp else exp in
       unify_exp env exp ty_expected;
       exp
   | Pexp_construct(lid, sarg, explicit_arity) ->
-      type_construct env sexp.pexp_loc lid sarg explicit_arity ty_expected
+      type_construct ~dispatch_apply env sexp.pexp_loc lid sarg explicit_arity ty_expected
   | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
       let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list None in
-      let body = type_expect new_env sbody ty_expected in
+      let body = type_expect ~dispatch_apply new_env sbody ty_expected in
       re {
         exp_desc = Texp_let(rec_flag, pat_exp_list, body);
         exp_loc = sexp.pexp_loc;
         exp_env = env }
   | Pexp_sequence(sexp1, sexp2) ->
       let exp1 = type_statement env sexp1 in
-      let exp2 = type_expect env sexp2 ty_expected in
+      let exp2 = type_expect ~dispatch_apply env sexp2 ty_expected in
       re {
         exp_desc = Texp_sequence(exp1, exp2);
         exp_loc = sexp.pexp_loc;
         exp_type = exp2.exp_type;
         exp_env = env }
   | Pexp_function (l, Some default, [spat, sbody]) ->
+      (* CR jfuruse: think about Dispatch.apply *)
       let loc = default.pexp_loc in
       let scases =
         [{ppat_loc = loc; ppat_desc =
                                 {pexp_loc = sexp.pexp_loc; pexp_desc =
                                  Pexp_let(Default, [spat, smatch], sbody)}])}
       in
-      type_expect ?in_function env sfun ty_expected
+      type_expect ?in_function ~dispatch_apply env sfun ty_expected
   | Pexp_function (l, _, caselist) ->
+      (* CR jfuruse: think about Dispatch.apply *)
       let (loc, ty_fun) =
         match in_function with Some p -> p
         | None -> (sexp.pexp_loc, ty_expected)
         exp_env = env }
   | Pexp_when(scond, sbody) ->
       let cond = type_expect env scond (instance Predef.type_bool) in
-      let body = type_expect env sbody ty_expected in
+      let body = type_expect ~dispatch_apply env sbody ty_expected in
       re {
         exp_desc = Texp_when(cond, body);
         exp_loc = sexp.pexp_loc;
         exp_type = body.exp_type;
         exp_env = env }
   | Pexp_poly(sbody, sty) ->
+      (* CR jfuruse: think about Dispatch.apply *)
       let ty =
         match sty with None -> repr ty_expected
         | Some sty ->
                with [pat.pat_type] which has the full $-dabsts explicitly or
                miss some of them. Therefore we cannot use [type_expect].
 
-               we do not need Dispatch.apply against the sexp
+               we do not need Dispatch.apply against the [sexp]
                since such applications are immediately abstracted by
                Dispatch.abstract. So type_exp_ instead of type_exp *)
 	    type_exp_ exp_env sexp
           else 
-            type_expect exp_env sexp pat.pat_type) )
+            type_expect ~dispatch_apply:true exp_env sexp pat.pat_type) )
 	  spat_sexp_list pat_list
   in
 
   let pat0_list = pat_list in (* we need this for fix_calls *)
   
+  (* CR jfuruse : abstracts_list is no longer used *)
   let exp_list, pat_list, abstracts_list =
     List.fold_right2 (fun 
       (spat, (exp, dispatches)) pat 
     pat_list;
 
   (* rebuild new_env since $absts may be introduced *)
-  (* CR jfuruse : abstract_list is no longer used *)
   let new_env = Dispatch.add_typed_patterns ~env ~new_env pat_list in
   
   (List.combine pat_list exp_list, new_env)

typing/typecore.mli

         Env.t * Env.t * Env.t
 val type_expect:
         ?in_function:(Location.t * type_expr) ->
+        ?dispatch_apply:bool ->
         Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression
 val type_exp:
         Env.t -> Parsetree.expression -> Typedtree.expression

typing/typemod.ml

         | Psig_value(name, sdesc) ->
             let desc = Typedecl.transl_value_decl env sdesc in
             let (id, newenv) = Env.enter_value name desc env in
-	    (* CR jfuruse : todo 
             Spot.Annot.record item.psig_loc
-	      (Spot.Annot.Use (Spot.Kind.Value, ...)); 
-	    *)
+              (Spot.Annot.Str (Spot.Abstraction.Str_value id));
+            Spot.Annot.record item.psig_loc
+              (Spot.Annot.Type desc.val_type);
+	    (* CR jfuruse : or, (Spot.Annot.Use (Spot.Kind.Value, ...)) ?? *) 
             let rem = transl_sig newenv srem in
             Tsig_value(id, desc) :: rem
         | Psig_type sdecls ->