[MLton-commit] r5109
Vesa Karvonen
vesak at mlton.org
Thu Feb 1 16:15:13 PST 2007
Made the def-use database design "object-oriented" so that different
kinds of methods can be used to access def-use information
(e.g. parsing in real-time).
Implemented mostly working (buffer modifications aren't detected, yet,
but file modifications dates are checked) automatic reloading and
purging (more like hiding) of MLton def-use data.
----------------------------------------------------------------------
U mlton/trunk/ide/emacs/def-use-data.el
U mlton/trunk/ide/emacs/def-use-mode.el
U mlton/trunk/ide/emacs/def-use-util.el
U mlton/trunk/ide/emacs/esml-du-mlton.el
----------------------------------------------------------------------
Modified: mlton/trunk/ide/emacs/def-use-data.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-data.el 2007-02-01 20:12:01 UTC (rev 5108)
+++ mlton/trunk/ide/emacs/def-use-data.el 2007-02-02 00:15:06 UTC (rev 5109)
@@ -5,19 +5,6 @@
(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
@@ -45,95 +32,53 @@
(defalias 'def-use-sym-name (function cadr))
(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
+;; Def-use source
-(defvar def-use-duf-to-src-set-table (def-use-make-hash-table)
- "Maps a def-use -file to a set of sources.")
+(defun def-use-dus (title sym-at-ref sym-to-uses finalize &rest args)
+ "Makes a new def-use -source."
+ (cons args (cons sym-at-ref (cons sym-to-uses (cons title finalize)))))
-(defvar def-use-src-to-info-table (def-use-make-hash-table)
- "Maps a source to a source info.")
+(defun def-use-dus-sym-at-ref (dus ref)
+ (apply (cadr dus) ref (car dus)))
-(defvar def-use-sym-to-uses-table (def-use-make-hash-table)
- "Maps a symbol to a list of use references to the symbol.")
+(defun def-use-dus-sym-to-uses (dus sym)
+ (apply (caddr dus) sym (car dus)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data entry
+(defun def-use-dus-title (dus)
+ (apply (cadddr dus) (car dus)))
-(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-dus-finalize (dus)
+ (apply (cddddr dus) (car dus)))
-(defun def-use-add-use (ref sym)
- "Adds a reference to (use of) the specified symbol."
- (puthash sym (cons ref (def-use-sym-to-uses sym)) def-use-sym-to-uses-table)
- (puthash (def-use-ref-pos ref) sym
- (def-use-src-to-pos-to-sym (def-use-ref-src ref))))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data access
+;; Def-use source list
-(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))
+(defvar def-use-dus-list nil
+ "List of active def-use sources.")
-(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-add-dus (dus)
+ (push dus def-use-dus-list))
-(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-rem-dus (dus)
+ (setq def-use-dus-list
+ (remove dus def-use-dus-list)))
-(defun def-use-src-to-pos-to-sym (src)
- "Returns a position to symbol table for the specified source."
- (def-use-info-pos-to-sym (def-use-src-to-info src)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Queries
-(defun def-use-src-to-sym-set (src)
- "Returns a set of all symbols defined in the specified source."
- (def-use-info-sym-set (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))))
+ (when ref
+ (loop for dus in def-use-dus-list do
+ (let ((it (def-use-dus-sym-at-ref dus ref)))
+ (when it (return it))))))
-(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."
- (gethash sym def-use-sym-to-uses-table))
+ (when sym
+ (loop for dus in def-use-dus-list do
+ (let ((it (def-use-dus-sym-to-uses dus sym)))
+ (when it (return it))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; 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-uses-table (def-use-make-hash-table)))
-
-;; XXX Ability to purge data in a more fine grained manner
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(provide 'def-use-data)
Modified: mlton/trunk/ide/emacs/def-use-mode.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-mode.el 2007-02-01 20:12:01 UTC (rev 5108)
+++ mlton/trunk/ide/emacs/def-use-mode.el 2007-02-02 00:15:06 UTC (rev 5109)
@@ -13,7 +13,7 @@
;; 1. Generate a def-use file using MLton with the (new)
;; -prefer-abs-paths true option.
;; 2. Load all of the `def-use-*.el' files and `esml-du-mlton.el'.
-;; 3. M-x esml-du-mlton-parse <def-use-file>
+;; 3. M-x esml-du-mlton <def-use-file>
;; (It may take some time for parsing to finish, but you can continue
;; editing at the same time.)
;; 4. M-x def-use-mode
@@ -110,21 +110,25 @@
(defun def-use-ref-at-point (point)
"Returns a reference for the symbol at the specified point in the
current buffer."
- (def-use-ref (def-use-buffer-true-file-name)
- (def-use-point-to-pos
- (save-excursion
- (goto-char point)
- ;; XXX Index this logic in a mode specific manner
- (when (zerop (skip-chars-backward
- "a-zA-Z0-9_" (def-use-point-at-current-line)))
- (skip-chars-backward
- "-!%&$#+/:<=>?@~`^|*\\" (def-use-point-at-current-line)))
- (point)))))
+ (let ((src (def-use-buffer-true-file-name)))
+ (when src
+ (def-use-ref src
+ (def-use-point-to-pos
+ (save-excursion
+ (goto-char point)
+ ;; XXX Index this logic in a mode specific manner
+ (when (zerop (skip-chars-backward
+ "a-zA-Z0-9_" (def-use-point-at-current-line)))
+ (skip-chars-backward
+ "-!%&$#+/:<=>?@~`^|*\\" (def-use-point-at-current-line)))
+ (point)))))))
(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.
- (def-use-sym-at-ref (def-use-ref-at-point point)))
+ (let ((ref (def-use-ref-at-point point)))
+ (when ref
+ (def-use-sym-at-ref ref))))
(defun def-use-current-sym ()
"Returns symbol information for the symbol at the current point."
Modified: mlton/trunk/ide/emacs/def-use-util.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-util.el 2007-02-01 20:12:01 UTC (rev 5108)
+++ mlton/trunk/ide/emacs/def-use-util.el 2007-02-02 00:15:06 UTC (rev 5109)
@@ -92,6 +92,13 @@
(add-text-properties 0 (length string) `(face ,face) string)
string)
+(defun def-use-attr-mod-time-as-double (attr)
+ (+ (* (car (nth 5 attr)) 65536.0) (cadr (nth 5 attr))))
+
+(defun def-use-attr-newer? (attr1 attr2)
+ (> (def-use-attr-mod-time-as-double attr1)
+ (def-use-attr-mod-time-as-double attr2)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'def-use-util)
Modified: mlton/trunk/ide/emacs/esml-du-mlton.el
===================================================================
--- mlton/trunk/ide/emacs/esml-du-mlton.el 2007-02-01 20:12:01 UTC (rev 5108)
+++ mlton/trunk/ide/emacs/esml-du-mlton.el 2007-02-02 00:15:06 UTC (rev 5109)
@@ -8,8 +8,70 @@
(require 'bg-job)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Parsing of def-use -files produced by MLton.
+;; Interface
+(defun esml-du-mlton (duf)
+ "Gets def-use information from a def-use file produced by MLton."
+ (interactive "fSpecify def-use -file: ")
+ (let ((ctx (esml-du-ctx (def-use-file-truename duf))))
+ (esml-du-parse ctx)
+ (def-use-add-dus
+ (def-use-dus
+ (function esml-du-title)
+ (function esml-du-sym-at-ref)
+ (function esml-du-sym-to-uses)
+ (function esml-du-finalize)
+ ctx))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Methods
+
+(defun esml-du-title (ctx)
+ (esml-du-ctx-duf ctx))
+
+(defun esml-du-sym-at-ref (ref ctx)
+ (if (def-use-attr-newer?
+ (file-attributes (def-use-ref-src ref))
+ (esml-du-ctx-attr ctx))
+ (esml-du-reparse ctx)
+ (gethash ref (esml-du-ctx-ref-to-sym-table ctx))))
+
+(defun esml-du-sym-to-uses (sym ctx)
+ (if (def-use-attr-newer?
+ (file-attributes (def-use-ref-src (def-use-sym-ref sym)))
+ (esml-du-ctx-attr ctx))
+ (esml-du-reparse ctx)
+ (gethash sym (esml-du-ctx-sym-to-uses-table ctx))))
+
+(defun esml-du-finalize (ctx)
+ (when (esml-du-ctx-buf ctx)
+ (with-current-buffer (esml-du-ctx-buf ctx)
+ (setq buffer-read-only nil)
+ (goto-char 1)
+ (delete-char (buffer-size))
+ (setq buffer-read-only t))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Context
+
+(defun esml-du-ctx (duf)
+ (cons (def-use-make-hash-table)
+ (cons (def-use-make-hash-table)
+ (cons duf
+ (cons nil nil)))))
+
+(defalias 'esml-du-ctx-buf (function cddddr))
+(defalias 'esml-du-ctx-attr (function cadddr))
+(defalias 'esml-du-ctx-duf (function caddr))
+(defalias 'esml-du-ctx-ref-to-sym-table (function cadr))
+(defalias 'esml-du-ctx-sym-to-uses-table (function car))
+
+(defun esml-du-ctx-set-buf (buf ctx) (setcdr (cdddr ctx) buf))
+(defun esml-du-ctx-set-attr (attr ctx) (setcar (cdddr ctx) attr))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Parsing
+
(defun esml-du-read (taking skipping)
(let ((start (point)))
(skip-chars-forward taking)
@@ -26,57 +88,75 @@
(,(def-use-intern "functor") . ,font-lock-variable-name-face)
(,(def-use-intern "exception") . ,font-lock-variable-name-face)))
-(defun esml-du-mlton-parse (duf)
- "Parses a def-use -file. Because parsing may take a while, it is
+(defun esml-du-reparse (ctx)
+ (cond
+ ((not (def-use-attr-newer?
+ (file-attributes (esml-du-ctx-duf ctx))
+ (esml-du-ctx-attr ctx)))
+ nil)
+ ((not (esml-du-ctx-buf ctx))
+ (esml-du-parse ctx)
+ nil)
+ (t
+ (esml-du-finalize ctx)
+ (run-with-idle-timer 0.1 nil (function esml-du-reparse) ctx)
+ nil)))
+
+(defun esml-du-parse (ctx)
+ "Parses the def-use -file. Because parsing may take a while, it is
done as a background process. This allows you to continue working
altough the editor may feel a bit sluggish."
- (interactive "fSpecify def-use -file: ")
- (setq duf (def-use-file-truename duf))
- (let ((buf (generate-new-buffer (concat "** " duf " **"))))
- (with-current-buffer buf
- (buffer-disable-undo buf)
- (insert-file duf)
- (goto-char 1)
- (setq buffer-read-only t))
- (message (concat "Parsing " duf " in the background..."))
- (bg-job-start
- (function
- (lambda (duf buf)
- (with-current-buffer buf
- (eobp))))
- (function
- (lambda (duf buf)
- (with-current-buffer buf
- (goto-char 1)
- (let* ((kind (def-use-intern (esml-du-read "^ " " ")))
- (name (def-use-intern (esml-du-read "^ " " ")))
- (src (def-use-file-truename
- (esml-du-read "^ " " ")))
- (line (string-to-int (esml-du-read "^." ".")))
- (col (- (string-to-int (esml-du-read "^\n" "\n")) 1))
- (pos (def-use-pos line col))
- (ref (def-use-ref src pos))
- (sym (def-use-sym kind name ref
- (cdr (assoc kind esml-du-kinds)))))
- (def-use-add-def duf sym)
- (while (< 0 (skip-chars-forward " "))
- (let* ((src (def-use-file-truename
- (esml-du-read "^ " " ")))
- (line (string-to-int (esml-du-read "^." ".")))
- (col (- (string-to-int (esml-du-read "^\n" "\n"))
- 1))
- (pos (def-use-pos line col))
- (ref (def-use-ref src pos)))
- (def-use-add-use ref sym))))
- (setq buffer-read-only nil)
- (delete-backward-char (- (point) 1))
- (setq buffer-read-only t))
- (list duf buf)))
- (function
- (lambda (duf buf)
- (kill-buffer buf)
- (message (concat "Finished parsing " duf "."))))
- duf buf)))
+ (esml-du-ctx-set-attr (file-attributes (esml-du-ctx-duf ctx)) ctx)
+ (esml-du-ctx-set-buf
+ (generate-new-buffer (concat "** " (esml-du-ctx-duf ctx) " **")) ctx)
+ (with-current-buffer (esml-du-ctx-buf ctx)
+ (buffer-disable-undo)
+ (insert-file (esml-du-ctx-duf ctx))
+ (setq buffer-read-only t)
+ (goto-char 1))
+ (clrhash (esml-du-ctx-ref-to-sym-table ctx))
+ (clrhash (esml-du-ctx-sym-to-uses-table ctx))
+ (bg-job-start
+ (function
+ (lambda (ctx)
+ (with-current-buffer (esml-du-ctx-buf ctx)
+ (eobp))))
+ (function
+ (lambda (ctx)
+ (with-current-buffer (esml-du-ctx-buf ctx)
+ (goto-char 1)
+ (let* ((ref-to-sym (esml-du-ctx-ref-to-sym-table ctx))
+ (sym-to-uses (esml-du-ctx-sym-to-uses-table ctx))
+ (kind (def-use-intern (esml-du-read "^ " " ")))
+ (name (def-use-intern (esml-du-read "^ " " ")))
+ (src (def-use-file-truename (esml-du-read "^ " " ")))
+ (line (string-to-int (esml-du-read "^." ".")))
+ (col (- (string-to-int (esml-du-read "^\n" "\n")) 1))
+ (pos (def-use-pos line col))
+ (ref (def-use-ref src pos))
+ (sym (def-use-sym kind name ref
+ (cdr (assoc kind esml-du-kinds)))))
+ (puthash ref sym ref-to-sym)
+ (while (< 0 (skip-chars-forward " "))
+ (let* ((src (def-use-file-truename (esml-du-read "^ " " ")))
+ (line (string-to-int (esml-du-read "^." ".")))
+ (col (- (string-to-int (esml-du-read "^\n" "\n")) 1))
+ (pos (def-use-pos line col))
+ (ref (def-use-ref src pos)))
+ (puthash ref sym (esml-du-ctx-ref-to-sym-table ctx))
+ (puthash sym (cons ref (gethash sym sym-to-uses))
+ sym-to-uses))))
+ (setq buffer-read-only nil)
+ (delete-backward-char (- (point) 1))
+ (setq buffer-read-only t))
+ (list ctx)))
+ (function
+ (lambda (ctx)
+ (kill-buffer (esml-du-ctx-buf ctx))
+ (esml-du-ctx-set-buf nil ctx)
+ (message (concat "Finished parsing " (esml-du-ctx-duf ctx) "."))))
+ ctx)
+ (message (concat "Parsing " (esml-du-ctx-duf ctx) " in the background...")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
More information about the MLton-commit
mailing list