[MLton-commit] r5077

[Vesa K. <ve...@ml...>]

Semi-usable Emacs mode for highlighting and navigating definitions and
uses.  To try it:
1. Generate a def-use file using MLton with the -prefer-abs-paths true
   option.
2. Load all of the def-use-*.el files and esml-def-use-mlton.el.
3. M-x def-use-mode
4. M-x esml-def-use-mlton-parse <path-to-def-use-file>
   (This may take from a few seconds to a minute or more.)
5. Go to a SML source file covered by the def-use file and place the
   cursor over some variable (def or use).
The plan is to improve the usability of this mode in the near future.

----------------------------------------------------------------------

A   mlton/trunk/ide/emacs/def-use-data.el
A   mlton/trunk/ide/emacs/def-use-mode.el
A   mlton/trunk/ide/emacs/def-use-util.el
A   mlton/trunk/ide/emacs/esml-def-use-mlton.el

----------------------------------------------------------------------

Added: mlton/trunk/ide/emacs/def-use-data.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-data.el	2007-01-29 14:27:04 UTC (rev 5076)
+++ mlton/trunk/ide/emacs/def-use-data.el	2007-01-29 14:41:29 UTC (rev 5077)
@@ -0,0 +1,134 @@
+;; Copyright (C) 2007 Vesa Karvonen
+;;
+;; MLton is released under a BSD-style license.
+;; See the file MLton-LICENSE for details.
+
+(require 'def-use-util)
+
+;; XXX Improve database design
+;;
+;; This hash table based database design isn't very flexible.  In
+;; particular, it would be inefficient to update the database after a
+;; buffer change.  There are data structures that would make such
+;; updates feasible.  Look at overlays in Emacs, for example.
+;;
+;; Also, instead of loading the def-use -file to memory, which takes a
+;; lot of time and memory, it might be better to query the file in
+;; real-time.  On my laptop, it takes less than a second to grep
+;; through MLton's def-use -file and about 1/25 when the files are in
+;; cache.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data records
+
+(defalias 'def-use-pos (function cons))
+(defalias 'def-use-pos-line (function car))
+(defalias 'def-use-pos-col  (function cdr))
+
+(defun def-use-ref (src pos)
+  "Reference constructor."
+  (cons (def-use-intern src) pos))
+(defalias 'def-use-ref-src (function car))
+(defalias 'def-use-ref-pos (function cdr))
+
+(defun def-use-sym (kind name ref)
+  "Symbol constructor."
+  (cons ref (cons (def-use-intern name) (def-use-intern kind))))
+(defun def-use-sym-kind (sym) (cddr sym))
+(defun def-use-sym-name (sym) (cadr sym))
+(defalias 'def-use-sym-ref (function car))
+
+(defun def-use-info ()
+  "Info constructor."
+  (cons (def-use-make-hash-table) (def-use-make-hash-table)))
+(defalias 'def-use-info-pos-to-sym (function car))
+(defalias 'def-use-info-sym-set    (function cdr))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data tables
+
+(defvar def-use-duf-to-src-set-table (def-use-make-hash-table)
+  "Maps a def-use -file to a set of sources.")
+
+(defvar def-use-src-to-info-table (def-use-make-hash-table)
+  "Maps a source to a source info.")
+
+(defvar def-use-sym-to-use-set-table (def-use-make-hash-table)
+  "Maps a symbol to a set of references to the symbol.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data entry
+
+(defun def-use-add-def (duf sym)
+  "Adds the definition of the specified symbol."
+  (let* ((ref (def-use-sym-ref sym))
+         (src (def-use-ref-src ref))
+         (info (def-use-src-to-info src)))
+    (puthash src src (def-use-duf-to-src-set duf))
+    (puthash sym sym (def-use-info-sym-set info))
+    (puthash (def-use-ref-pos ref) sym (def-use-info-pos-to-sym info))))
+
+(defun def-use-add-use (ref sym)
+  "Adds a reference to (use of) the specified symbol."
+  (puthash ref ref (def-use-sym-to-use-set sym))
+  (puthash (def-use-ref-pos ref) sym
+           (def-use-src-to-pos-to-sym (def-use-ref-src ref))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data access
+
+(defun def-use-duf-to-src-set (duf)
+  "Returns the existing source set for the specified def-use -file or a
+new empty set."
+  (def-use-gethash-or-put duf (function def-use-make-hash-table)
+    def-use-duf-to-src-set-table))
+
+(defun def-use-sym-to-use-set (sym)
+  "Returns the existing use set for the specified symbol or a new empty
+use set."
+  (def-use-gethash-or-put sym (function def-use-make-hash-table)
+    def-use-sym-to-use-set-table))
+
+(defun def-use-src-to-info (src)
+  "Returns the existing source info for the specified source or a new
+empty source info."
+  (def-use-gethash-or-put src (function def-use-info)
+    def-use-src-to-info-table))
+
+(defun def-use-duf-to-srcs (duf)
+  "Returns a list of all sources whose symbols the def-use -file describes."
+  (def-use-set-to-list (def-use-duf-to-src-set duf)))
+
+(defun def-use-src-to-pos-to-sym (src)
+  "Returns a pos to sym table for the specified source."
+  (def-use-info-pos-to-sym (def-use-src-to-info src)))
+
+(defun def-use-sym-at-ref (ref)
+  "Returns the symbol referenced at specified ref."
+  (gethash (def-use-ref-pos ref)
+           (def-use-src-to-pos-to-sym (def-use-ref-src ref))))
+
+(defun def-use-src-to-syms (src)
+  "Returns a list of symbols defined (not symbols referenced) in the
+specified source."
+  (def-use-set-to-list (def-use-src-to-sym-set src)))
+
+(defun def-use-sym-to-uses (sym)
+  "Returns a list of uses of the specified symbol."
+  (def-use-hash-table-to-key-list (def-use-sym-to-use-set sym)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Data purging
+
+(defun def-use-purge-all ()
+  "Purges all data cached by def-use -mode."
+  (interactive)
+  (setq def-use-duf-to-src-set-table (def-use-make-hash-table))
+  (setq def-use-src-to-info-table (def-use-make-hash-table))
+  (setq def-use-sym-to-use-set-table (def-use-make-hash-table)))
+
+;; XXX Ability to purge data in a more fine grained manner
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide 'def-use-data)

Added: mlton/trunk/ide/emacs/def-use-mode.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-mode.el	2007-01-29 14:27:04 UTC (rev 5076)
+++ mlton/trunk/ide/emacs/def-use-mode.el	2007-01-29 14:41:29 UTC (rev 5077)
@@ -0,0 +1,178 @@
+;; Copyright (C) 2007 Vesa Karvonen
+;;
+;; MLton is released under a BSD-style license.
+;; See the file MLton-LICENSE for details.
+
+;; TBD:
+;; - jump-to-next
+;; - automatic loading of def-use files
+;; - make loading of def-use files asynchronous
+;; - disable def-use when file is modified
+
+(require 'def-use-data)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Customization
+
+(defgroup def-use nil
+  "Minor mode to support precisely identified definitions and uses."
+  :group 'matching)
+
+(defface def-use-def-face
+  '((((class color)) (:background "paleturquoise3"))
+    (t (:background "gray")))
+  "Face for highlighting definitions."
+  :group 'faces
+  :group 'def-use)
+
+(defface def-use-use-face
+  '((((class color)) (:background "darkseagreen3"))
+    (t (:background "gray")))
+  "Face for highlighting uses."
+  :group 'faces
+  :group 'def-use)
+
+(defcustom def-use-delay 0.125
+  "Idle time in seconds to delay before updating highlighting."
+  :type '(number :tag "seconds")
+  :group 'def-use)
+
+(defcustom def-use-priority 1000
+  "Priority of highlighting overlays."
+  :type 'integer
+  :group 'def-use)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Points and Positions
+
+(defun def-use-pos-to-point (pos)
+  "Returns the value of point in the current buffer at the position."
+  (save-excursion
+    (goto-line (def-use-pos-line pos))
+    (+ (point) (def-use-pos-col pos))))
+
+(defun def-use-point-to-pos (point)
+  "Returns the position corresponding to the specified point in the
+current buffer."
+  (save-excursion
+    (goto-char point)
+    (def-use-pos
+      (+ (count-lines 1 (point))
+         (if (= (current-column) 0) 1 0))
+      (current-column))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; High-level symbol lookup
+
+(defun def-use-sym-at-point (point)
+  "Returns symbol information for the symbol at the specified point."
+  ;; XXX If data unvailable for current buffer then attempt to load it.
+  (let ((pos
+         (def-use-point-to-pos
+           (save-excursion
+             (goto-char point)
+             (skip-syntax-backward "w" (def-use-point-at-current-line))
+             (point)))))
+    (def-use-sym-at-ref (def-use-ref (def-use-buffer-true-file-name) pos))))
+
+(defun def-use-current-sym ()
+  "Returns symbol information for the symbol at the current point."
+  (def-use-sym-at-point (point)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Navigation
+
+(defun def-use-jump-to-def ()
+  "Jumps to the definition of the symbol under the cursor."
+  (interactive)
+  (let ((sym (def-use-current-sym)))
+    (if sym
+        (def-use-goto-ref (def-use-sym-ref sym))
+      (message "Sorry, no known symbol at cursor."))))
+
+(defun def-use-goto-ref (ref)
+  "Find the referenced source and moves point to the referenced position."
+  (find-file (def-use-ref-src ref))
+  (def-use-goto-pos (def-use-ref-pos ref)))
+
+(defun def-use-goto-pos (pos)
+  "Moves point to the specified position."
+  (goto-char (def-use-pos-to-point pos)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Highlighting
+
+(defvar def-use-highlighted-sym nil)
+(defvar def-use-highlighted-overlays nil)
+
+(defun def-use-delete-highlighting ()
+  (mapc (function delete-overlay) def-use-highlighted-overlays)
+  (setq def-use-highlighted-overlays nil)
+  (setq def-use-highlighted-sym nil))
+
+(defun def-use-highlight-ref (sym ref face-attr)
+  ;; XXX Apply highlight to all open buffers
+  (when (equal (def-use-ref-src ref) (def-use-buffer-true-file-name))
+    (let* ((begin (def-use-pos-to-point (def-use-ref-pos ref)))
+           (beyond (+ begin (length (def-use-sym-name sym))))
+           (overlay (make-overlay begin beyond)))
+      (push overlay def-use-highlighted-overlays)
+      (overlay-put overlay 'priority def-use-priority)
+      (overlay-put overlay 'face face-attr))))
+
+(defun def-use-highlight-sym (sym)
+  "Highlights the specified symbol."
+  (unless (equal sym def-use-highlighted-sym)
+    (def-use-delete-highlighting)
+    (when sym
+      (setq def-use-highlighted-sym sym)
+      (def-use-highlight-ref sym (def-use-sym-ref sym) 'def-use-def-face)
+      (maphash (function
+                (lambda (ref _)
+                  (def-use-highlight-ref sym ref 'def-use-use-face)))
+               (def-use-sym-to-use-set sym)))))
+
+(defun def-use-highlight-current ()
+  "Highlights the symbol at the point."
+  (interactive)
+  (def-use-highlight-sym (def-use-current-sym)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Highlighting timer
+
+(defvar def-use-highlight-timer nil)
+
+(defun def-use-delete-highlight-timer ()
+  (when def-use-highlight-timer
+    (def-use-delete-idle-timer def-use-highlight-timer)
+    (setq def-use-highlight-timer nil)))
+
+(defun def-use-create-highlight-timer ()
+  (unless def-use-highlight-timer
+    (setq def-use-highlight-timer
+          (run-with-idle-timer
+           def-use-delay t
+           'def-use-highlight-current))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Mode
+
+(defun def-use-mode-enabled-in-some-buffer ()
+  (memq t (mapcar (lambda (buffer)
+                    (with-current-buffer buffer
+                      def-use-mode))
+                  (buffer-list))))
+
+(define-minor-mode def-use-mode
+  "Toggless the def-use highlighting mode."
+  :group 'def-use
+  :global t
+  :lighter " DU"
+  (def-use-delete-highlight-timer)
+  (def-use-delete-highlighting)
+  (when (def-use-mode-enabled-in-some-buffer)
+    (def-use-create-highlight-timer)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide 'def-use-mode)

Added: mlton/trunk/ide/emacs/def-use-util.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-util.el	2007-01-29 14:27:04 UTC (rev 5076)
+++ mlton/trunk/ide/emacs/def-use-util.el	2007-01-29 14:41:29 UTC (rev 5077)
@@ -0,0 +1,70 @@
+;; Copyright (C) 2007 Vesa Karvonen
+;;
+;; MLton is released under a BSD-style license.
+;; See the file MLton-LICENSE for details.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Utilities
+
+(defun def-use-buffer-true-file-name ()
+  "Returns the true filename of the current buffer."
+  (file-truename (buffer-file-name)))
+
+(defun def-use-point-at-next-line ()
+  "Returns point at the beginning of the next line."
+  (save-excursion
+    (end-of-line)
+    (+ 1 (point))))
+
+(defun def-use-point-at-current-line ()
+  "Returns point at the beginning of the current line."
+  (save-excursion
+    (beginning-of-line)
+    (point)))
+
+(defun def-use-delete-idle-timer (timer)
+  "Deletes the specified idle timer."
+  (if (string-match "XEmacs" emacs-version)
+      (delete-itimer timer)
+    (cancel-timer timer)))
+
+(defun def-use-gethash-or-put (key_ mk-value_ table_)
+  (or (gethash key_ table_)
+      (puthash key_ (funcall mk-value_) table_)))
+
+(defvar def-use-intern-table
+  (make-hash-table :test 'equal :weakness 'key-and-value)
+  "Weak hash table private to `def-use-intern'.")
+
+(defun def-use-intern (value)
+  "Hashes the given value to itself.  The assumption is that the value
+being interned is not going to be mutated."
+  (def-use-gethash-or-put value (function (lambda () value))
+    def-use-intern-table))
+
+(defun def-use-hash-table-to-assoc-list (hash-table)
+  "Returns an assoc list containing all the keys and values of the hash
+table."
+  (let ((result nil))
+    (maphash (function
+              (lambda (key value)
+                (push (cons key value) result)))
+             hash-table)
+    (nreverse result)))
+
+(defun def-use-hash-table-to-key-list (hash-table)
+  "Returns a list of the keys of the set (identity hash-table)."
+  (mapcar (function car)
+          (def-use-hash-table-to-assoc-list hash-table)))
+
+(defun def-use-set-to-list (set)
+  "Returns a list of the keys of the set (identity hash-table)."
+  (def-use-hash-table-to-key-list set))
+
+(defun def-use-make-hash-table ()
+  "Makes a hash table with `equal' semantics."
+  (make-hash-table :test 'equal :size 1))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide 'def-use-util)

Added: mlton/trunk/ide/emacs/esml-def-use-mlton.el
===================================================================
--- mlton/trunk/ide/emacs/esml-def-use-mlton.el	2007-01-29 14:27:04 UTC (rev 5076)
+++ mlton/trunk/ide/emacs/esml-def-use-mlton.el	2007-01-29 14:41:29 UTC (rev 5077)
@@ -0,0 +1,70 @@
+;; Copyright (C) 2007 Vesa Karvonen
+;;
+;; MLton is released under a BSD-style license.
+;; See the file MLton-LICENSE for details.
+
+(require 'def-use-mode)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Parsing of def-use -files produced by MLton.
+
+(defvar esml-def-use-mlton-resolve-src-last-src nil)
+(defvar esml-def-use-mlton-resolve-src-last-duf nil)
+(defvar esml-def-use-mlton-resolve-src-last-result nil)
+
+(defun esml-def-use-mlton-resolve-src (src duf)
+  (if (and (equal esml-def-use-mlton-resolve-src-last-src src)
+           (equal esml-def-use-mlton-resolve-src-last-duf duf))
+      esml-def-use-mlton-resolve-src-last-result
+    (setq esml-def-use-mlton-resolve-src-last-src src
+          esml-def-use-mlton-resolve-src-last-duf duf
+          esml-def-use-mlton-resolve-src-last-result
+          (def-use-intern
+            (file-truename
+             (cond
+              ;; XXX <basis>
+              ((file-name-absolute-p src)
+               src)
+              ((equal ?< (aref src 0))
+               src)
+              (t
+               (expand-file-name
+                src (file-name-directory duf)))))))))
+
+(defun esml-def-use-read (taking skipping)
+  (let ((start (point)))
+    (skip-chars-forward taking)
+    (let ((result (buffer-substring start (point))))
+      (skip-chars-forward skipping)
+      result)))
+
+(defun esml-def-use-mlton-parse (duf)
+  "Parses a def-use -file."
+  (interactive "fSpecify def-use -file: ")
+  (setq duf (expand-file-name duf))
+  (with-temp-buffer
+    (insert-file duf)
+    (goto-char 1)
+    (while (not (eobp))
+      (let* ((kind (esml-def-use-read "^ " " "))
+             (name (esml-def-use-read "^ " " "))
+             (src (esml-def-use-mlton-resolve-src
+                   (esml-def-use-read "^ " " ") duf))
+             (line (string-to-int (esml-def-use-read "^." ".")))
+             (col (- (string-to-int (esml-def-use-read "^\n" "\n")) 1))
+             (pos (def-use-pos line col))
+             (ref (def-use-ref src pos))
+             (sym (def-use-sym kind name ref)))
+        (def-use-add-def duf sym)
+        (while (< 0 (skip-chars-forward " "))
+          (let* ((src (esml-def-use-mlton-resolve-src
+                       (esml-def-use-read "^ " " ") duf))
+                 (line (string-to-int (esml-def-use-read "^." ".")))
+                 (col (- (string-to-int (esml-def-use-read "^\n" "\n")) 1))
+                 (pos (def-use-pos line col))
+                 (ref (def-use-ref src pos)))
+            (def-use-add-use ref sym)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide 'esml-def-use-mlton)