ocaml/emacs/caml-types.el

;(***********************************************************************)
;(*                                                                     *)
;(*                           Objective Caml                            *)
;(*                                                                     *)
;(*          Damien Doligez, projet Moscova, INRIA Rocquencourt         *)
;(*                                                                     *)
;(*  Copyright 2003 Institut National de Recherche en Informatique et   *)
;(*  en Automatique.  All rights reserved.  This file is distributed    *)
;(*  under the terms of the Q Public License version 1.0.               *)
;(*                                                                     *)
;(***********************************************************************)

;(* $Id$ *)

; WARNING:
; This code is experimental.  Everything may change at any time.

; 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 (or pattern) that contains the cursor.
; The expression is highlighted in the current buffer.
; The type is highlighted in "foo.annot" (if your file is "foo.ml"),
; which is convenient when the type doesn't fit on a line.


; 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 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 where the type checker failed.
; . To get rid of the highlighting, put the cursor in a comment
;   and type C-c C-t.
; . The mark in the foo.annot file is set to the beginning of the
;   type, so you can type C-x C-x in that file to view the type.



; TO DO:
; - make emacs scroll the foo.annot file to show the type
; - (?) integrate this file into caml.el


; 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

; <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.

; 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".


; (global-set-key "\C-c\C-t" 'caml-types-show-type)


(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* ((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-bol (line-beginning-position))
         (target-cnum (point))
         (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)))
    (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-bol target-cnum)))
          (if (null loc)
              (progn
                (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))
            (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)
            (message (format "type: %s" (match-string 1)))
                                        ; *** 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))
            )))
      (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 3)
        (delete-overlay caml-types-expr-ovl))
      )))

(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-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)))))))))


;; 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 line)
    (forward-char col)
    (point)))

; 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)))