mlton-commit — [MLton-commit] Code commits

[MLton-commit] r5088

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

Changed from use-set to a uses list for a space/time improvement.

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

U   mlton/trunk/ide/emacs/def-use-data.el

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

Modified: mlton/trunk/ide/emacs/def-use-data.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-data.el	2007-01-30 14:33:06 UTC (rev 5087)
+++ mlton/trunk/ide/emacs/def-use-data.el	2007-01-30 14:56:48 UTC (rev 5088)
@@ -61,8 +61,8 @@
 (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.")
+(defvar def-use-sym-to-uses-table nil
+  "Maps a symbol to a list of use references to the symbol.")
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Data entry
@@ -78,7 +78,7 @@
 
 (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 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))))
 
@@ -91,12 +91,6 @@
   (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."
@@ -127,7 +121,7 @@
 
 (defun def-use-sym-to-uses (sym)
   "Returns a list of uses of the specified symbol."
-  (def-use-set-to-list (def-use-sym-to-use-set sym)))
+  (gethash sym def-use-sym-to-uses-table))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Data purging
@@ -137,7 +131,7 @@
   (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)))
+  (setq def-use-sym-to-uses-table (def-use-make-hash-table)))
 
 ;; XXX Ability to purge data in a more fine grained manner
 

[MLton-commit] r5087

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

Sort refs in jump-to-{next,prev}.

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

U   mlton/trunk/ide/emacs/def-use-data.el
U   mlton/trunk/ide/emacs/def-use-mode.el

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

Modified: mlton/trunk/ide/emacs/def-use-data.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-data.el	2007-01-30 14:04:00 UTC (rev 5086)
+++ mlton/trunk/ide/emacs/def-use-data.el	2007-01-30 14:33:06 UTC (rev 5087)
@@ -24,12 +24,20 @@
 (defalias 'def-use-pos (function cons))
 (defalias 'def-use-pos-line (function car))
 (defalias 'def-use-pos-col  (function cdr))
+(defun def-use-pos< (lhs rhs)
+  (or (< (def-use-pos-line lhs) (def-use-pos-line rhs))
+      (and (equal (def-use-pos-line lhs) (def-use-pos-line rhs))
+           (< (def-use-pos-col lhs) (def-use-pos-col rhs)))))
 
 (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-ref< (lhs rhs)
+  (or (string< (def-use-ref-src lhs) (def-use-ref-src rhs))
+      (and (equal (def-use-ref-src lhs) (def-use-ref-src rhs))
+           (def-use-pos< (def-use-ref-pos lhs) (def-use-ref-pos rhs)))))
 
 (defun def-use-sym (kind name ref)
   "Symbol constructor."
@@ -64,7 +72,6 @@
   (let* ((ref (def-use-sym-ref sym))
          (src (def-use-ref-src ref))
          (info (def-use-src-to-info src)))
-    (puthash ref ref (def-use-sym-to-use-set sym))
     (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))))

Modified: mlton/trunk/ide/emacs/def-use-mode.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-mode.el	2007-01-30 14:04:00 UTC (rev 5086)
+++ mlton/trunk/ide/emacs/def-use-mode.el	2007-01-30 14:33:06 UTC (rev 5087)
@@ -122,11 +122,13 @@
          (sym (def-use-sym-at-ref ref)))
     (if (not sym)
         (message "Sorry, no information on the symbol at point!")
-      (let* ((uses (def-use-sym-to-uses sym))
-             (uses (if reverse (reverse uses) uses))
-             (uses (append uses uses)))
-        (while (not (equal (pop uses) ref)))
-        (def-use-goto-ref (car uses) other-window)))))
+      (let* ((refs (sort (cons (def-use-sym-ref sym)
+                               (def-use-sym-to-uses sym))
+                         (function def-use-ref<)))
+             (refs (if reverse (reverse refs) refs))
+             (refs (append refs refs)))
+        (while (not (equal (pop refs) ref)))
+        (def-use-goto-ref (car refs) other-window)))))
 
 (defun def-use-jump-to-prev (&optional other-window)
   "Jumps to the prev use (or def) of the symbol under the cursor."
@@ -199,10 +201,10 @@
       (setq def-use-highlighted-sym sym)
       (setq def-use-highlighted-buffer (current-buffer))
       (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)))))
+      (mapc (function
+             (lambda (ref)
+               (def-use-highlight-ref sym ref 'def-use-use-face)))
+            (def-use-sym-to-uses sym)))))
 
 (defun def-use-highlight-current ()
   "Highlights the symbol at the point."

[MLton-commit] r5086

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

Added option to jump to other window.

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

U   mlton/trunk/ide/emacs/def-use-mode.el

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

Modified: mlton/trunk/ide/emacs/def-use-mode.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-mode.el	2007-01-30 13:21:20 UTC (rev 5085)
+++ mlton/trunk/ide/emacs/def-use-mode.el	2007-01-30 14:04:00 UTC (rev 5086)
@@ -107,17 +107,17 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Navigation
 
-(defun def-use-jump-to-def ()
+(defun def-use-jump-to-def (&optional other-window)
   "Jumps to the definition of the symbol under the cursor."
-  (interactive)
+  (interactive "P")
   (let ((sym (def-use-current-sym)))
     (if sym
-        (def-use-goto-ref (def-use-sym-ref sym))
+        (def-use-goto-ref (def-use-sym-ref sym) other-window)
       (message "Sorry, no known symbol at cursor."))))
 
-(defun def-use-jump-to-next (&optional reverse)
+(defun def-use-jump-to-next (&optional other-window reverse)
   "Jumps to the next use (or def) of the symbol under the cursor."
-  (interactive)
+  (interactive "P")
   (let* ((ref (def-use-current-ref))
          (sym (def-use-sym-at-ref ref)))
     (if (not sym)
@@ -126,18 +126,20 @@
              (uses (if reverse (reverse uses) uses))
              (uses (append uses uses)))
         (while (not (equal (pop uses) ref)))
-        (def-use-goto-ref (car uses))))))
+        (def-use-goto-ref (car uses) other-window)))))
 
-(defun def-use-jump-to-prev ()
+(defun def-use-jump-to-prev (&optional other-window)
   "Jumps to the prev use (or def) of the symbol under the cursor."
-  (interactive)
-  (def-use-jump-to-next t))
+  (interactive "P")
+  (def-use-jump-to-next other-window t))
 
-(defun def-use-goto-ref (ref)
+(defun def-use-goto-ref (ref &optional other-window)
   "Find the referenced source and moves point to the referenced position."
-  (unless (equal (def-use-buffer-true-file-name)
-                 (def-use-ref-src ref))
-    (find-file (def-use-ref-src ref)))
+  (cond
+   (other-window
+    (find-file-other-window (def-use-ref-src ref)))
+   ((not (equal (def-use-buffer-true-file-name) (def-use-ref-src ref)))
+    (find-file (def-use-ref-src ref))))
   (def-use-goto-pos (def-use-ref-pos ref)))
 
 (defun def-use-goto-pos (pos)

[MLton-commit] r5085

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

Added key bindings, jump-to-prev, show-info, and did some minor
tweaks.

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

U   mlton/trunk/ide/emacs/def-use-mode.el

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

Modified: mlton/trunk/ide/emacs/def-use-mode.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-mode.el	2007-01-30 13:06:22 UTC (rev 5084)
+++ mlton/trunk/ide/emacs/def-use-mode.el	2007-01-30 13:21:20 UTC (rev 5085)
@@ -41,6 +41,24 @@
   :type 'integer
   :group 'def-use)
 
+(defcustom def-use-key-bindings
+  '(("[(control c) (control d)]"
+     . def-use-jump-to-def)
+    ("[(control c) (control n)]"
+     . def-use-jump-to-next)
+    ("[(control c) (control p)]"
+     . def-use-jump-to-prev)
+    ("[(control c) (control v)]"
+     . def-use-show-info))
+  "Key bindings for the def-use mode.  The key specifications must be
+in a format accepted by the function `define-key'.  Hint: You might
+want to type `M-x describe-function def-use <TAB>' to see the
+available commands."
+  :type '(repeat (cons :tag "Key Binding"
+                       (string :tag "Key")
+                       (function :tag "Command")))
+  :group 'def-use)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Points and Positions
 
@@ -97,7 +115,7 @@
         (def-use-goto-ref (def-use-sym-ref sym))
       (message "Sorry, no known symbol at cursor."))))
 
-(defun def-use-jump-to-next ()
+(defun def-use-jump-to-next (&optional reverse)
   "Jumps to the next use (or def) of the symbol under the cursor."
   (interactive)
   (let* ((ref (def-use-current-ref))
@@ -105,13 +123,21 @@
     (if (not sym)
         (message "Sorry, no information on the symbol at point!")
       (let* ((uses (def-use-sym-to-uses sym))
+             (uses (if reverse (reverse uses) uses))
              (uses (append uses uses)))
         (while (not (equal (pop uses) ref)))
         (def-use-goto-ref (car uses))))))
 
+(defun def-use-jump-to-prev ()
+  "Jumps to the prev use (or def) of the symbol under the cursor."
+  (interactive)
+  (def-use-jump-to-next t))
+
 (defun def-use-goto-ref (ref)
   "Find the referenced source and moves point to the referenced position."
-  (find-file (def-use-ref-src ref))
+  (unless (equal (def-use-buffer-true-file-name)
+                 (def-use-ref-src ref))
+    (find-file (def-use-ref-src ref)))
   (def-use-goto-pos (def-use-ref-pos ref)))
 
 (defun def-use-goto-pos (pos)
@@ -119,14 +145,37 @@
   (goto-char (def-use-pos-to-point pos)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Info
+
+(defun def-use-show-info ()
+  "Shows info on the symbol under the cursor."
+  (interactive)
+  (let ((sym (def-use-current-sym)))
+    (if (not sym)
+        (message "Sorry, no information on the symbol at point!")
+      (message (def-use-format-sym sym)))))
+
+(defun def-use-format-sym (sym)
+  "Formats a string with some basic info on the symbol."
+  (format "%s:%d.%d: %s %s, %d uses."
+          (def-use-ref-src (def-use-sym-ref sym))
+          (def-use-pos-line (def-use-ref-pos (def-use-sym-ref sym)))
+          (def-use-pos-col (def-use-ref-pos (def-use-sym-ref sym)))
+          (def-use-sym-kind sym)
+          (def-use-sym-name sym)
+          (length (def-use-sym-to-uses sym))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Highlighting
 
 (defvar def-use-highlighted-sym nil)
+(defvar def-use-highlighted-buffer 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-buffer nil)
   (setq def-use-highlighted-sym nil))
 
 (defun def-use-highlight-ref (sym ref face-attr)
@@ -141,10 +190,12 @@
 
 (defun def-use-highlight-sym (sym)
   "Highlights the specified symbol."
-  (unless (equal sym def-use-highlighted-sym)
+  (unless (and (equal def-use-highlighted-sym sym)
+               (equal def-use-highlighted-buffer (current-buffer)))
     (def-use-delete-highlighting)
     (when sym
       (setq def-use-highlighted-sym sym)
+      (setq def-use-highlighted-buffer (current-buffer))
       (def-use-highlight-ref sym (def-use-sym-ref sym) 'def-use-def-face)
       (maphash (function
                 (lambda (ref _)
@@ -183,10 +234,20 @@
                   (buffer-list))))
 
 (define-minor-mode def-use-mode
-  "Toggless the def-use highlighting mode."
+  "Minor mode for highlighting and navigating definitions and uses."
+  ;; value
+  nil
+  ;; lighter
+  " DU"
+  ;; keymap
+  (let ((result (make-sparse-keymap)))
+    (mapc (function
+           (lambda (key-command)
+             (define-key result (read (car key-command)) (cdr key-command))))
+          def-use-key-bindings)
+    result)
   :group 'def-use
   :global t
-  :lighter " DU"
   (def-use-delete-highlight-timer)
   (def-use-delete-highlighting)
   (when (def-use-mode-enabled-in-some-buffer)

[MLton-commit] r5084

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

Fixed to work when buffer has no file name.

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

U   mlton/trunk/ide/emacs/def-use-util.el

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

Modified: mlton/trunk/ide/emacs/def-use-util.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-util.el	2007-01-30 08:40:24 UTC (rev 5083)
+++ mlton/trunk/ide/emacs/def-use-util.el	2007-01-30 13:06:22 UTC (rev 5084)
@@ -20,7 +20,9 @@
 
 (defun def-use-buffer-true-file-name ()
   "Returns the true filename of the current buffer."
-  (def-use-file-truename (buffer-file-name)))
+  (let ((name (buffer-file-name)))
+    (when name
+      (def-use-file-truename name))))
 
 (defun def-use-point-at-next-line ()
   "Returns point at the beginning of the next line."

[MLton-commit] r5083

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

jump-to-next that actually works.

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

U   mlton/trunk/ide/emacs/def-use-mode.el

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

Modified: mlton/trunk/ide/emacs/def-use-mode.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-mode.el	2007-01-30 08:30:29 UTC (rev 5082)
+++ mlton/trunk/ide/emacs/def-use-mode.el	2007-01-30 08:40:24 UTC (rev 5083)
@@ -4,7 +4,6 @@
 ;; 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
@@ -64,21 +63,29 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; High-level symbol lookup
 
+(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)
+        (skip-syntax-backward "w." (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.
-  (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))))
+  (def-use-sym-at-ref (def-use-ref-at-point point)))
 
 (defun def-use-current-sym ()
   "Returns symbol information for the symbol at the current point."
   (def-use-sym-at-point (point)))
 
+(defun def-use-current-ref ()
+  "Returns a reference to the symbol at the current point."
+  (def-use-ref-at-point (point)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Navigation
 
@@ -93,12 +100,13 @@
 (defun def-use-jump-to-next ()
   "Jumps to the next use (or def) of the symbol under the cursor."
   (interactive)
-  (let ((sym (def-use-current-sym)))
+  (let* ((ref (def-use-current-ref))
+         (sym (def-use-sym-at-ref ref)))
     (if (not sym)
         (message "Sorry, no information on the symbol at point!")
       (let* ((uses (def-use-sym-to-uses sym))
              (uses (append uses uses)))
-        (while (not (equal (pop uses) (def-use-sym-ref sym))))
+        (while (not (equal (pop uses) ref)))
         (def-use-goto-ref (car uses))))))
 
 (defun def-use-goto-ref (ref)

[MLton-commit] r5082

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

jump-to-next that doesn't quite work yet.

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

U   mlton/trunk/ide/emacs/def-use-data.el
U   mlton/trunk/ide/emacs/def-use-mode.el

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

Modified: mlton/trunk/ide/emacs/def-use-data.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-data.el	2007-01-30 07:30:49 UTC (rev 5081)
+++ mlton/trunk/ide/emacs/def-use-data.el	2007-01-30 08:30:29 UTC (rev 5082)
@@ -64,6 +64,7 @@
   (let* ((ref (def-use-sym-ref sym))
          (src (def-use-ref-src ref))
          (info (def-use-src-to-info src)))
+    (puthash ref ref (def-use-sym-to-use-set sym))
     (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))))

Modified: mlton/trunk/ide/emacs/def-use-mode.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-mode.el	2007-01-30 07:30:49 UTC (rev 5081)
+++ mlton/trunk/ide/emacs/def-use-mode.el	2007-01-30 08:30:29 UTC (rev 5082)
@@ -90,6 +90,17 @@
         (def-use-goto-ref (def-use-sym-ref sym))
       (message "Sorry, no known symbol at cursor."))))
 
+(defun def-use-jump-to-next ()
+  "Jumps to the next use (or def) of the symbol under the cursor."
+  (interactive)
+  (let ((sym (def-use-current-sym)))
+    (if (not sym)
+        (message "Sorry, no information on the symbol at point!")
+      (let* ((uses (def-use-sym-to-uses sym))
+             (uses (append uses uses)))
+        (while (not (equal (pop uses) (def-use-sym-ref sym))))
+        (def-use-goto-ref (car uses))))))
+
 (defun def-use-goto-ref (ref)
   "Find the referenced source and moves point to the referenced position."
   (find-file (def-use-ref-src ref))

[MLton-commit] r5081

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

Added missing function.

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

U   mlton/trunk/ide/emacs/def-use-data.el

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

Modified: mlton/trunk/ide/emacs/def-use-data.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-data.el	2007-01-29 22:09:09 UTC (rev 5080)
+++ mlton/trunk/ide/emacs/def-use-data.el	2007-01-30 07:30:49 UTC (rev 5081)
@@ -100,9 +100,13 @@
   (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."
+  "Returns a position to symbol table for the specified source."
   (def-use-info-pos-to-sym (def-use-src-to-info src)))
 
+(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)
@@ -115,7 +119,7 @@
 
 (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)))
+  (def-use-set-to-list (def-use-sym-to-use-set sym)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Data purging

[MLton-commit] r5080

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

Added some caching to speed up things.

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

U   mlton/trunk/ide/emacs/def-use-util.el
U   mlton/trunk/ide/emacs/esml-def-use-mlton.el

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

Modified: mlton/trunk/ide/emacs/def-use-util.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-util.el	2007-01-29 16:04:56 UTC (rev 5079)
+++ mlton/trunk/ide/emacs/def-use-util.el	2007-01-29 22:09:09 UTC (rev 5080)
@@ -6,9 +6,21 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Utilities
 
+(defvar def-use-file-truename-table
+  (make-hash-table :test 'equal :weakness 'key)
+  "Weak hash table private to `def-use-file-truename'.")
+
+(defun def-use-file-truename (file)
+  "Cached version of `file-truename'."
+  (def-use-gethash-or-put file
+    (function
+     (lambda ()
+       (def-use-intern (file-truename file))))
+    def-use-intern-table))
+
 (defun def-use-buffer-true-file-name ()
   "Returns the true filename of the current buffer."
-  (file-truename (buffer-file-name)))
+  (def-use-file-truename (buffer-file-name)))
 
 (defun def-use-point-at-next-line ()
   "Returns point at the beginning of the next line."

Modified: mlton/trunk/ide/emacs/esml-def-use-mlton.el
===================================================================
--- mlton/trunk/ide/emacs/esml-def-use-mlton.el	2007-01-29 16:04:56 UTC (rev 5079)
+++ mlton/trunk/ide/emacs/esml-def-use-mlton.el	2007-01-29 22:09:09 UTC (rev 5080)
@@ -19,17 +19,16 @@
     (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)))))))))
+          (def-use-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)))

[MLton-commit] r5079

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

Fixed the syntax class specification.

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

U   mlton/trunk/ide/emacs/def-use-mode.el

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

Modified: mlton/trunk/ide/emacs/def-use-mode.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-mode.el	2007-01-29 16:03:46 UTC (rev 5078)
+++ mlton/trunk/ide/emacs/def-use-mode.el	2007-01-29 16:04:56 UTC (rev 5079)
@@ -71,7 +71,7 @@
          (def-use-point-to-pos
            (save-excursion
              (goto-char point)
-             (skip-syntax-backward "w" (def-use-point-at-current-line))
+             (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))))
 

[MLton-commit] r5078

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

Modified to compute regions for the short identifiers of a long
identifier.

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

U   mlton/trunk/mlton/ast/longid.fun
U   mlton/trunk/mlton/control/source-pos.sig
U   mlton/trunk/mlton/control/source-pos.sml

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

Modified: mlton/trunk/mlton/ast/longid.fun
===================================================================
--- mlton/trunk/mlton/ast/longid.fun	2007-01-29 14:41:29 UTC (rev 5077)
+++ mlton/trunk/mlton/ast/longid.fun	2007-01-29 16:03:46 UTC (rev 5078)
@@ -90,11 +90,36 @@
 
 fun fromSymbols (ss: Symbol.t list, region: Region.t): t =
    let
-      val (strids, id) = List.splitLast ss
+      val srs =
+         case Region.left region of
+             NONE => List.map (ss, fn s => (s, region))
+           | SOME p =>
+             let
+                val file = SourcePos.file p
+                val line = SourcePos.line p
+             in
+                List.unfold
+                ((ss, SourcePos.column p),
+                 fn (s::ss, cl) =>
+                    let
+                       val cr = cl + String.length (Symbol.toString s)
+                    in
+                       SOME
+                       ((s, Region.make
+                            {left = SourcePos.make {column = cl,
+                                                    file = file,
+                                                    line = line},
+                             right = SourcePos.make {column = cr,
+                                                     file = file,
+                                                     line = line}}),
+                        (ss, cr + 1))
+                    end
+                  | ([], _) => NONE)
+             end
+      val (strids, id) = List.splitLast srs
    in
-      makeRegion (T {strids = List.map (strids, fn s =>
-                                        Strid.fromSymbol (s, region)),
-                     id = Id.fromSymbol (id, region)},
+      makeRegion (T {strids = List.map (strids, Strid.fromSymbol),
+                     id = Id.fromSymbol id},
                   region)
    end
 

Modified: mlton/trunk/mlton/control/source-pos.sig
===================================================================
--- mlton/trunk/mlton/control/source-pos.sig	2007-01-29 14:41:29 UTC (rev 5077)
+++ mlton/trunk/mlton/control/source-pos.sig	2007-01-29 16:03:46 UTC (rev 5078)
@@ -19,6 +19,7 @@
       type t
 
       val bogus: t
+      val column: t -> int
       val compare: t * t -> Relation.t
       val equals: t * t -> bool
       val file: t -> File.t

Modified: mlton/trunk/mlton/control/source-pos.sml
===================================================================
--- mlton/trunk/mlton/control/source-pos.sml	2007-01-29 14:41:29 UTC (rev 5077)
+++ mlton/trunk/mlton/control/source-pos.sml	2007-01-29 16:03:46 UTC (rev 5078)
@@ -16,6 +16,7 @@
 local
    fun f g (T r) = g r
 in
+   val column = f #column
    val line = f #line
 end
 

[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)

[MLton-commit] r5076

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

Added new expert option: -prefer-abs-paths {false|true}

Setting the option to true is supposed to have the effect that source
files are referred to by their absolute paths.  This can simplify
(working with and implementation of) external tools that would
otherwise have to know the directory from which the compiler was
executed (in order to locate source files).

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

U   mlton/trunk/mlton/control/control-flags.sig
U   mlton/trunk/mlton/control/control-flags.sml
U   mlton/trunk/mlton/control/source-pos.sml
U   mlton/trunk/mlton/front-end/mlb-front-end.fun
U   mlton/trunk/mlton/main/main.fun

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

Modified: mlton/trunk/mlton/control/control-flags.sig
===================================================================
--- mlton/trunk/mlton/control/control-flags.sig	2007-01-29 12:35:47 UTC (rev 5075)
+++ mlton/trunk/mlton/control/control-flags.sig	2007-01-29 14:27:04 UTC (rev 5076)
@@ -251,6 +251,8 @@
           product: int
          } option ref
 
+      val preferAbsPaths: bool ref
+
       (* List of pass names to keep profiling info on. *)
       val profPasses: Regexp.Compiled.t list ref
 

Modified: mlton/trunk/mlton/control/control-flags.sml
===================================================================
--- mlton/trunk/mlton/control/control-flags.sml	2007-01-29 12:35:47 UTC (rev 5075)
+++ mlton/trunk/mlton/control/control-flags.sml	2007-01-29 14:27:04 UTC (rev 5076)
@@ -836,6 +836,10 @@
                              ("product", Int.layout product)])
              p)}
 
+val preferAbsPaths = control {name = "prefer abs paths",
+                              default = false,
+                              toString = Bool.toString}
+
 val profPasses = 
    control {name = "prof passes",
             default = [],

Modified: mlton/trunk/mlton/control/source-pos.sml
===================================================================
--- mlton/trunk/mlton/control/source-pos.sml	2007-01-29 12:35:47 UTC (rev 5075)
+++ mlton/trunk/mlton/control/source-pos.sml	2007-01-29 14:27:04 UTC (rev 5076)
@@ -46,14 +46,17 @@
    end
 
 fun file (p as T {file, ...}) =
-   case getLib p of
-      NONE => file
-    | SOME i =>
-         String.substituteFirst
-         (String.substituteFirst
-          (String.dropPrefix (file, i), 
-           {substring = "/", replacement = "<"}),
-          {substring = "/", replacement = ">/"})
+   if !ControlFlags.preferAbsPaths
+      then file
+      else
+         case getLib p of
+            NONE => file
+          | SOME i =>
+               String.substituteFirst
+               (String.substituteFirst
+                (String.dropPrefix (file, i),
+                 {substring = "/", replacement = "<"}),
+                {substring = "/", replacement = ">/"})
 
 val bogus = T {column = ~1,
                file = "<bogus>",

Modified: mlton/trunk/mlton/front-end/mlb-front-end.fun
===================================================================
--- mlton/trunk/mlton/front-end/mlb-front-end.fun	2007-01-29 12:35:47 UTC (rev 5075)
+++ mlton/trunk/mlton/front-end/mlb-front-end.fun	2007-01-29 14:27:04 UTC (rev 5076)
@@ -153,7 +153,7 @@
             val fileAbs = OS.Path.mkAbsolute {path = fileExp, relativeTo = cwd}
             val fileAbs = OS.Path.mkCanonical fileAbs
             val relativize =
-               if OS.Path.isAbsolute fileExp
+               if !Control.preferAbsPaths orelse OS.Path.isAbsolute fileExp
                   then NONE
                   else relativize
             val fileUse =

Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun	2007-01-29 12:35:47 UTC (rev 5075)
+++ mlton/trunk/mlton/main/main.fun	2007-01-29 14:27:04 UTC (rev 5076)
@@ -373,6 +373,9 @@
         SpaceString (fn s => output := SOME s)),
        (Expert, "polyvariance", " {true|false}", "use polyvariance",
         Bool (fn b => if b then () else polyvariance := NONE)),
+       (Expert, "prefer-abs-paths", " {false|true}",
+        "prefer absolute paths when referring to files",
+        boolRef preferAbsPaths),
        (Expert, "prof-pass", " <pass>", "keep profile info for pass",
         SpaceString (fn s =>
                      (case Regexp.fromString s of

[MLton-commit] r5075

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

Removed the extra trailing space on use lines.

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

U   mlton/trunk/mlton/elaborate/elaborate-env.fun

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

Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun	2007-01-26 01:14:39 UTC (rev 5074)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun	2007-01-29 12:35:47 UTC (rev 5075)
@@ -1752,11 +1752,10 @@
                                   (align
                                    (List.map
                                     (uses, fn r =>
-                                     str (concat [case Region.left r of
-                                                     NONE => "NONE"
-                                                   | SOME p =>
-                                                        SourcePos.toString p,
-                                                  " "]))),
+                                     str (case Region.left r of
+                                              NONE => "NONE"
+                                            | SOME p =>
+                                              SourcePos.toString p))),
                                    4)],
                            out)
                        end))

[MLton-commit] r5074

[Stephen W. <sw...@ml...>]

tweaked

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

U   mltonlib/trunk/com/sweeks/basic/unstable/exn.sml

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

Modified: mltonlib/trunk/com/sweeks/basic/unstable/exn.sml
===================================================================
--- mltonlib/trunk/com/sweeks/basic/unstable/exn.sml	2007-01-23 18:03:36 UTC (rev 5073)
+++ mltonlib/trunk/com/sweeks/basic/unstable/exn.sml	2007-01-26 01:14:39 UTC (rev 5074)
@@ -7,19 +7,30 @@
 
    type t = Exn.t
 
-   local
-      datatype 'a z = Ok of 'a | Raise of t
+   datatype 'a z = Ok of 'a | Raise of t
+
+   val run: (Unit.t -> 'a) -> 'a z =
+      fn t => Ok (t ()) handle e => Raise e
+
+   val eval: 'a z -> 'a =
+      fn z =>
+      case z of
+         Ok x => x
+       | Raise e => raise e
+
+   val try: (Unit.t -> 'a) * ('a -> 'b) * (t -> 'b) -> 'b =
+      fn (t, k, h) =>
+      case run t of
+         Ok x => k x
+       | Raise e => h e
+
+   fun finally (t, cleanup: Unit.t -> Unit.t) = let
+      val z = run t
+      val () = cleanup ()
    in
-      val try: (Unit.t -> 'a) * ('a -> 'b) * (t -> 'b) -> 'b =
-         fn (t, k, h) =>
-         case Ok (t ()) handle e => Raise e of
-            Ok x => k x
-          | Raise e => h e
+      eval z
    end
 
-   fun finally (thunk, cleanup: Unit.t -> Unit.t) =
-      try (thunk, fn a => (cleanup (); a), fn e => (cleanup (); raise e))
-
 end
 
 local

[MLton-commit] r5073

[Matthew F. <fl...@ml...>]

Export PackWord{16,64}{Big,Little} from Basis2002
----------------------------------------------------------------------

U   mlton/trunk/basis-library/libs/basis-2002/top-level/basis.sig
U   mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sig
U   mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sml

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

Modified: mlton/trunk/basis-library/libs/basis-2002/top-level/basis.sig
===================================================================
--- mlton/trunk/basis-library/libs/basis-2002/top-level/basis.sig	2007-01-14 23:23:47 UTC (rev 5072)
+++ mlton/trunk/basis-library/libs/basis-2002/top-level/basis.sig	2007-01-23 18:03:36 UTC (rev 5073)
@@ -218,8 +218,12 @@
       structure PackReal64Little : PACK_REAL
       structure PackRealBig : PACK_REAL
       structure PackRealLittle : PACK_REAL
+      structure PackWord16Big : PACK_WORD
+      structure PackWord16Little : PACK_WORD
       structure PackWord32Big : PACK_WORD
       structure PackWord32Little : PACK_WORD
+      structure PackWord64Big : PACK_WORD
+      structure PackWord64Little : PACK_WORD
       structure Posix : POSIX
       structure Real32 : REAL
       structure Real32Array : MONO_ARRAY

Modified: mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sig
===================================================================
--- mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sig	2007-01-14 23:23:47 UTC (rev 5072)
+++ mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sig	2007-01-23 18:03:36 UTC (rev 5073)
@@ -218,8 +218,12 @@
       structure PackReal64Little : PACK_REAL
       structure PackRealBig : PACK_REAL
       structure PackRealLittle : PACK_REAL
+      structure PackWord16Big : PACK_WORD
+      structure PackWord16Little : PACK_WORD
       structure PackWord32Big : PACK_WORD
       structure PackWord32Little : PACK_WORD
+      structure PackWord64Big : PACK_WORD
+      structure PackWord64Little : PACK_WORD
       structure Posix : POSIX
       structure Real32 : REAL
       structure Real32Array : MONO_ARRAY

Modified: mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sml
===================================================================
--- mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sml	2007-01-14 23:23:47 UTC (rev 5072)
+++ mlton/trunk/basis-library/libs/basis-extra/top-level/basis.sml	2007-01-23 18:03:36 UTC (rev 5073)
@@ -147,8 +147,12 @@
       structure PackReal64Little = PackReal64Little
       structure PackRealBig = PackRealBig
       structure PackRealLittle = PackRealLittle
+      structure PackWord16Big = PackWord16Big
+      structure PackWord16Little = PackWord16Little
       structure PackWord32Big = PackWord32Big
       structure PackWord32Little = PackWord32Little
+      structure PackWord64Big = PackWord64Big
+      structure PackWord64Little = PackWord64Little
       structure Posix = Posix
       structure Real32 = Real32
       structure Real32Array = Real32Array

[MLton-commit] r5072

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

Added annotations to enable warnings (warnUnused and sequenceNonUnit) and
eliminated the exposed warnings (all of which were caused by unused
identifiers).  Previously, compiling mlnlffi-lib with warnings enabled
(from the command line) caused a flood of warnings.

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

U   mlton/trunk/lib/mlnlffi/c.mlb
U   mlton/trunk/lib/mlnlffi/internals/c-int.mlb
U   mlton/trunk/lib/mlnlffi/internals/c-int.sml
U   mlton/trunk/lib/mlnlffi/memory/linkage-libdl.sml
U   mlton/trunk/lib/mlnlffi/memory/memory.32bit-unix.mlb

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

Modified: mlton/trunk/lib/mlnlffi/c.mlb
===================================================================
--- mlton/trunk/lib/mlnlffi/c.mlb	2007-01-14 22:00:47 UTC (rev 5071)
+++ mlton/trunk/lib/mlnlffi/c.mlb	2007-01-14 23:23:47 UTC (rev 5072)
@@ -14,21 +14,27 @@
  *
  * author: Matthias Blume (bl...@re...)
  *)
-local
-   internals/c-int.mlb
+ann
+   "forceUsed"
+   "sequenceNonUnit warn"
+   "warnUnused true"
 in
-   structure Tag
+   local
+      internals/c-int.mlb
+   in
+      structure Tag
 
-   structure MLRep
+      structure MLRep
 
-   signature C
-   structure C
-   signature C_DEBUG
-   structure C_Debug
+      signature C
+      structure C
+      signature C_DEBUG
+      structure C_Debug
 
-   signature ZSTRING
-   structure ZString
+      signature ZSTRING
+      structure ZString
 
-   signature DYN_LINKAGE
-   structure DynLinkage
+      signature DYN_LINKAGE
+      structure DynLinkage
+   end
 end

Modified: mlton/trunk/lib/mlnlffi/internals/c-int.mlb
===================================================================
--- mlton/trunk/lib/mlnlffi/internals/c-int.mlb	2007-01-14 22:00:47 UTC (rev 5071)
+++ mlton/trunk/lib/mlnlffi/internals/c-int.mlb	2007-01-14 23:23:47 UTC (rev 5072)
@@ -2,34 +2,42 @@
    $(SML_LIB)/basis/basis.mlb
 
    ../memory/memory.mlb
+in
+   ann
+      "forceUsed"
+      "sequenceNonUnit warn"
+      "warnUnused true"
+   in
+      local
+         ../c.sig
+         ../c-debug.sig
+         c-int.sig
+         c-int.sml
+         c.sml
+         c-debug.sml
 
-   ../c.sig
-   ../c-debug.sig
-   c-int.sig
-   c-int.sml
-   c.sml
-   c-debug.sml
+         ../zstring.sig
+         zstring.sml
+         tag.sml
+      in
+         structure Tag
 
-   ../zstring.sig
-   zstring.sml
-   tag.sml
-in
-   structure Tag
+         structure MLRep
+         signature C
+         structure C
+         signature C_INT
+         structure C_Int
+         signature C_DEBUG
+         structure C_Debug
 
-   structure MLRep
-   signature C
-   structure C
-   signature C_INT
-   structure C_Int
-   signature C_DEBUG
-   structure C_Debug
+         signature ZSTRING
+         structure ZString
 
-   signature ZSTRING
-   structure ZString
+         signature DYN_LINKAGE
+         structure DynLinkage
 
-   signature DYN_LINKAGE
-   structure DynLinkage
-
-   signature CMEMORY
-   structure CMemory
+         signature CMEMORY
+         structure CMemory
+      end
+   end
 end

Modified: mlton/trunk/lib/mlnlffi/internals/c-int.sml
===================================================================
--- mlton/trunk/lib/mlnlffi/internals/c-int.sml	2007-01-14 22:00:47 UTC (rev 5071)
+++ mlton/trunk/lib/mlnlffi/internals/c-int.sml	2007-01-14 23:23:47 UTC (rev 5072)
@@ -45,7 +45,9 @@
         type cword = MLRep.Int.Unsigned.word
         type bf = { a: addr, l: word, r: word, lr: word, m: cword, im: cword }
 
+(*
         fun pair_type_addr (t: 'f objt) (a: addr) = (a, t)
+*)
         fun strip_type (a: addr, _: 'f objt) = a
         fun p_strip_type (a: addr, _: 'f objt) = a
         fun strip_fun (a: addr, _: 'f) = a
@@ -62,7 +64,9 @@
         val op ~>> = MLRep.Int.Unsigned.~>>
         val op && = MLRep.Int.Unsigned.andb
         val op || = MLRep.Int.Unsigned.orb
+(*
         val op ^^ = MLRep.Int.Unsigned.xorb
+*)
         val ~~ = MLRep.Int.Unsigned.notb
     in
 
@@ -168,7 +172,7 @@
        fn w => fn x => w x
     val convert' : (('st, 'sc) obj, ('tt, 'tc) obj) W.witness -> 
                    ('st, 'sc) obj' -> ('tt, 'tc) obj' =
-       fn w => fn x => x
+       fn _ => fn x => x
 
     (*
      * A family of types and corresponding values representing natural numbers.
@@ -399,9 +403,9 @@
         local
             val u2s = MLRep.Int.Signed.fromLarge o MLRep.Int.Unsigned.toLargeIntX
         in
-            fun ubf ({ a, l, r, lr, m, im } : bf) =
+            fun ubf ({ a, l, r=_, lr, m=_, im=_ } : bf) =
                 (CMemory.load_uint a << l) >> lr
-            fun sbf ({ a, l, r, lr, m, im } : bf) =
+            fun sbf ({ a, l, r=_, lr, m=_, im=_ } : bf) =
                 u2s ((CMemory.load_uint a << l) ~>> lr)
         end
     end
@@ -455,7 +459,7 @@
                fn (x, p) => ptr_voidptr' (p_strip_type x, p)
         end
 
-        fun ubf ({ a, l, r, lr, m, im }, x) =
+        fun ubf ({ a, l=_, r, lr=_, m, im }, x) =
            CMemory.store_uint (a, (CMemory.load_uint a && im) ||
                                ((x << r) && m))
 
@@ -498,7 +502,7 @@
 
         val inject : 'o ptr -> voidptr = p_strip_type
         val cast : 'o ptr T.typ -> voidptr -> 'o ptr =
-           fn PTR (null, t) => (fn p => (p, t))
+           fn PTR (_, t) => (fn p => (p, t))
             | _ => bug "Ptr.cast (non-pointer-type)"
 
         val vnull : voidptr = CMemory.null
@@ -526,7 +530,7 @@
            fn ((p, t as PTR (_, t')), i) => (|+! (T.sizeof t') (p, i), t)
             | _ => bug "Ptr.|+| (non-pointer-type)"
         val |-| : ('t, 'c) obj ptr * ('t, 'c) obj ptr -> int =
-           fn ((p, t as PTR (_, t')), (p', _)) => |-! (T.sizeof t') (p, p')
+           fn ((p, PTR (_, t')), (p', _)) => |-! (T.sizeof t') (p, p')
             | _ => bug "Ptr.|-| (non-pointer-type"
 
         val sub : ('t, 'c) obj ptr * int -> ('t, 'c) obj =
@@ -539,7 +543,7 @@
            fn w => fn x => w x
         val convert' : (('st, 'sc) obj ptr, ('tt, 'tc) obj ptr) W.witness ->
                        ('st, 'sc) obj ptr' -> ('tt, 'tc) obj ptr' =
-           fn w => fn x => x
+           fn _ => fn x => x
 
         val ro : ('t, 'c) obj ptr   -> ('t, ro) obj ptr =
            fn x => convert (W.pointer (W.ro W.trivial)) x
@@ -577,7 +581,7 @@
            fn ((a, PTR (_, t)), d) => (a, T.arr (t, d))
             | _ => bug "Arr.reconstruct (non-pointer)"
 
-        fun reconstruct' (a: addr, d: 'n Dim.dim) = a
+        fun reconstruct' (a: addr, _: 'n Dim.dim) = a
 
         fun dim (_: addr, t) = T.dim t
     end

Modified: mlton/trunk/lib/mlnlffi/memory/linkage-libdl.sml
===================================================================
--- mlton/trunk/lib/mlnlffi/memory/linkage-libdl.sml	2007-01-14 22:00:47 UTC (rev 5071)
+++ mlton/trunk/lib/mlnlffi/memory/linkage-libdl.sml	2007-01-14 23:23:47 UTC (rev 5072)
@@ -99,8 +99,9 @@
         end
 
         (* label used for CleanUp *)
+(*
         val label = "DynLinkNewEra"
-
+*)
         (* generate a new "era" indicator *)
         fun newEra () = ref ()
 

Modified: mlton/trunk/lib/mlnlffi/memory/memory.32bit-unix.mlb
===================================================================
--- mlton/trunk/lib/mlnlffi/memory/memory.32bit-unix.mlb	2007-01-14 22:00:47 UTC (rev 5071)
+++ mlton/trunk/lib/mlnlffi/memory/memory.32bit-unix.mlb	2007-01-14 23:23:47 UTC (rev 5072)
@@ -1,25 +1,33 @@
 local
    $(SML_LIB)/basis/basis.mlb
    $(SML_LIB)/basis/mlton.mlb
-
-   linkage.sig
-   ann "allowFFI true" in
-      linkage-libdl.sml
+in
+   ann
+      "forceUsed"
+      "sequenceNonUnit warn"
+      "warnUnused true"
+   in
+      local
+         linkage.sig
+         ann "allowFFI true" in
+            linkage-libdl.sml
+         end
+         bitop-fn.sml
+         mlrep-i8i16i32i32i64f32f64.sml
+         memaccess.sig
+         memaccess-a4c1s2i4l4ll8f4d8.sml
+         memalloc.sig
+         ann "allowFFI true" in
+            memalloc-a4-unix.sml
+         end
+         memory.sig
+         memory.sml
+      in
+         signature CMEMORY
+         structure CMemory
+         signature DYN_LINKAGE
+         structure DynLinkage
+         structure MLRep
+      end
    end
-   bitop-fn.sml
-   mlrep-i8i16i32i32i64f32f64.sml
-   memaccess.sig
-   memaccess-a4c1s2i4l4ll8f4d8.sml
-   memalloc.sig
-   ann "allowFFI true" in
-      memalloc-a4-unix.sml
-   end
-   memory.sig
-   memory.sml
-in
-   signature CMEMORY
-   structure CMemory
-   signature DYN_LINKAGE
-   structure DynLinkage
-   structure MLRep
 end

[MLton-commit] r5071

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

Changed indentation style.

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

U   mltonlib/trunk/com/ssh/misc-util/unstable/type.sml

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

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/type.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/type.sml	2007-01-12 12:44:04 UTC (rev 5070)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/type.sml	2007-01-14 22:00:47 UTC (rev 5071)
@@ -9,193 +9,188 @@
  * utility implementations of the {TYPE} signature.
  *)
 
-structure Type :>
-   sig
-      include TYPE
+structure Type :> sig
+   include TYPE
 
-      (** == STRUCTURAL TYPE-INDEXED VALUES == *)
+   (** == STRUCTURAL TYPE-INDEXED VALUES == *)
 
-      include ARBITRARY
-      include COMPARE
-      include EQ
+   include ARBITRARY
+   include COMPARE
+   include EQ
 
-      (** == NOMINAL TYPE-INDEXED VALUES == *)
+   (** == NOMINAL TYPE-INDEXED VALUES == *)
 
-      include SHOW
+   include SHOW
 
-      (* Sharing constraints *)
+   (* Sharing constraints *)
 
-      sharing type t
-                 = arbitrary_t
-                 = compare_t
-                 = eq_t
-                 = show_t
-      sharing type s
-                 = show_s
-      sharing type p
-                 = show_p
-   end = struct
-      structure Type =
-         TypePair
-            (structure A = Show
-             structure B =
-                StructuralTypeToType
-                   (StructuralTypePair
-                       (structure A = Arbitrary
-                        structure B =
-                           StructuralTypePair
-                              (structure A = Compare
-                               structure B = Eq))))
+   sharing type t
+              = arbitrary_t
+              = compare_t
+              = eq_t
+              = show_t
+   sharing type s
+              = show_s
+   sharing type p
+              = show_p
+end = struct
+   structure Type =
+      TypePair
+         (structure A = Show
+          structure B =
+             StructuralTypeToType
+                (StructuralTypePair
+                    (structure A = Arbitrary
+                     structure B =
+                        StructuralTypePair
+                           (structure A = Compare
+                            structure B = Eq))))
 
-      structure T :
-         sig
-            type 'a t
-            type 'a s
-            type ('a, 'k) p
-         end = Type
+   structure T : sig
+      type 'a t
+      type 'a s
+      type ('a, 'k) p
+   end = Type
 
-      local
-         open Lift
-      in
-         val A = A
-         val B = B
-         val op ^ = op ^
-      end
+   local
+      open Lift
+   in
+      val A = A
+      val B = B
+      val op ^ = op ^
+   end
 
-      structure Arbitrary = LiftArbitrary (open Arbitrary T fun lift () = B^A)
-      structure Compare   = LiftCompare   (open Compare   T fun lift () = B^B^A)
-      structure Eq        = LiftEq        (open Eq        T fun lift () = B^B^B)
+   structure Arbitrary = LiftArbitrary (open Arbitrary T fun lift () = B^A)
+   structure Compare   = LiftCompare   (open Compare   T fun lift () = B^B^A)
+   structure Eq        = LiftEq        (open Eq        T fun lift () = B^B^B)
 
-      structure Show = LiftShow (open Show T fun liftT () = A)
+   structure Show = LiftShow (open Show T fun liftT () = A)
 
-      open Type
-           Arbitrary
-           Compare
-           Eq
-           Show
-   end
+   open Type
+        Arbitrary
+        Compare
+        Eq
+        Show
+end
 
 (**
  * Here we extend the Type module with type-indices for some standard
  * types and type constructors as well as implement some utilities.
  *)
-structure Type =
-   struct
-      open TypeSupport Type
+structure Type = struct
+   open TypeSupport Type
 
-      (* Convenience functions for making constructors and labels.  Use
-       * these only for defining monomorphic type-indices.
-       *)
-      fun C0' n = C0 (C n)
-      fun C1' n = C1 (C n)
-      fun R' n = R (L n)
+   (* Convenience functions for making constructors and labels.  Use
+    * these only for defining monomorphic type-indices.
+    *)
+   fun C0' n = C0 (C n)
+   fun C1' n = C1 (C n)
+   fun R' n = R (L n)
 
-      (* Convenience functions for registering exceptions. *)
-      fun regExn0 e p n = regExn (C0' n) (const e, p)
-      fun regExn1 e p n t = regExn (C1' n t) (e, p)
+   (* Convenience functions for registering exceptions. *)
+   fun regExn0 e p n = regExn (C0' n) (const e, p)
+   fun regExn1 e p n t = regExn (C1' n t) (e, p)
 
-      (* Convenience functions for defining small tuples. *)
-      local
-         fun mk t = iso (tuple t)
-      in
-         fun tuple2 (a, b) = mk (T a *` T b) Product.isoTuple2
-         fun tuple3 (a, b, c) = mk (T a *` T b *` T c) Product.isoTuple3
-         fun tuple4 (a, b, c, d) = mk (T a *` T b *` T c *` T d) Product.isoTuple4
-      end
+   (* Convenience functions for defining small tuples. *)
+   local
+      fun mk t = iso (tuple t)
+   in
+      fun tuple2 (a, b) = mk (T a *` T b) Product.isoTuple2
+      fun tuple3 (a, b, c) = mk (T a *` T b *` T c) Product.isoTuple3
+      fun tuple4 (a, b, c, d) = mk (T a *` T b *` T c *` T d) Product.isoTuple4
+   end
 
-      (* Type-indices for some standard types. *)
-      local
-         fun mk precision int' large' =
-             if isSome Int.precision andalso
-                valOf precision <= valOf Int.precision then
-                iso int int'
-             else
-                iso largeInt large'
-      in
-         (* Warning: The following encodings of sized integer types are
-          *    not optimal for serialization.  (They do work, however.)
-          *    For serialization, one should encode sized integer types
-          *    in terms of the corresponding sized word types.
-          *)
-         val int8  = mk Int8.precision  Int8.isoInt  Int8.isoLarge
-         val int16 = mk Int16.precision Int16.isoInt Int16.isoLarge
-         val int32 = mk Int32.precision Int32.isoInt Int32.isoLarge
-         val int64 = mk Int64.precision Int64.isoInt Int64.isoLarge
-      end
+   (* Type-indices for some standard types. *)
+   local
+      fun mk precision int' large' =
+          if isSome Int.precision andalso
+             valOf precision <= valOf Int.precision then
+             iso int int'
+          else
+             iso largeInt large'
+   in
+      (* Warning: The following encodings of sized integer types are
+       *    not optimal for serialization.  (They do work, however.)
+       *    For serialization, one should encode sized integer types
+       *    in terms of the corresponding sized word types.
+       *)
+      val int8  = mk Int8.precision  Int8.isoInt  Int8.isoLarge
+      val int16 = mk Int16.precision Int16.isoInt Int16.isoLarge
+      val int32 = mk Int32.precision Int32.isoInt Int32.isoLarge
+      val int64 = mk Int64.precision Int64.isoInt Int64.isoLarge
+   end
 
-      local
-         val none = C "NONE"
-         val some = C "SOME"
-      in
-         fun option a =
-             iso (data (C0 none +` C1 some a))
-                 (fn NONE => INL () | SOME a => INR a,
-                  fn INL () => NONE | INR a => SOME a)
-      end
+   local
+      val none = C "NONE"
+      val some = C "SOME"
+   in
+      fun option a =
+          iso (data (C0 none +` C1 some a))
+              (fn NONE => INL () | SOME a => INR a,
+               fn INL () => NONE | INR a => SOME a)
+   end
 
-      val order =
-          iso (data (C0' "LESS" +` C0' "EQUAL" +` C0' "GREATER"))
-              (fn LESS => INL (INL ())
-                | EQUAL => INL (INR ())
-                | GREATER => INR (),
-               fn INL (INL ()) => LESS
-                | INL (INR ()) => EQUAL
-                | INR () => GREATER)
+   val order =
+       iso (data (C0' "LESS" +` C0' "EQUAL" +` C0' "GREATER"))
+           (fn LESS => INL (INL ())
+             | EQUAL => INL (INR ())
+             | GREATER => INR (),
+            fn INL (INL ()) => LESS
+             | INL (INR ()) => EQUAL
+             | INR () => GREATER)
 
-      structure OS' =
-         struct
-            val syserror = iso string (OS.errorName, valOf o OS.syserror)
-         end
+   structure OS' = struct
+      val syserror = iso string (OS.errorName, valOf o OS.syserror)
+   end
 
-      (* Type-indices for some util library types. *)
-      local
-         val et = C "&"
-      in
-         fun a &` b = data (C1 et (tuple (T a *` T b)))
-      end
+   (* Type-indices for some util library types. *)
+   local
+      val et = C "&"
+   in
+      fun a &` b = data (C1 et (tuple (T a *` T b)))
+   end
 
-      local
-         val inl = C "INL"
-         val inr = C "INR"
-      in
-         fun a |` b = data (C1 inl a +` C1 inr b)
-      end
-
-      (* Abbreviations for type-indices. *)
-      fun sq a = tuple2 (Sq.mk a)
-      fun uop a = a --> a
-      fun bop a = sq a --> a
+   local
+      val inl = C "INL"
+      val inr = C "INR"
+   in
+      fun a |` b = data (C1 inl a +` C1 inr b)
    end
 
-val () =
-    let
-       open IEEEReal OS OS.IO OS.Path Time Type
-       val s = SOME
-       val n = NONE
-       val su = SOME ()
-       val syserr = tuple2 (string, option OS'.syserror)
-    in
-       (* Handlers for (most if not all) standard exceptions: *)
-       regExn0 Bind       (fn Bind       => su | _ => n) "Bind"
-     ; regExn0 Chr        (fn Chr        => su | _ => n) "Chr"
-     ; regExn0 Date.Date  (fn Date.Date  => su | _ => n) "Date.Date"
-     ; regExn0 Div        (fn Div        => su | _ => n) "Div"
-     ; regExn0 Domain     (fn Domain     => su | _ => n) "Domain"
-     ; regExn0 Empty      (fn Empty      => su | _ => n) "Empty"
-     ; regExn0 InvalidArc (fn InvalidArc => su | _ => n) "OS.Path.InvalidArc"
-     ; regExn0 Match      (fn Match      => su | _ => n) "Match"
-     ; regExn0 Option     (fn Option     => su | _ => n) "Option"
-     ; regExn0 Overflow   (fn Overflow   => su | _ => n) "Overflow"
-     ; regExn0 Path       (fn Path       => su | _ => n) "OS.Path.Path"
-     ; regExn0 Poll       (fn Poll       => su | _ => n) "OS.IO.Poll"
-     ; regExn0 Size       (fn Size       => su | _ => n) "Size"
-     ; regExn0 Span       (fn Span       => su | _ => n) "Span"
-     ; regExn0 Subscript  (fn Subscript  => su | _ => n) "Subscript"
-     ; regExn0 Time       (fn Time       => su | _ => n) "Time.Time"
-     ; regExn0 Unordered  (fn Unordered  => su | _ => n) "IEEEReal.Unordered"
-     ; regExn1 Fail       (fn Fail     ? => s? | _ => n) "Fail"      string
-     ; regExn1 SysErr     (fn SysErr   ? => s? | _ => n) "OS.SysErr" syserr
-       (* Handlers for some util library exceptions: *)
-     ; regExn0 Sum.Sum    (fn Sum.Sum    => su | _ => n) "Sum"
-     ; regExn0 Fix.Fix    (fn Fix.Fix    => su | _ => n) "Fix"
-    end
+   (* Abbreviations for type-indices. *)
+   fun sq a = tuple2 (Sq.mk a)
+   fun uop a = a --> a
+   fun bop a = sq a --> a
+end
+
+val () = let
+   open IEEEReal OS OS.IO OS.Path Time Type
+   val s = SOME
+   val n = NONE
+   val su = SOME ()
+   val syserr = tuple2 (string, option OS'.syserror)
+in
+   (* Handlers for (most if not all) standard exceptions: *)
+   regExn0 Bind       (fn Bind       => su | _ => n) "Bind"
+ ; regExn0 Chr        (fn Chr        => su | _ => n) "Chr"
+ ; regExn0 Date.Date  (fn Date.Date  => su | _ => n) "Date.Date"
+ ; regExn0 Div        (fn Div        => su | _ => n) "Div"
+ ; regExn0 Domain     (fn Domain     => su | _ => n) "Domain"
+ ; regExn0 Empty      (fn Empty      => su | _ => n) "Empty"
+ ; regExn0 InvalidArc (fn InvalidArc => su | _ => n) "OS.Path.InvalidArc"
+ ; regExn0 Match      (fn Match      => su | _ => n) "Match"
+ ; regExn0 Option     (fn Option     => su | _ => n) "Option"
+ ; regExn0 Overflow   (fn Overflow   => su | _ => n) "Overflow"
+ ; regExn0 Path       (fn Path       => su | _ => n) "OS.Path.Path"
+ ; regExn0 Poll       (fn Poll       => su | _ => n) "OS.IO.Poll"
+ ; regExn0 Size       (fn Size       => su | _ => n) "Size"
+ ; regExn0 Span       (fn Span       => su | _ => n) "Span"
+ ; regExn0 Subscript  (fn Subscript  => su | _ => n) "Subscript"
+ ; regExn0 Time       (fn Time       => su | _ => n) "Time.Time"
+ ; regExn0 Unordered  (fn Unordered  => su | _ => n) "IEEEReal.Unordered"
+ ; regExn1 Fail       (fn Fail     ? => s? | _ => n) "Fail"      string
+ ; regExn1 SysErr     (fn SysErr   ? => s? | _ => n) "OS.SysErr" syserr
+   (* Handlers for some util library exceptions: *)
+ ; regExn0 Sum.Sum    (fn Sum.Sum    => su | _ => n) "Sum"
+ ; regExn0 Fix.Fix    (fn Fix.Fix    => su | _ => n) "Fix"
+end

[MLton-commit] r5070

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

Removed unused file.
----------------------------------------------------------------------

D   mltonlib/trunk/com/ssh/misc-util/unstable/ffi.sml

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

Deleted: mltonlib/trunk/com/ssh/misc-util/unstable/ffi.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/ffi.sml	2007-01-12 12:41:21 UTC (rev 5069)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/ffi.sml	2007-01-12 12:44:04 UTC (rev 5070)
@@ -1,17 +0,0 @@
-(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
- *
- * This code is released under the MLton license, a BSD-style license.
- * See the LICENSE file or http://mlton.org/License for details.
- *)
-
-(*
- * This is an unstable experimental FFI utility library.
- *)
-
-structure FFI = struct
-   type 'a export = 'a Effect.t
-   type 'a symbol = 'a Thunk.t * 'a Effect.t
-
-   fun get ((th, _) : 'a symbol) = th ()
-   fun set ((_, ef) : 'a symbol) x = ef x
-end

[MLton-commit] r5069

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

Initial commit of a lib of misc utils to be refactored.
----------------------------------------------------------------------

A   mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sml

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sml	2007-01-12 12:41:10 UTC (rev 5068)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sml	2007-01-12 12:41:21 UTC (rev 5069)
@@ -0,0 +1,112 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(*
+ * An implementation of the {WORD_TABLE} signature.  The table capacities
+ * are primes.  The primes used are the largest primes less than 2^i for i
+ * in {4, ..., 30}.  The table capacity is roughly doubled when the size
+ * of the table is the capacity and roughly halved when the size of the
+ * table is one quarter of the capacity.  This ensures that any sequence
+ * of insertions and deletions is linear modulo collisions.
+ *)
+
+structure WordTable :> WORD_TABLE where type Key.t = Word32.t = struct
+   structure Key = Word32 and W = Word32 and N = Node and V = Vector
+
+   datatype 'a t = IN of {table : (W.t * 'a) N.t Vector.t Ref.t,
+                          size : Int.t Ref.t}
+
+   val caps = V.fromList
+                 [3, 7, 13, 31, 61, 127, 251, 509, 1021, 2039, 4093, 8191,
+                  16381, 32749, 65521, 131071, 262139, 524287, 1048573,
+                  2097143, 4194301, 8388593, 16777213, 33554393, 67108859,
+                  134217689, 268435399, 536870909, 1073741789]
+   val minCap = V.sub (caps, 0)
+   val maxCap = V.sub (caps, V.length caps - 1)
+
+   fun table (IN {table, ...}) = !table
+   fun size (IN {size, ...}) = !size
+
+   fun keyToIdx t key = W.toIntX (key mod W.fromInt (V.length (table t)))
+   fun putAt t idx entry = N.push (V.sub (table t, idx)) entry
+   fun newTable cap = V.tabulate (cap, N.new o ignore)
+   fun findKey t idx key = N.find (key <\ op = o #1) (V.sub (table t, idx))
+
+   fun maybeRealloc (t as IN {table, ...}) = let
+      val cap = V.length (!table)
+      fun findIdx cap = #1 (valOf (V.findi (cap <\ op = o #2) caps))
+      fun realloc offs = let
+         val newCap = V.sub (caps, findIdx cap + offs)
+         val oldTable = !table
+      in
+         table := newTable newCap
+         (* Theoretically speaking, it should be possible to
+          * execute the following code in constant space.
+          *)
+       ; V.app (N.clearWith
+                   (fn entry as (key, _) => putAt t (keyToIdx t key) entry))
+               oldTable
+      end
+   in
+      if size t <= cap div 4 andalso minCap < cap then
+         realloc ~1
+      else if cap <= size t andalso cap < maxCap then
+         realloc 1
+      else
+         ()
+   end
+
+   fun new () = IN {table = ref (newTable minCap),
+                    size = ref 0}
+
+   fun == (IN {table = l, ...}, IN {table = r, ...}) = l = r
+
+   structure Action = struct
+      type ('v, 'r) t = ((W.t * 'v) N.t,
+                         (W.t * 'v) N.t) Sum.t * W.t * 'v t -> 'r
+      type ('v, 'r, 's) m = ('v, 'r) t
+      type none = unit
+      type some = unit
+
+      fun get {some, none} =
+          fn s as (INL _, _, _) => none () s
+           | s as (INR n, _, _) => some (Pair.snd (N.hd n)) s
+
+      fun peek {some, none} =
+          fn s as (INL _, _, _) => none () s
+           | s as (INR _, _, _) => some () s
+
+      fun insert value result =
+          fn (INL n, key, t as IN {size, ...}) =>
+             (size := !size + 1
+            ; N.push n (key, value)
+            ; maybeRealloc t
+            ; result)
+           | (INR _, _, _) =>
+             undefined ()
+
+      fun update value result =
+          fn (INL _, _, _) =>
+             undefined ()
+           | (INR n, key, _) =>
+             (N.<- (n, SOME ((key, value), N.tl n))
+            ; result)
+
+      fun remove result =
+          fn (INL _, _, _) =>
+             undefined ()
+           | (INR n, _, t as IN {size, ...}) =>
+             (size := !size - 1
+            ; N.drop n
+            ; maybeRealloc t
+            ; result)
+
+      val return = const
+   end
+
+   fun access t key action =
+       action (findKey t (keyToIdx t key) key, key, t)
+end


Property changes on: mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sml
___________________________________________________________________
Name: svn:eol-style
   + native

[MLton-commit] r5068

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

Initial commit of a lib of misc utils to be refactored.
----------------------------------------------------------------------

A   mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sig

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sig
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sig	2007-01-12 12:40:56 UTC (rev 5067)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sig	2007-01-12 12:41:10 UTC (rev 5068)
@@ -0,0 +1,55 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(*
+ * Signature for a low-level imperative polymorphic mapping from words to
+ * values intended for building hash table like containers.  The idea is
+ * that the client makes sure that the distribution of words used as keys
+ * is sufficiently random, while the word table takes care of stuff like
+ * resizing the table.
+ *)
+
+signature WORD_TABLE = sig
+   eqtype 'a t
+   (** The type of word tables. *)
+
+   structure Key : WORD
+   (** Substructure specifying the word type used as keys. *)
+
+   val new : 'a t Thunk.t
+   (** Allocates a new word table. *)
+
+   val == : 'a t BinPr.t
+   (** Equality predicate. *)
+
+   val size : 'a t -> Int.t
+   (** Returns the number of associations stored in the word table. *)
+
+   (**
+    * The {Action} substructure specifies type-safe combinators for
+    * expressing actions to take on access.  In particular, the
+    * combinators prevent the user from inserting or removing an element
+    * multiple times during a single access.
+    *)
+   structure Action : sig
+      type ('v, 'r) t
+      type ('v, 'r, 's) m
+      type some
+      type none
+
+      val get : {some : 'v -> ('v, 'r, some) m,
+                 none : ('v, 'r, none) m Thunk.t} -> ('v, 'r) t
+      val peek : {some : ('v, 'r, some) m Thunk.t,
+                  none : ('v, 'r, none) m Thunk.t} -> ('v, 'r) t
+      val insert : 'v -> 'r -> ('v, 'r, none) m
+      val update : 'v -> 'r -> ('v, 'r, some) m
+      val remove : 'r -> ('v, 'r, some) m
+      val return : 'r -> ('v, 'r, 's) m
+   end
+
+   val access : 'v t -> Key.t -> ('v, 'r) Action.t -> 'r
+   (** Performs an action on an association of the word table. *)
+end


Property changes on: mltonlib/trunk/com/ssh/misc-util/unstable/word-table.sig
___________________________________________________________________
Name: svn:eol-style
   + native

[MLton-commit] r5067

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

Initial commit of a lib of misc utils to be refactored.
----------------------------------------------------------------------

A   mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml	2007-01-12 12:40:39 UTC (rev 5066)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml	2007-01-12 12:40:56 UTC (rev 5067)
@@ -0,0 +1,479 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(*
+ * A simple unit testing framework.
+ *)
+
+structure UnitTest :> sig
+   type t
+   (** Type of unit test fold state. *)
+
+   type 'a s = (t, t, t, Unit.t, 'a) Fold.step0
+   (** Type of a unit test fold step. *)
+
+   (** == TEST SPECIFICATION INTERFACE == *)
+
+   val unitTests : (t, t, Unit.t, 'a) Fold.t
+   (** Begins test specification. *)
+
+   val title : String.t -> 'a s
+   (** {title string} specifies the title for subsequent tests. *)
+
+   (** === TEST REGISTRATION INTERFACE === *)
+
+   val test : Unit.t Effect.t -> 'a s
+   (**
+    * Registers an ad hoc test.  An ad hoc test should indicate failure
+    * by raising an exception.
+    *)
+
+   val testEq : 'a Type.t -> {actual : 'a, expect : 'a} Thunk.t -> 'b s
+   (** Tests that the expected and actual values are equal. *)
+
+   val testTrue  : Bool.t Thunk.t -> 'a s
+   (** Tests that the thunk evaluates to {true}. *)
+
+   val testFalse : Bool.t Thunk.t -> 'a s
+   (** Tests that the thunk evaluates to {false}. *)
+
+   val testFailsWith : Exn.t UnPr.t -> 'a Thunk.t -> 'b s
+   (**
+    * Tests that the thunk raises an exception satisfying the
+    * predicate.
+    *)
+
+   val testFails : 'a Thunk.t -> 'b s
+   (** Tests that the thunk raises an exception. *)
+
+   val testRaises : Exn.t -> 'a Thunk.t -> 'b s
+   (**
+    * Tests that the thunk raises an exception equal to the given one.
+    * The exception constructor must be registered with {Type.regExn}.
+    *)
+
+   (** == RANDOM TESTING INTERFACE == *)
+
+   val sizeFn : Int.t UnOp.t -> 'a s
+   (**
+    * Sets the function to determine the "size" of generated random
+    * test data.  The argument to the function is the number of tests
+    * passed.  The default function is {fn n => n div 2 + 3}.
+    *)
+
+   val maxPass : Int.t -> 'a s
+   (**
+    * Sets the max number of passed random test cases to try per test.
+    * The default is 100.
+    *)
+
+   val maxSkip : Int.t -> 'a s
+   (**
+    * Sets the max number of skipped random test cases to accept per
+    * test.  The default is 200.  If a lot of tests are being skipped,
+    * you should implement a better test data generator or a more
+    * comprehensive law.
+    *)
+
+   type law
+   (** The type of testable laws or properties. *)
+
+   val chk : law -> 'b s
+   (**
+    * Tries to find counter examples to a given law by testing the law
+    * with randomly generated cases.
+    *)
+
+   val all : 'a Type.t -> ('a -> law) -> law
+   (**
+    * Specifies that a law must hold for all values of type {'a}.  For
+    * example,
+    *
+    *> all int (fn x => that (x = x))
+    *
+    * specifies that all integers must be equal to themselves.
+    *)
+
+   val that : Bool.t -> law
+   (**
+    * Specifies a primitive boolean law.  For example,
+    *
+    *> that (1 <= 2)
+    *
+    * specifies that {1} is less than or equal to {2}.
+    *)
+
+   val skip : law
+   (**
+    * Specifies that the premises of a conditional law aren't satisfied
+    * so the specific test case of the law should be ignored.  For
+    * example,
+    *
+    *> all (sq int)
+    *>     (fn (x, y) =>
+    *>         if x <= y then
+    *>            that (Int.max (x, y) = y)
+    *>         else
+    *>            skip)
+    *
+    * specifies that if {x <= y} then {Int.max (x, y) = y}.
+    *)
+
+   val classify : String.t Option.t -> law UnOp.t
+   (**
+    * Classifies cases of a law.  The distribution of classified cases
+    * will be logged.
+    *)
+
+   val trivial : Bool.t -> law UnOp.t
+   (** Convenience function to classify cases of a law as "trivial". *)
+
+   val collect : 'a Type.t -> 'a -> law UnOp.t
+   (**
+    * Classifies test cases by value of type {'a}.  The distribution as
+    * well as the (pretty printed) values will be logged.
+    *)
+
+   (** == AD HOC TESTING HELPERS == *)
+
+   exception Failure of Prettier.t
+   (** Exception for reporting prettier errors. *)
+
+   val verifyEq : 'a Type.t -> {actual : 'a, expect : 'a} Effect.t
+   (** Verifies that the expected and actual values are equal. *)
+
+   val verifyTrue : Bool.t Effect.t
+   (** Verifies that the given value is {true}. *)
+
+   val verifyFalse : Bool.t Effect.t
+   (** Verifies that the given value is {false}. *)
+
+   val verifyFailsWith : Exn.t UnPr.t -> 'a Thunk.t Effect.t
+   (**
+    * Verifies that the thunk fails with an exception satisfying the
+    * predicate.
+    *)
+
+   val verifyFails : 'a Thunk.t Effect.t
+   (** Verifies that the given thunk fails with an exception. *)
+
+   val verifyRaises : Exn.t -> 'a Thunk.t Effect.t
+   (**
+    * Verifies that the thunk raises an exception equal to the given
+    * one.  The exception constructor must be registered with
+    * {Type.regExn}.
+    *)
+end = struct
+   structure CL = CommandLine and G = RanQD1Gen and I = Int and S = String
+
+   local
+      open Type
+   in
+      val arbitrary = arbitrary
+      val bool = bool
+      val eq = eq
+      val exn = exn
+      val layout = layout
+      val notEq = notEq
+   end
+
+   local
+      open Prettier
+   in
+      val indent = nest 2 o sep
+      fun named t n v = str n <^> nest 2 (line <^> layout t v)
+      val comma = comma
+      val dot = dot
+      val group = group
+      val op <^> = op <^>
+      val pretty = pretty
+
+      local
+         (* XXX move to lib *)
+
+         fun l <+> r = if isSome l then l else r ()
+         val mapPartial = Option.mapPartial
+         val s2i = I.fromString
+         val getEnv = OS.Process.getEnv
+
+         fun getArg fromString short long = let
+            val short =
+                case short of
+                   NONE => const NONE
+                 | SOME s =>
+                   fn (a, b) =>
+                      if a <> "-"^s then
+                         NONE
+                      else
+                         SOME b
+
+            val long =
+                case long of
+                   NONE => const NONE
+                 | SOME s =>
+                   fn a =>
+                      if not |< S.isPrefix ("--"^s^"=") a then
+                         NONE
+                      else
+                         SOME (S.extract (a, 3 + size s, NONE))
+
+            fun lp [] = NONE
+              | lp [a] = long a <+> (fn () => NONE)
+              | lp (a::b::xs) =
+                long a       <+> (fn () =>
+                short (a, b) <+> (fn () =>
+                lp (b::xs)))
+         in
+            mapPartial fromString (lp (CL.arguments ()))
+         end
+
+         val cols =
+             valOf (getArg s2i (SOME "w") (SOME "width") <+> (fn () =>
+                    mapPartial s2i (getEnv "COLUMNS")    <+> (fn () =>
+                    SOME 70)))
+      in
+         val println = println TextIO.stdOut (SOME cols)
+      end
+
+      val punctuate = punctuate
+      val str = str
+   end
+
+   datatype t =
+      IN of {title : String.t Option.t,
+             idx : Int.t,
+             size : Int.t UnOp.t,
+             passM : Int.t,
+             skipM : Int.t}
+   type 'a s = (t, t, t, Unit.t, 'a) Fold.step0
+
+   exception Failure of Prettier.t
+
+   val defaultCfg =
+       IN {title = NONE,
+           idx   = 1,
+           size  = fn n => n div 2 + 3,
+           passM = 100,
+           skipM = 200}
+
+   local
+      val ~ = (fn {title=a, idx=b, size=c, passM=d, skipM=e} => a&b&c&d&e,
+               fn a&b&c&d&e => {title=a, idx=b, size=c, passM=d, skipM=e})
+      open FRU
+   in
+      fun updCfg ? = fruData (fn IN ? => ?, IN) A5 $ ~ ~ ?
+   end
+
+   val succeeded = ref 0
+   val failed = ref 0
+
+   val i2s = I.toString
+
+   fun runTest safeTest =
+       Fold.step0
+          (fn cfg as IN {idx, ...} =>
+              (if safeTest cfg then
+                  succeeded += 1
+               else
+                  failed += 1
+             ; updCfg (U#idx (idx + 1)) $ cfg))
+
+   fun header (IN {title, idx, ...}) =
+       if isSome title then
+          concat [i2s idx, ". ", valOf title, " test"]
+       else
+          "An untitled test"
+
+   (* We assume here that we're the first call to atExit so that it
+    * is (relatively) safe to call terminate in our atExit effect.
+    *)
+
+   val printlnStrs = println o group o str o concat
+   val () =
+       OS.Process.atExit
+          (fn () =>
+              if 0 = !failed then
+                 printlnStrs
+                    ["All ", i2s (!succeeded), " tests succeeded."]
+              else
+                 (printlnStrs
+                     [i2s (!succeeded + !failed), " tests of which\n",
+                      i2s (!succeeded), " succeeded and\n",
+                      i2s (!failed), " failed."]
+                ; OS.Process.terminate OS.Process.failure))
+
+   (* TEST SPECIFICATION INTERFACE *)
+
+   fun unitTests ? =
+       Fold.fold (defaultCfg, ignore) ?
+
+   fun title title =
+       Fold.step0 (updCfg (U #idx 1) (U #title (SOME title)) $)
+
+   (* AD HOC TESTING HELPERS *)
+
+   fun verifyEq t {actual, expect} =
+       if notEq t (actual, expect) then
+          raise Failure (indent [str "Equality test failed:",
+                                 named t "expected" expect <^> comma,
+                                 named t "but got" actual])
+       else
+          ()
+
+   fun verifyTrue  b = verifyEq bool {expect = true,  actual = b}
+   fun verifyFalse b = verifyEq bool {expect = false, actual = b}
+
+   fun verifyFailsWith ePr th =
+       try (th,
+            fn _ =>
+               raise Failure (str "Test didn't raise an\
+                                  \ exception as expected"),
+            fn e =>
+               if ePr e then
+                  ()
+               else
+                  raise Failure (group (named exn
+                                              "Test raised an\
+                                              \ unexpected exception"
+                                              e)))
+
+   fun verifyFails ? = verifyFailsWith (const true) ?
+   fun verifyRaises e = verifyFailsWith (e <\ eq exn)
+
+   (* TEST REGISTRATION INTERFACE *)
+
+   fun test body =
+       runTest
+          (fn cfg =>
+              try (body,
+                   fn _ =>
+                      (printlnStrs [header cfg, " succeeded."]
+                     ; true),
+                   fn e =>
+                      (println
+                          (indent
+                              [str (header cfg ^ " failed."),
+                               case e of
+                                  Failure doc => doc <^> dot
+                                | _ =>
+                                  indent [str "Unhandled exception",
+                                          str (Exn.message e) <^> dot],
+                               case Exn.history e of
+                                  [] =>
+                                  str "No exception history available."
+                                | hs => (indent o map str)
+                                           ("Exception history:"::hs)])
+                     ; false)))
+
+   fun testEq t th = test (verifyEq t o th)
+
+   fun testTrue  th = test (verifyTrue  o th)
+   fun testFalse th = test (verifyFalse o th)
+
+   fun testFailsWith ep th = test (fn () => verifyFailsWith ep th)
+   fun testFails th = test (fn () => verifyFails th)
+   fun testRaises e th = test (fn () => verifyRaises e th)
+
+   (* RANDOM TESTING INTERFACE *)
+
+   type law = (Bool.t Option.t * String.t List.t * Prettier.t List.t) G.gen
+
+   local
+      fun mk field value = Fold.step0 (updCfg (U field value) $)
+   in
+      fun sizeFn  ? = mk #size  ?
+      fun maxPass ? = mk #passM ?
+      fun maxSkip ? = mk #skipM ?
+   end
+
+   val rng = ref (G.make (Word32.fromWord (getOpt (RandomDev.seed (), 0w0))))
+
+   fun chk prop =
+       runTest
+          (fn cfg as IN {size, passM, skipM, ...} => let
+              fun sort ? = SortedList.stableSort #n ?
+
+              fun group xs = let
+                 fun lp (gs, xs) x =
+                     fn y::ys =>
+                        lp (if x = y then
+                               (gs, x::xs)
+                            else
+                               ((x::xs)::gs, []))
+                           y ys
+                      | [] => (x::xs)::gs
+              in
+                 case sort S.compare xs of
+                    [] => []
+                  | x::xs => lp ([], []) x xs
+              end
+
+              fun table n allTags =
+                  punctuate comma o
+                  map (fn (n, m) => str (concat [i2s n, "% ", m])) o
+                  sort (I.compare o Pair.swap o Pair.map (Sq.mk Pair.fst)) o
+                  map (Pair.map (fn l => 100 * length l div n, hd) o Sq.mk) o
+                  group |< sort S.compare allTags
+
+              fun done msg passN tags =
+                  ((println o indent)
+                      ((str o concat)
+                          [header cfg, ":\n", msg, " ", i2s passN,
+                           " random cases passed."]::
+                       (if null tags then
+                           []
+                        else
+                           [indent (str "Statistics:" ::
+                                    table passN tags) <^> dot]))
+                 ; true)
+
+              fun lp passN skipN allTags =
+                  if passM <= passN then
+                     done "OK," passN allTags
+                  else if skipM <= skipN then
+                     done "Arguments exhausted after" passN allTags
+                  else
+                     case prop (size passN)
+                               (!rng before Ref.modify G.next rng) of
+                        (NONE, _, _) =>
+                        lp passN (skipN + 1) allTags
+                      | (SOME true, tags, _) =>
+                        lp (passN + 1) skipN (List.revAppend (tags, allTags))
+                      | (SOME false, _, msgs) =>
+                        (println
+                            (indent
+                                [str (header cfg ^ " failed."),
+                                 indent (str "Falsifiable:"::msgs)] <^>
+                             dot)
+                       ; false)
+           in
+              lp 0 0 []
+           end)
+
+   fun all t toProp =
+       G.>>= (arbitrary t,
+              fn v => fn n => fn g =>
+                 try (fn () => toProp v n g,
+                      fn (r as SOME false, ts, msgs) =>
+                         (r, ts, named t "with" v :: msgs)
+                       | p => p,
+                      fn e => (SOME false, [],
+                               [named t "with" v,
+                                named exn "raised" e])))
+   fun that b = G.return (SOME b, [], [])
+   fun skip _ _ = (NONE, [], [])
+
+   fun classify tOpt p =
+       G.prj p (fn p as (r, ts, msg) =>
+                   case tOpt & r of
+                      NONE & _ => p
+                    | _ & NONE => p
+                    | SOME t & _ => (r, t::ts, msg))
+   fun trivial b = classify (if b then SOME "trivial" else NONE)
+
+   fun collect t v p =
+       G.prj p (fn (r, ts, msg) => (r, pretty NONE (layout t v)::ts, msg))
+end


Property changes on: mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml
___________________________________________________________________
Name: svn:eol-style
   + native

[MLton-commit] r5066

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

Initial commit of a lib of misc utils to be refactored.
----------------------------------------------------------------------

A   mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.mlb

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.mlb
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.mlb	2007-01-12 12:40:13 UTC (rev 5065)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.mlb	2007-01-12 12:40:39 UTC (rev 5066)
@@ -0,0 +1,22 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(*
+ * MLB file for the unit test framework.
+ *)
+
+local
+   $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+   lib.mlb
+in
+   ann
+      "forceUsed"
+      "sequenceNonUnit warn"
+      "warnUnused true"
+   in
+      unit-test.sml
+   end
+end


Property changes on: mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.mlb
___________________________________________________________________
Name: svn:eol-style
   + native

[MLton-commit] r5065

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

Initial commit of a lib of misc utils to be refactored.
----------------------------------------------------------------------

A   mltonlib/trunk/com/ssh/misc-util/unstable/type-util.sml

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/type-util.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/type-util.sml	2007-01-12 12:39:48 UTC (rev 5064)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/type-util.sml	2007-01-12 12:40:13 UTC (rev 5065)
@@ -0,0 +1,19 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(*
+ * Utilities for defining type-indexed functions.
+ *)
+
+structure TypeUtil :> sig
+   val failExn : Exn.t -> 'a
+   val failExnSq : Exn.t Sq.t -> 'a
+end = struct
+   val ` = Exn.name
+   fun failCat ss = raise Fail (concat ss)
+   fun failExn e = failCat ["unregistered exn ", `e]
+   fun failExnSq (l, r) = failCat ["unregistered exns ", `l, " and ", `r]
+end


Property changes on: mltonlib/trunk/com/ssh/misc-util/unstable/type-util.sml
___________________________________________________________________
Name: svn:eol-style
   + native

[MLton-commit] r5064

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

Initial commit of a lib of misc utils to be refactored.
----------------------------------------------------------------------

A   mltonlib/trunk/com/ssh/misc-util/unstable/type-support.sml

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/type-support.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/type-support.sml	2007-01-12 12:39:26 UTC (rev 5063)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/type-support.sml	2007-01-12 12:39:48 UTC (rev 5064)
@@ -0,0 +1,37 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(*
+ * Supporting primitives required by {TYPE}
+ *)
+
+structure TypeSupport :> sig
+   eqtype label
+   eqtype constructor
+
+   type record
+   type tuple
+
+   val labelToString : label -> String.t
+   val constructorToString : constructor -> String.t
+
+   val L : String.t -> label
+   val C : String.t -> constructor
+end = struct
+   structure Dbg = MkDbg (open DbgDefs val name = "TypeSupport")
+
+   type label = String.t
+   type constructor = String.t
+
+   type record = Unit.t
+   type tuple = Unit.t
+
+   val labelToString = id
+   val constructorToString = id
+
+   val L = Effect.obs (fn s => Dbg.assert 0 (fn () => SmlSyntax.isLabel s))
+   val C = Effect.obs (fn s => Dbg.assert 0 (fn () => SmlSyntax.isLongId s))
+end


Property changes on: mltonlib/trunk/com/ssh/misc-util/unstable/type-support.sml
___________________________________________________________________
Name: svn:eol-style
   + native