[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