|
From: Vesa K. <ve...@ml...> - 2007-01-29 06:41:31
|
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) |