[MLton-commit] r5077
Vesa Karvonen
vesak at mlton.org
Mon Jan 29 06:41:30 PST 2007
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)
More information about the MLton-commit
mailing list