mlton-commit — [MLton-commit] Code commits

[MLton-commit] r5038

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/node.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/node.sml	2007-01-12 12:29:12 UTC (rev 5037)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/node.sml	2007-01-12 12:29:27 UTC (rev 5038)
@@ -0,0 +1,159 @@
+(* 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.
+ *)
+
+(*
+ * Imperative singly linked list node.  This is useful and often more
+ * convenient than a functional list when implementing imperative data
+ * structures.
+ *
+ * Note that imperative lists may form cycles and, unless otherwise
+ * specified, procedures specified in this module are not specifically
+ * designed to work with cyclic lists.
+ *)
+
+structure Node :> sig
+   eqtype 'a t
+
+   val new : 'a t Thunk.t
+   (** Allocates a new empty node. *)
+
+   val get : 'a t -> ('a * 'a t) Option.t
+   (** Returns the contents of the node. *)
+
+   val <- : ('a t * ('a * 'a t) Option.t) Effect.t
+   (** Sets the contents of the node. *)
+
+   val isEmpty : 'a t UnPr.t
+   (** Returns true iff the imperative list is empty. *)
+
+   val hd : 'a t -> 'a
+   (**
+    * Returns the first element of the imperative list.  Raises {Empty} if
+    * the list is empty.
+    *)
+
+   val tl : 'a t -> 'a t
+   (**
+    * Returns the next node of the imperative list.  Raises {Empty} if the
+    * list is empty.
+    *)
+
+   val push : 'a t -> 'a Effect.t
+   (**
+    * Inserts the given element into the imperative list after the given
+    * node.
+    *)
+
+   val take : 'a t -> 'a Option.t
+   (**
+    * If the imperative list is non-empty, removes the first element {v}
+    * of the list and returns {SOME v}.  Otherwise returns {NONE}.
+    *)
+
+   val drop : 'a t Effect.t
+   (**
+    * If the imperative list is non-empty, removes the first element of
+    * the list.  Otherwise does nothing.
+    *)
+
+   val clearWith : 'a Effect.t -> 'a t Effect.t
+   (**
+    * Takes all elements of the imperative list of nodes one-by-one and
+    * performs the given effect on the removed elements.
+    *)
+
+   val fromList : 'a List.t -> 'a t
+   (** Constructs an imperative list from a functional list. *)
+
+   val app : 'a Effect.t -> 'a t Effect.t
+   (**
+    * Applies the given effect to all elements of the imperative list.
+    * {app} is to be implemented tail recursively.
+    *)
+
+   val find : 'a UnPr.t -> 'a t -> ('a t, 'a t) Sum.t
+   (**
+    * Returns {INR n} where {n} is first node containing an element
+    * satisfying the given predicate or {INL n} where {n} is the last node
+    * in the imperative list.  {find} is to be implemented tail
+    * recursively.
+    *)
+
+   val foldl : ('a * 'b -> 'b) -> 'b -> 'a t -> 'b
+   (**
+    * Folds the imperative lists with the given function and starting
+    * value.  {foldl} is to be implemented tail recursively.
+    *)
+end = struct
+   datatype 'a t = IN of ('a * 'a t) Option.t Ref.t
+   fun new () = IN (ref NONE)
+   fun get (IN t) = !t
+   fun (IN r) <- t = r := t
+
+   (* The following only use the operations {new}, {get}, and {<-}. *)
+
+   fun fromList l = let
+      val h = new ()
+      fun lp ([], _) = ()
+        | lp (x::xs, t) = let
+         val t' = new ()
+      in
+         t <- SOME (x, t')
+       ; lp (xs, t')
+      end
+   in
+      lp (l, h)
+    ; h
+   end
+
+   fun isEmpty t =
+       not (isSome (get t))
+
+   local
+      fun eat t =
+          case get t of
+             NONE => raise Empty
+           | SOME x => x
+   in
+      fun hd t = #1 (eat t)
+      fun tl t = #2 (eat t)
+   end
+
+   fun push t x = let
+      val n = new ()
+   in
+      n <- get t
+    ; t <- SOME (x, n)
+   end
+
+   fun take t =
+       case get t of
+          NONE => NONE
+        | SOME (x, t') => (t <- get t' ; SOME x)
+
+   fun drop t =
+       ignore (take t)
+
+   fun clearWith e t =
+       case take t of
+          NONE => ()
+        | SOME x => (e x : unit ; clearWith e t)
+
+   fun foldl f x t =
+       case get t of
+          NONE => x
+        | SOME (y, t) =>
+          foldl f (f (y, x)) t
+
+   fun app e =
+       foldl (e o #1) ()
+
+   fun find p t =
+       case get t of
+          NONE => INL t
+        | SOME (x, t') =>
+          if p x then INR t else find p t'
+end


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

[MLton-commit] r5037

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

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

A   mltonlib/trunk/com/ssh/misc-util/unstable/mk-random-gen.fun

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/mk-random-gen.fun
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/mk-random-gen.fun	2007-01-12 12:28:55 UTC (rev 5036)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/mk-random-gen.fun	2007-01-12 12:29:12 UTC (rev 5037)
@@ -0,0 +1,94 @@
+(* 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 functor for making random value generator combinators from a module
+ * providing a random number generator.
+ *)
+
+functor MkRandomGen (RNG : RNG) :>
+   RANDOM_GEN
+      where type t = RNG.t = struct
+   structure D = MkDbg (open DbgDefs val name = "MkRandomGen")
+         and A = Array and R = Real and V = Vector and W = Word
+
+   open RNG
+   type 'a gen = Int.t -> t -> 'a
+
+   val lift = const
+   fun return a _ _ = a
+   fun (m >>= k) n r = k (m n (split 0w314 r)) n (split 0w159 r)
+   fun prj gb b2a n = b2a o gb n
+   fun promote a2b n r a = a2b a n r
+   fun sized i2g n r = i2g n n r
+   fun resize f g = g o f
+   fun bool _ r = maxValue div 0w2 < value r
+
+   fun inRange bInRange (a2b, b2a) =
+       flip prj b2a o bInRange o Pair.map (Sq.mk a2b)
+
+   fun wordInRange (l, h) =
+       (D.assert 0 (fn () => l <= h)
+      ; let val n = h - l + 0w1     (* XXX may overflow *)
+            val d = maxValue div n  (* XXX may result in zero *)
+            val m = n * d
+        in lift (fn r => value r mod m div d + l)
+        end)
+
+   fun intInRange (l, h) =
+       (D.assert 0 (fn () => l <= h)
+      ; prj (inRange wordInRange (Iso.swap W.isoInt) (0, h - l))
+            (op + /> l))
+
+   local
+      val w2r = R.fromLargeInt o W.toLargeInt
+   in
+      fun realInRange (l, h) =
+          (D.assert 0 (fn () => l <= h)
+         ; let val m = (h - l) / w2r maxValue
+           in const (fn r => w2r (value r) * m + l)
+           end)
+   end
+
+   fun elements xs =
+       let val xs = V.fromList xs
+       in prj (intInRange (0, V.length xs)) (xs <\ V.sub)
+       end
+
+   fun oneOf gs = elements gs >>= id
+
+   fun frequency xs = let
+      val xs = A.fromList xs
+      val tot = A.foldli (fn (i, (n, g), tot) =>
+                             (A.update (xs, i, (n+tot, g)) ; n+tot))
+                         0 xs
+      fun pick i n = let
+         val (k, x) = A.sub (xs, i)
+      in
+         if n <= k then x else pick (i+1) n
+      end
+   in
+      intInRange (1, tot) >>= pick 0
+   end
+
+   local
+      fun unfold px sx x2y = let
+         fun lp ys x =
+             if px x then
+                rev ys
+             else
+                lp (x2y x::ys) (sx x)
+      in
+         lp []
+      end
+   in
+      fun list ga m n r =
+          unfold (op = /> 0w0)
+                 (op - /> 0w1)
+                 (ga n o flip split r)
+                 (W.fromInt m)
+   end
+end


Property changes on: mltonlib/trunk/com/ssh/misc-util/unstable/mk-random-gen.fun
___________________________________________________________________
Name: svn:eol-style
   + native

[MLton-commit] r5036

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/misc-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/misc-test.sml	2007-01-12 12:28:35 UTC (rev 5035)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/misc-test.sml	2007-01-12 12:28:55 UTC (rev 5036)
@@ -0,0 +1,44 @@
+(* 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.
+ *)
+
+(*
+ * Unit tests for the {Misc} module.
+ *)
+
+val () = let
+   open Type UnitTest
+in
+   unitTests
+      (title "Misc.ranqd1")
+
+      (testEq
+          (list word32)
+          (fn () =>
+              {expect = [0wxCBF633B1, 0wx94F0AF1A, 0wx81FDBEE7,
+                         0wxA3D95FA8, 0wx57FE6C2D, 0wx9F2EC686,
+                         0wx6252E503, 0wxAAF95334, 0wxD1CCF6E9,
+                         0wx47502932, 0wx3C6EF35F, 0wx0],
+               actual = #2 |< repeat
+                         (fn (x, ys) =>
+                             (Misc.ranqd1 x, x::ys))
+                         12
+                         (0w0, [])}))
+
+      (title "Misc.psdes")
+
+      (testEq
+          (list (sq word32))
+          (fn () =>
+              {expect = [(0wx604D1DCE, 0wx509C0C23),
+                         (0wxD97F8571, 0wxA66CB41A),
+                         (0wx7822309D, 0wx64300984),
+                         (0wxD7F376F0, 0wx59BA89EB)],
+               actual = map Misc.psdes
+                            [(0w1, 0w1), (0w1, 0w99),
+                             (0w99, 0w1), (0w99, 0w99)]}))
+
+      $
+end


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

[MLton-commit] r5035

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/misc.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/misc.sml	2007-01-12 12:28:23 UTC (rev 5034)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/misc.sml	2007-01-12 12:28:35 UTC (rev 5035)
@@ -0,0 +1,44 @@
+(* 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.
+ *)
+
+(*
+ * Some miscellaneous utilities.
+ *)
+
+structure Misc :> sig
+   val ranqd1 : Word32.t UnOp.t
+   (**
+    * This implements the quick-and-dirty linear congruential pseudo
+    * random number generator described on page 284 of the book Numerical
+    * Recipes in C.  Perhaps the most important feature of this generator
+    * is that it cycles through all 32-bit words.  This is useful if you
+    * want to generate unique 32-bit identifiers.
+    *
+    * Warning: If you need a high-quality pseudo random number generator
+    * for simulation purposes, then this isn't for you.
+    *)
+
+   val psdes : Word32.t Sq.t UnOp.t
+   (**
+    * This implements the "Pseudo-DES" algorithm described in section 7.5
+    * of the book Numerical Recipes in C.
+    *)
+end = struct
+   fun ranqd1 s : Word32.t = s * 0w1664525 + 0w1013904223
+
+   val psdes =
+       flip (foldl (fn ((c1, c2), (lw, rw)) => let
+                       open Word32
+                       val a = rw xorb c1
+                       val al = a andb 0wxFFFF
+                       val ah = a >> 0w16
+                       val b = al*al + notb (ah*ah)
+                    in (rw,
+                        lw xorb (al*ah + (c2 xorb (b >> 0w16 orb b << 0w16))))
+                    end))
+            [(0wxBAA96887, 0wx4B0F3B58), (0wx1E17D32C, 0wxE874F0C3),
+             (0wx03BCDC3C, 0wx6955C5A6), (0wx0F33D1B2, 0wx55A7CA46)]
+end


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

[MLton-commit] r5034

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/lift.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/lift.sml	2007-01-12 12:28:10 UTC (rev 5033)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/lift.sml	2007-01-12 12:28:23 UTC (rev 5034)
@@ -0,0 +1,38 @@
+(* 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.
+ *)
+
+(*
+ * Utility module for lifting type-indexed values.
+ *)
+
+structure Lift :> sig
+   type ('t, 'u) t
+
+   val id : ('a, 'a) t
+
+   val get : ('a, 'b) t Thunk.t -> ('a -> 'c) -> 'b -> 'c
+
+   val update : ('a, 'b) t Thunk.t -> 'a UnOp.t -> 'b UnOp.t
+
+   val A : ('a, 'a * 'b) t
+   val B : ('b, 'a * 'b) t
+
+   val ^ : ('m, 'u) t * ('t, 'm) t -> ('t, 'u) t
+end = struct
+   datatype ('t, 'u) t = IN of {get : 'u -> 't, update : 't UnOp.t -> 'u UnOp.t}
+   fun out (IN t) = t
+
+   val id = IN {get = id, update = id}
+
+   fun get lift = op o /> #get (out (lift ()))
+   fun update lift = #update (out (lift ()))
+
+   val A = IN {get = Pair.fst, update = Pair.mapFst}
+   val B = IN {get = Pair.snd, update = Pair.mapSnd}
+
+   fun (IN {get = gL, update = uL}) ^ (IN {get = gR, update = uR}) =
+       IN {get = gR o gL, update = uL o uR}
+end


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

[MLton-commit] r5033

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

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

A   mltonlib/trunk/com/ssh/misc-util/unstable/LICENSE

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

Copied: mltonlib/trunk/com/ssh/misc-util/unstable/LICENSE (from rev 5014, mltonlib/trunk/com/ssh/extended-basis/unstable/LICENSE)
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/LICENSE	2007-01-07 16:33:41 UTC (rev 5014)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/LICENSE	2007-01-12 12:28:10 UTC (rev 5033)
@@ -0,0 +1,20 @@
+COPYRIGHT NOTICE, LICENSE AND DISCLAIMER.
+
+Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+
+Permission to use, copy, modify, and distribute this software and its
+documentation for any purpose and without fee is hereby granted,
+provided that the above copyright notice appear in all copies and that
+both the copyright notice and this permission notice and warranty
+disclaimer appear in supporting documentation, and that the name of
+the above copyright holders, or their entities, not be used in
+advertising or publicity pertaining to distribution of the software
+without specific, written prior permission.
+
+The above copyright holders disclaim all warranties with regard to
+this software, including all implied warranties of merchantability and
+fitness. In no event shall the above copyright holders be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether in an
+action of contract, negligence or other tortious action, arising out
+of or in connection with the use or performance of this software.

[MLton-commit] r5032

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/lib.mlb	2007-01-12 12:27:50 UTC (rev 5031)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/lib.mlb	2007-01-12 12:27:59 UTC (rev 5032)
@@ -0,0 +1,92 @@
+(* 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 misc utilities.
+ *)
+
+$(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+
+ann
+   "forceUsed"
+   "sequenceNonUnit warn"
+   "warnUnused true"
+in
+   (* base *)
+   infixes.sml
+   basic.sml
+   dbg.sml
+
+   (* misc *)
+   misc.sml
+
+   bit-flags.sml
+
+   (* variable argument fold *)
+   fold.sml
+   fold01n.sml
+   fold-pair.sml
+
+   fru.sml
+
+   sorted-list.sml
+
+   node.sml
+
+   queue.sig
+   queue.sml
+
+   word-table.sig
+   word-table.sml
+
+   cache.sig
+   local
+      $(SML_LIB)/mlnlffi-lib/mlnlffi-lib.mlb
+   in
+      cache.sml
+   end
+
+   (* SML *)
+   sml-syntax.sml
+
+   (* pretty printing *)
+   prettier.sml
+
+   (* random generators *)
+   rng.sig
+   random-gen.sig
+   mk-random-gen.fun
+   ranqd1-gen.sml
+   random-dev.sig
+   local
+      $(MLTON_ROOT)/basis/mlton.mlb
+   in
+      random-dev-mlton.sml
+   end
+
+   (* type-indexed stuff *)
+   structural-type.sig
+   structural-type-pair.fun
+   type-support.sml
+   type.sig
+   type-pair.fun
+   structural-type-to-type.fun
+   type-util.sml
+   lift.sml
+
+   (* structural type-indexed values *)
+   dummy.sml
+   type-info.sml
+   arbitrary.sml
+   compare.sml
+   eq.sml
+
+   (* nominal type-indexed values *)
+   show.sml
+
+   (* combined type-indexed values *)
+   type.sml
+end


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

[MLton-commit] r5031

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/infixes.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/infixes.sml	2007-01-12 12:27:36 UTC (rev 5030)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/infixes.sml	2007-01-12 12:27:50 UTC (rev 5031)
@@ -0,0 +1,26 @@
+(* 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.
+ *)
+
+(*
+ * Global operator precedence table.
+ *
+ * We assume here the modified precedence table of the extended basis library.
+ *)
+
+(* ************************************************************************** *)
+(*       !  Prettier !                                                        *)
+(* ========================================================================== *)
+infix  7 !           ! |`
+(* ========================================================================== *)
+infixr 7 ! <^> <+>   !
+(* ========================================================================== *)
+infixr 6 ! <$> <$$>  !
+         ! </> <//>  !
+(* ========================================================================== *)
+infix  1 ! <-        ! += -=
+(* ************************************************************************** *)
+
+nonfix ! (* We just used ! above as a visual separator. *)


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

[MLton-commit] r5030

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/fru.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/fru.sml	2007-01-12 12:27:21 UTC (rev 5029)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/fru.sml	2007-01-12 12:27:36 UTC (rev 5030)
@@ -0,0 +1,77 @@
+(* 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.
+ *)
+
+(*
+ * Support for functional record update.
+ *
+ * See
+ *
+ *   http://mlton.org/FunctionalRecordUpdate
+ *
+ * for further information.
+ *)
+
+structure FRU = struct
+   local
+      fun pathFold ? = Fold01N.fold {zero = const (), none = id, some = id} ?
+      fun pathStep ? =
+          Fold01N.step0
+             {none = const id,
+              some = fn m =>
+                        fn p =>
+                           m (p o INL) &
+                             (p o INR)} ?
+
+      fun setFold ? = Fold01N.fold {zero = id, none = id, some = id} ?
+      fun setStep ? =
+          Fold01N.step0
+             {none = const const,
+              some = fn u =>
+                        fn INL p =>
+                           (fn l & r => u p l & r)
+                         | INR v =>
+                           (fn l & _ => l & v)} ?
+   in
+      fun make ? =
+          FoldPair.fold
+             (pathFold, setFold)
+             (fn (m, u) =>
+                 fn iso : ('r1, 'p1) Iso.t =>
+                    fn (_, p2r') : ('r2, 'p2) Iso.t =>
+                       p2r' (m (Fn.map iso o u))) ?
+
+      fun A ? = FoldPair.step0 (pathStep, setStep) ?
+   end
+
+   (* 2^n *)
+   val A1 = A
+   fun A2 ? = pass ? A1 A1
+   fun A4 ? = pass ? A2 A2
+   fun A8 ? = pass ? A4 A4
+
+   (* 2^i + j where j < 2^i *)
+   fun A3  ? = pass ? A2 A1
+   fun A5  ? = pass ? A4 A1
+   fun A6  ? = pass ? A4 A2
+   fun A7  ? = pass ? A4 A3
+   fun A9  ? = pass ? A8 A1
+   fun A10 ? = pass ? A8 A2
+   fun A11 ? = pass ? A8 A3
+   fun A12 ? = pass ? A8 A4
+   fun A13 ? = pass ? A8 A5
+   fun A14 ? = pass ? A8 A6
+   fun A15 ? = pass ? A8 A7
+
+   fun updData iso u = Fold.fold ((id, u), Fn.map iso o Pair.fst)
+   fun fruData iso = Fold.post (fn f => fn ~ => updData iso o f ~) make
+
+   fun upd ? = updData Iso.id ?
+   fun fru ? = fruData Iso.id ?
+
+   fun U s v = Fold.step0 (fn (f, u) => (s u v o f, u))
+end
+
+val U = FRU.U


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

[MLton-commit] r5029

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/fold.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/fold.sml	2007-01-12 12:27:09 UTC (rev 5028)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/fold.sml	2007-01-12 12:27:21 UTC (rev 5029)
@@ -0,0 +1,87 @@
+(* 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.
+ *)
+
+(*
+ * Utility module for defining "variadic" type-indexed functions in SML.
+ *
+ * See
+ *
+ *   http://mlton.org/Fold
+ *
+ * for extensive discussion of the subject.
+ *)
+
+structure Fold = struct
+   type ('a, 'b, 'c, 'd) step =
+        'a * ('b -> 'c) -> 'd
+   type ('a, 'b, 'c, 'd) t =
+        ('a, 'b, 'c, 'd) step -> 'd
+   type ('a, 'b, 'c, 'd, 'e) step0 =
+        ('a, 'c, 'd, ('b, 'c, 'd, 'e) t) step
+   type ('a, 'b, 'c, 'd, 'e, 'f) step1 =
+        ('b, 'd, 'e, 'a -> ('c, 'd, 'e, 'f) t) step
+end
+
+signature FOLD = sig
+   type ('a, 'b, 'c, 'd) step =
+        ('a, 'b, 'c, 'd) Fold.step
+   type ('a, 'b, 'c, 'd) t =
+        ('a, 'b, 'c, 'd) Fold.t
+   type ('a, 'b, 'c, 'd, 'e) step0 =
+        ('a, 'b, 'c, 'd, 'e) Fold.step0
+   type ('a, 'b, 'c, 'd, 'e, 'f) step1 =
+        ('a, 'b, 'c, 'd, 'e, 'f) Fold.step1
+
+   val fold : 'a * ('b -> 'c) -> ('a, 'b, 'c, 'd) t
+   val unfold : ('a, 'b, 'c, 'a * ('b -> 'c)) t
+                -> 'a * ('b -> 'c)
+   val lift : ('a, 'b, 'c, 'a * ('b -> 'c)) t
+              -> ('a, 'b, 'c, 'd) t
+
+   val post : ('a -> 'd)
+              -> ('b, 'c, 'a, 'b * ('c -> 'a)) t
+              -> ('b, 'c, 'd, 'e) t
+
+   val step0 : ('a -> 'b)
+               -> ('a, 'b, 'c, 'd, 'e) step0
+   val step1 : ('a * 'b -> 'c)
+               -> ('a, 'b, 'c, 'd, 'e, 'f) step1
+
+   val unstep0 : ('a, 'b, 'b, 'b, 'b) step0
+                 -> 'a -> 'b
+   val unstep1 : ('a, 'b, 'c, 'c, 'c, 'c) step1
+                 -> 'a * 'b -> 'c
+
+   val lift0 : ('a, 'b, 'b, 'b, 'b) step0
+               -> ('a, 'b, 'c, 'd, 'e) step0
+   val lift1 : ('a, 'b, 'c, 'c, 'c, 'c) step1
+               -> ('a, 'b, 'c, 'd, 'e, 'f) step1
+   val lift0to1 : ('b, 'c, 'c, 'c, 'c) step0
+                  -> ('a, 'b, 'c, 'd, 'e, 'f) step1
+end
+
+fun $ (x, f) = f x
+
+structure Fold :> FOLD = struct
+   open Fold
+
+   val fold = pass
+   fun unfold f = f id
+   fun lift ? = (fold o unfold) ?
+
+   fun post g = fold o Pair.map (id, fn f => g o f) o unfold
+
+   fun step0 h (a1, f) = fold (h a1, f)
+   fun step1 h (a2, f) a1 = fold (h (a1, a2), f)
+
+   fun unstep0 s a1 = fold (a1, id) s $
+   fun unstep1 s (a1, a2) = fold (a2, id) s a1 $
+
+   fun lift0 ? = (step0 o unstep0) ?
+   fun lift1 ? = (step1 o unstep1) ?
+
+   fun lift0to1 s = step1 (unstep0 s o Pair.snd)
+end


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

[MLton-commit] r5028

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/fold-pair.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/fold-pair.sml	2007-01-12 12:26:48 UTC (rev 5027)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/fold-pair.sml	2007-01-12 12:27:09 UTC (rev 5028)
@@ -0,0 +1,62 @@
+(* 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.
+ *)
+
+(*
+ * Utility module for pairing folds (see fold.sml).
+ *)
+
+(* XXX create FoldProduct for tupling an arbitrary number of folds easily *)
+
+structure FoldPair = struct
+   type ('a, 'b, 'c, 'd, 'e, 'f) t =
+        ('a * 'b, 'c * 'd, 'e, 'f) Fold.t
+   type ('a, 'b, 'c, 'd, 'e, 'f, 'g) step0 =
+        ('a * 'c, 'b * 'd, 'e, 'f, 'g) Fold.step0
+   type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) step1 =
+        ('a, 'b * 'd, 'c * 'e, 'f, 'g, 'h) Fold.step1
+end
+
+signature FOLD_PAIR = sig
+   type ('a, 'b, 'c, 'd, 'e, 'f) t =
+        ('a, 'b, 'c, 'd, 'e, 'f) FoldPair.t
+   type ('a, 'b, 'c, 'd, 'e, 'f, 'g) step0 =
+        ('a, 'b, 'c, 'd, 'e, 'f, 'g) FoldPair.step0
+   type ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) step1 =
+        ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) FoldPair.step1
+
+   val fold : ('a, 'b, 'c, 'a * ('b -> 'c)) Fold.t
+              * ('d, 'e, 'f, 'd * ('e -> 'f)) Fold.t
+              -> ('c * 'f -> 'g)
+              -> ('a, 'd, 'b, 'e, 'g, 'h) t
+   val step0 : ('a, 'b, 'b, 'b, 'b) Fold.step0
+               * ('c, 'd, 'd, 'd, 'd) Fold.step0
+               -> ('a, 'b, 'c, 'd, 'e, 'f, 'g) step0
+   val step1 : ('a, 'b, 'c, 'c, 'c, 'c) Fold.step1
+               * ('a, 'd, 'e, 'e, 'e, 'e) Fold.step1
+               -> ('a, 'b, 'c, 'd, 'e, 'f, 'g, 'h) step1
+end
+
+structure FoldPair :> FOLD_PAIR = struct
+   open FoldPair
+
+   fun fold (l, r) f = let
+      val (la, lf) = Fold.unfold l
+      val (ra, rf) = Fold.unfold r
+   in
+      Fold.fold ((la, ra), f o Pair.map (lf, rf))
+   end
+
+   fun step0 (l, r) =
+       Fold.step0 (Pair.map (Fold.unstep0 l,
+                             Fold.unstep0 r))
+
+   fun step1 (l, r) =
+       Fold.step1 (Pair.map (Fold.unstep1 l,
+                             Fold.unstep1 r)
+                   o (fn (a11, (a12l, a12r)) =>
+                         ((a11, a12l),
+                          (a11, a12r))))
+end


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

[MLton-commit] r5027

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/fold01n.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/fold01n.sml	2007-01-12 12:26:02 UTC (rev 5026)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/fold01n.sml	2007-01-12 12:26:48 UTC (rev 5027)
@@ -0,0 +1,59 @@
+(* 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.
+ *)
+
+(*
+ * Utility module for creating folds (see fold.sml) that need to treat the
+ * cases of 0 and 1 or more steps differently.
+ *
+ * See
+ *
+ *   http://mlton.org/Fold01N
+ *
+ * for discussion.
+ *)
+
+signature FOLD01N = sig
+   type ('a, 'b, 'c, 'd, 'e, 'f, 'g) ac
+
+   val fold : {none: 'a -> 'b,
+               some: 'c -> 'd,
+               zero: 'e}
+              -> (('e, 'f, 'g, 'h, 'i, 'f, 'g) ac,
+                  ('j, 'a, 'b, 'c, 'd, 'j, 'k) ac,
+                  'k, 'l) Fold.t
+   val step0 : {none: 'a -> 'b,
+                some: 'c -> 'd}
+               -> (('e, 'a, 'b, 'c, 'd, 'e, 'f) ac,
+                   ('f, 'g, 'h, 'i, 'j, 'i, 'j) ac,
+                   'k, 'l, 'm) Fold.step0
+   val step1 : {none: 'a -> 'b,
+                some: 'c -> 'd}
+               -> ('e,
+                   ('f, 'a, 'b, 'c, 'd, 'e * 'f, 'g) ac,
+                   ('g, 'h, 'i, 'j, 'k, 'j, 'k) ac,
+                   'l, 'm, 'n) Fold.step1
+end
+
+structure Fold01N :> FOLD01N = struct
+   datatype ('a, 'b, 'c, 'd, 'e, 'f, 'g) ac =
+            IN of 'a * (('b -> 'c) * ('d -> 'e) -> 'f -> 'g)
+
+   fun fold {zero, none, some} =
+       Fold.fold (IN (zero, Pair.fst),
+                  fn IN (ac, pick) =>
+                     pick (none, some) ac)
+
+   fun step0 {none, some} =
+       Fold.step0 (fn IN (ac, pick) =>
+                      IN (pick (none, some) ac,
+                          Pair.snd))
+
+   fun step1 {none, some} =
+       Fold.step1 (fn (x, IN (ac, pick)) =>
+                      IN (pick (none, some)
+                               (x, ac),
+                          Pair.snd))
+end


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

[MLton-commit] r5026

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/ffi.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/ffi.sml	2007-01-12 12:25:43 UTC (rev 5025)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/ffi.sml	2007-01-12 12:26:02 UTC (rev 5026)
@@ -0,0 +1,17 @@
+(* 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


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

[MLton-commit] r5025

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/eq.sml	2007-01-12 12:25:32 UTC (rev 5024)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/eq.sml	2007-01-12 12:25:43 UTC (rev 5025)
@@ -0,0 +1,93 @@
+(* 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 a type-indexed equality relation.  For equality
+ * types the semantics is the same as SML's built-in equality.  User
+ * defined types, exceptions, and reals are given a natural, structural,
+ * semantics of equality.  Functions, obviously, can't be supported.
+ *)
+
+signature EQ = sig
+   type 'a eq_t
+
+   val eq : 'a eq_t -> 'a BinPr.t
+   (**
+    * Extracs the equality relation.  Note that the type parameter {'a}
+    * isn't an equality type variable.
+    *)
+
+   val notEq : 'a eq_t -> 'a BinPr.t
+   (** {notEq t = not o eq t} *)
+end
+
+functor LiftEq
+           (include EQ
+            type 'a t
+            val lift : ('a eq_t, 'a t) Lift.t Thunk.t) : EQ = struct
+   type 'a eq_t = 'a t
+   val eq    = fn ? => Lift.get lift eq    ?
+   val notEq = fn ? => Lift.get lift notEq ?
+end
+
+structure Eq :> sig
+   include STRUCTURAL_TYPE
+   include EQ where type 'a eq_t = 'a t
+end = struct
+   type 'a t = 'a BinPr.t
+   type 'a eq_t = 'a t
+
+   val eq = id
+   val notEq = negate
+
+   fun iso b (a2b, _) = b o Pair.map (Sq.mk a2b)
+
+   val op *` = Product.equal
+   val op +` = Sum.equal
+
+   val Y = Tie.function
+
+   local
+      val e = Fail "Eq.--> not supported"
+   in
+      fun _ --> _ = failing e
+   end
+
+   val exn : exn t ref = ref TypeUtil.failExnSq
+   fun regExn t (_, prj) =
+       Ref.modify (fn exn =>
+                      fn (l, r) =>
+                         case prj l & prj r of
+                            SOME l & SOME r => t (l, r)
+                          | SOME _ & NONE   => false
+                          | NONE   & SOME _ => false
+                          | NONE   & NONE   => exn (l, r)) exn
+   val exn = fn ? => !exn ?
+
+   fun array _ = op =
+   fun refc _ = op =
+
+   val list = ListPair.allEq
+
+   fun vector eq = iso (list eq) Vector.isoList (* XXX can be optimized *)
+
+   val bool   = op =
+   val char   = op =
+   val int    = op =
+   val real   = Real.==
+   val string = op =
+   val unit   = op =
+   val word   = op =
+
+   val largeInt  = op =
+   val largeReal = LargeReal.==
+   val largeWord = op =
+
+   val word8  = op =
+   val word16 = op =
+   val word32 = op =
+   val word64 = op =
+end


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

[MLton-commit] r5024

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/dummy.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/dummy.sml	2007-01-12 12:25:21 UTC (rev 5023)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/dummy.sml	2007-01-12 12:25:32 UTC (rev 5024)
@@ -0,0 +1,106 @@
+(* 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 a type-indexed family of dummy values.  In Standard
+ * ML, dummy values are needed for things such as computing fixpoints and
+ * building cyclic values.
+ *
+ * This type-indexed function is unlikely to be directly useful in
+ * application programs and is more likely to be used internally in the
+ * implementation of some other type-indexed functions (e.g. pickling).
+ *)
+
+signature DUMMY = sig
+   type 'a dummy_t
+
+   exception Dummy
+   (**
+    * This is raised when trying to extract the dummy value in case of
+    * unfounded recursion or an abstract type that has not been given a
+    * dummy value.
+    *)
+
+   val dummy : 'a dummy_t -> 'a
+   (** Extracts the dummy value or raises {Dummy}. *)
+
+   val noDummy : 'a dummy_t UnOp.t
+   (**
+    * Removes the dummy value from the given type-index.  This can be used
+    * for encoding abstract types that can not be given dummy values.
+    *)
+end
+
+functor LiftDummy
+           (include DUMMY
+            type 'a t
+            val lift : ('a dummy_t, 'a t) Lift.t Thunk.t) : DUMMY = struct
+   type 'a dummy_t = 'a t
+   exception Dummy = Dummy
+   val dummy   = fn ? => Lift.get    lift dummy   ?
+   val noDummy = fn ? => Lift.update lift noDummy ?
+end
+
+structure Dummy :> sig
+   include STRUCTURAL_TYPE
+   include DUMMY where type 'a dummy_t = 'a t
+end = struct
+   type 'a t = 'a option
+   type 'a dummy_t = 'a t
+
+   exception Dummy
+
+   val dummy = fn SOME v => v
+                | NONE => raise Dummy
+
+   fun noDummy _ = NONE
+
+   fun iso b = flip Option.map b o Iso.from
+
+   fun a *` b = case a & b of
+                   SOME a & SOME b => SOME (a & b)
+                 | _ => NONE
+
+   fun a +` b = case a of
+                   SOME a => SOME (INL a)
+                 | NONE => Option.map INR b
+
+   val unit = SOME ()
+
+   fun Y ? = Tie.pure (const (NONE, id)) ?
+
+   local
+      val e = Fail "Dummy.-->"
+   in
+      fun _ --> _ = SOME (failing e)
+   end
+
+   val exn = SOME Empty
+   fun regExn _ _ = ()
+
+   fun array _ = SOME (Array.tabulate (0, undefined))
+   fun refc  ? = Option.map ref ?
+
+   fun vector _ = SOME (Vector.tabulate (0, undefined))
+
+   val largeInt  : LargeInt.int   t = SOME 0
+   val largeReal : LargeReal.real t = SOME 0.0
+   val largeWord : LargeWord.word t = SOME 0w0
+
+   fun list _ = SOME []
+
+   val bool   = SOME false
+   val char   = SOME #"\000"
+   val int    = SOME 0
+   val real   = SOME 0.0
+   val string = SOME ""
+   val word   = SOME 0w0
+
+   val word8  : Word8.word  t = SOME 0w0
+   val word16 : Word16.word t = SOME 0w0
+   val word32 : Word32.word t = SOME 0w0
+   val word64 : Word64.word t = SOME 0w0
+end


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

[MLton-commit] r5023

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/dbg.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/dbg.sml	2007-01-12 12:25:08 UTC (rev 5022)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/dbg.sml	2007-01-12 12:25:21 UTC (rev 5023)
@@ -0,0 +1,88 @@
+(* 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.
+ *)
+
+(*
+ * Module level configurable debugging framework.
+ *)
+
+(* XXX This design and implementation is experimental and likely to change.
+ *     Feedback is welcome!
+ *)
+
+signature DBG = sig
+   exception Assertion
+   val check : Bool.t -> Exn.t Effect.t
+   val verify : Bool.t Effect.t
+   val assert : Int.t -> Bool.t Thunk.t Effect.t
+   val log : Int.t -> String.t Thunk.t Effect.t
+end
+
+structure DbgControl = struct
+   type module =
+        {name : String.t,
+         assertLevel : Int.t Ref.t,
+         logLevel : Int.t Ref.t,
+         output : (String.t * String.t) Effect.t Ref.t}
+end
+
+signature DBG_CONTROL = sig
+   type module = DbgControl.module
+   val app : module Effect.t Effect.t
+end
+
+signature DBG_OPT = sig
+   val name : String.t
+   val enableLog : Bool.t
+   val enableAssert : Bool.t
+end
+
+structure DbgDefs :> DBG_OPT = struct
+   val name = ""
+   val enableLog = true
+   val enableAssert = true
+end
+
+structure DbgControl = struct
+   open DbgControl
+
+   exception Assertion
+
+   fun check b e = if b then () else raise e
+   fun verify b = check b Assertion
+   fun output (name, msg) =
+       TextIO.output (TextIO.stdErr, concat [name, ": ", msg, "\n"])
+
+   local
+      val modules = ref ([] : module list)
+   in
+      fun register m = modules := m :: !modules
+      fun app ef = List.app ef (!modules)
+   end
+end
+
+functor MkDbg (Opt : DBG_OPT) :> DBG = struct
+   open DbgControl Opt
+
+   val output = ref output
+
+   val assertLevel = ref 0
+   fun assert l t =
+       if not enableAssert orelse !assertLevel < l then ()
+       else verify (t ())
+
+   val logLevel = ref 0
+   fun log l m =
+       if not enableLog orelse !logLevel < l then ()
+       else !output (name, m ())
+
+   val () = register
+               {name = name,
+                assertLevel = assertLevel,
+                logLevel = logLevel,
+                output = output}
+end
+
+structure DbgControl :> DBG_CONTROL = DbgControl


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

[MLton-commit] r5022

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/compare.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/compare.sml	2007-01-12 12:24:57 UTC (rev 5021)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/compare.sml	2007-01-12 12:25:08 UTC (rev 5022)
@@ -0,0 +1,97 @@
+(* 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 a type-indexed family of compare functions.  The
+ * idea is that the compare functions just implement some arbitrary
+ * logical ordering that you need for things such as search trees.
+ *
+ * Note that comparison of functions is impossible and fails at run-time.
+ * Comparison of exceptions only works when both exception constructors
+ * involved in a comparison have been registered with {regExn}.  Also,
+ * comparison of arrays and references does not coincide with SML's notion
+ * of equality.  More precisely, for an implementation of the {COMPARE}
+ * signature, two arrays (or refs) {a} and {b} may compare {EQUAL}, but it
+ * is not necessarily the case that {a=b} evaluates to {true}.
+ *)
+
+signature COMPARE = sig
+   type 'a compare_t
+
+   val compare : 'a compare_t -> 'a Cmp.t
+   (** Extracts the compare function. *)
+end
+
+functor LiftCompare
+           (include COMPARE
+            type 'a t
+            val lift : ('a compare_t, 'a t) Lift.t Thunk.t) : COMPARE = struct
+   type 'a compare_t = 'a t
+   val compare = fn ? => Lift.get lift compare ?
+end
+
+structure Compare :> sig
+   include STRUCTURAL_TYPE
+   include COMPARE where type 'a compare_t = 'a t
+end = struct
+   type 'a t = 'a Cmp.t
+   type 'a compare_t = 'a t
+
+   val compare = id
+
+   fun inj b a2b = b o Pair.map (Sq.mk a2b)
+   fun iso b = inj b o Iso.to
+
+   val op *` = Product.collate
+   val op +` = Sum.collate
+
+   val Y = Tie.function
+
+   local
+      val e = Fail "Compare.--> not supported"
+   in
+      fun _ --> _ = failing e
+   end
+
+   (* XXX It is also possible to implement exn so that compare provides
+    * a reasonable answer as long as at least one of the exception
+    * variants (involved in a comparison) has been registered.
+    *)
+   val exn : exn t ref = ref TypeUtil.failExnSq
+   fun regExn t (_, prj) =
+       Ref.modify (fn exn =>
+                      fn (l, r) =>
+                         case prj l & prj r of
+                            SOME l & SOME r => t (l, r)
+                          | SOME _ & NONE   => GREATER
+                          | NONE   & SOME _ => LESS
+                          | NONE   & NONE   => exn (l, r)) exn
+   val exn = fn ? => !exn ?
+
+   val array  = Array.collate
+   fun refc ? = inj ? !
+
+   val vector = Vector.collate
+
+   val list = List.collate
+
+   val unit   = fn ((), ()) => EQUAL
+   val bool   = Bool.compare
+   val char   = Char.compare
+   val int    = Int.compare
+   val real   = Real.compare
+   val string = String.compare
+   val word   = Word.compare
+
+   val largeInt  = LargeInt.compare
+   val largeReal = LargeReal.compare
+   val largeWord = LargeWord.compare
+
+   val word8  = Word8.compare
+   val word16 = Word16.compare
+   val word32 = Word32.compare
+   val word64 = Word64.compare
+end


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

[MLton-commit] r5021

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/cache.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/cache.sml	2007-01-12 12:24:45 UTC (rev 5020)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/cache.sml	2007-01-12 12:24:57 UTC (rev 5021)
@@ -0,0 +1,58 @@
+(* 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 cache implementation is basically an imperative separate chaining
+ * hashtable.  The keys are generated using a quick-and-dirty pseudo RNG.
+ *)
+structure Cache :> CACHE where type Key.t = MLRep.Long.Unsigned.word = struct
+   structure T = WordTable and A = WordTable.Action
+         and W = WordTable.Key
+         and Dbg = MkDbg (open DbgDefs val name = "Cache")
+
+   structure Key = struct
+      open MLRep.Long.Unsigned
+      type t = word
+   end
+
+   val () = Dbg.verify (W.wordSize <= Key.wordSize)
+
+   datatype 'a t = IN of {table : 'a T.t, seed : W.t ref}
+
+   exception NotFound
+
+   val (keyToWord, wordToKey) =
+       Iso.<--> (Iso.swap W.isoLarge, (Key.toLarge, Key.fromLarge))
+
+   fun new () = IN {table = T.new (), seed = ref 0w0}
+
+   fun size (IN {table, ...}) = T.size table
+
+   fun putWith (t as IN {table, seed}) keyToValue = let
+      val word = !seed before seed := Misc.ranqd1 (!seed)
+      val key = wordToKey word
+   in
+      case T.access
+              table word
+              (A.peek {some = fn () => A.return NONE,
+                       none = fn () => let
+                                 val value = keyToValue key
+                              in
+                                 A.insert value (SOME value)
+                              end}) of
+         NONE => putWith t keyToValue
+       | SOME value => (key, value)
+   end
+
+   fun put t = #1 o putWith t o const
+
+   fun access action (IN {table, ...}) key =
+       T.access table (keyToWord key) action
+
+   fun get ? = access (A.get {none = failing NotFound, some = A.return}) ?
+   fun use ? = access (A.get {none = failing NotFound, some = A.remove}) ?
+   fun rem ? = access (A.peek {none = failing NotFound, some = A.remove}) ?
+end


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

[MLton-commit] r5020

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/cache.sig
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/cache.sig	2007-01-12 12:24:34 UTC (rev 5019)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/cache.sig	2007-01-12 12:24:45 UTC (rev 5020)
@@ -0,0 +1,46 @@
+(* 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 an imperative polymorphic cache for storing values.  A cache
+ * differs from an ordinary imperative polymorphic map in that a cache
+ * automatically generates keys for values.
+ *)
+signature CACHE = sig
+   type 'a t
+
+   structure Key : sig
+      type t
+   end
+
+   exception NotFound
+   (** Raised by {get}, {use}, and {rem} in case a key is not found. *)
+
+   val new : Unit.t -> 'a t
+   (** Creates a new (empty) cache. *)
+
+   val size : 'a t -> Int.t
+   (** Returns the number of elements in the cache. *)
+
+   val putWith : 'a t -> (Key.t -> 'a) -> Key.t * 'a
+   (**
+    * Puts a key dependent value into cache and returns the key and
+    * value.  If the construction of the value raises an exception, the
+    * state of the cache does not change observably.
+    *)
+
+   val put : 'a t -> 'a -> Key.t
+   (** Puts a value into cache and return the key for the value. *)
+
+   val get : 'a t -> Key.t -> 'a
+   (** Returns the value corresponding to the key. *)
+
+   val use : 'a t -> Key.t -> 'a
+   (** Removes from the cache and returns the value corresponding to the key. *)
+
+   val rem : 'a t -> Key.t -> Unit.t
+   (** Removes from the cache the value corresponding to the key. *)
+end


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

[MLton-commit] r5019

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/bit-flags.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/bit-flags.sml	2007-01-12 12:24:12 UTC (rev 5018)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/bit-flags.sml	2007-01-12 12:24:34 UTC (rev 5019)
@@ -0,0 +1,21 @@
+(* 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 BIT_FLAGS signature of the Basis Library.
+ *)
+structure BitFlags : BIT_FLAGS = struct
+   open SysWord
+   type flags = t
+   val toWord = id
+   val fromWord = id
+   val (none, all) = bounds
+   val flags = foldl op orb none
+   val intersect = foldl op andb all
+   fun clear (f1, f2) = notb f1 andb f2
+   fun allSet (f1, f2) = f1 = f1 andb f2
+   fun anySet (f1, f2) = none <> f1 andb f2
+end


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

[MLton-commit] r5018

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/basic.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/basic.sml	2007-01-12 12:23:48 UTC (rev 5017)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/basic.sml	2007-01-12 12:24:12 UTC (rev 5018)
@@ -0,0 +1,28 @@
+(* 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.
+ *)
+
+(**
+ * Some basic combinators; the kind of combinators you would expect to see
+ * in the language standard library or prelude.
+ *)
+structure Basic :> sig
+   val repeat : 'a UnOp.t -> Int.t -> 'a UnOp.t
+   (** {repeat f n x} repeats {f} {n}-times starting with {x}. *)
+
+   val += : (Int.t Ref.t * Int.t) Effect.t
+   (** {c += n} is equivalent to {c := !c + n}. *)
+
+   val -= : (Int.t Ref.t * Int.t) Effect.t
+   (** {c -= n} is equivalent to {c := !c - n}. *)
+end = struct
+   fun repeat f n x = if n = 0 then x else repeat f (n-1) (f x)
+
+   fun c += n = c := !c + n
+   fun c -= n = c := !c - n
+end
+
+(* Expose all of the basic combinators at the top-level for convenience. *)
+open Basic


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

[MLton-commit] r5017

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/arbitrary.sml	2007-01-12 12:22:31 UTC (rev 5016)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/arbitrary.sml	2007-01-12 12:23:48 UTC (rev 5017)
@@ -0,0 +1,176 @@
+(* 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 type-indexed function for generating random values of any type.  The
+ * design is inspired by the QuickCheck library by Koen Claessen and John
+ * Hughes:
+ *
+ *   http://www.cs.chalmers.se/~rjmh/QuickCheck/ .
+ *)
+
+signature ARBITRARY = sig
+   type 'a arbitrary_t
+
+   val arbitrary : 'a arbitrary_t -> 'a RanQD1Gen.gen
+   (** Extracts the random value generator. *)
+
+   val withGen : 'a RanQD1Gen.gen -> 'a arbitrary_t UnOp.t
+   (** Functionally updates the random value generator. *)
+end
+
+functor LiftArbitrary
+           (include ARBITRARY
+            type 'a t
+            val lift : ('a arbitrary_t, 'a t) Lift.t Thunk.t) : ARBITRARY =
+struct
+   type 'a arbitrary_t = 'a t
+   val arbitrary = fn ? => Lift.get lift arbitrary ?
+   val withGen = fn g => Lift.update lift (withGen g)
+end
+
+structure Arbitrary :> sig
+   include STRUCTURAL_TYPE
+   include ARBITRARY where type 'a arbitrary_t = 'a t
+end = struct
+   structure G = RanQD1Gen and I = Int and R = Real and W = Word
+         and Typ = TypeInfo
+
+   datatype 'a t =
+      IN of {gen : 'a G.gen,
+             cog : int -> 'a -> G.t UnOp.t,
+             typ : 'a Typ.t}
+   type 'a arbitrary_t = 'a t
+
+   val op >>= = G.>>=
+
+   fun arbitrary (IN {gen, ...}) = gen
+   fun withGen gen (IN {cog, typ, ...}) =
+       IN {gen = gen, cog = cog, typ = typ}
+
+   fun iso (IN {gen, cog, typ, ...}) (iso as (a2b, b2a)) =
+       IN {gen = G.prj gen b2a,
+           cog = fn n => cog n o a2b,
+           typ = Typ.iso typ iso}
+
+   val unit = IN {gen = const (const ()),
+                  cog = const (const (G.split 0w0)),
+                  typ = Typ.unit}
+   val bool = IN {gen = G.bool,
+                  cog = const (G.split o (fn false => 0w1 | true => 0w2)),
+                  typ = Typ.bool}
+   val int  = IN {gen = G.prj (G.lift G.value)
+                              (fn w => (* XXX result may not fit an Int.int *)
+                                  W.toIntX (w - G.maxValue div 0w2)),
+                  cog = const (G.split o W.fromInt),
+                  typ = Typ.int}
+   val word = IN {gen = G.lift G.value,
+                  cog = const G.split,
+                  typ = Typ.word}
+   val real = IN {gen = G.sized ((fn r => G.realInRange (~r, r)) o real),
+                  cog = const (G.split o W.fromLarge o
+                               PackWord32Little.subVec /> 0 o
+                               PackReal32Little.toBytes o
+                               Real32.fromLarge IEEEReal.TO_NEAREST o
+                               R.toLarge),
+                  typ = Typ.real}
+
+   fun Y ? = let open Tie in iso (function *` function *` Typ.Y) end
+                (fn IN {gen = a, cog = b, typ = c} => a & b & c,
+                 fn a & b & c => IN {gen = a, cog = b, typ = c}) ?
+
+   fun (IN {gen = aGen, cog = aCog, typ = aTyp, ...}) *`
+       (IN {gen = bGen, cog = bCog, typ = bTyp, ...}) =
+       IN {gen = aGen >>= (fn a => bGen >>= (fn b => G.return (a & b))),
+           cog = fn n => fn a & b => aCog n a o G.split 0w643 o bCog n b,
+           typ = Typ.*` (aTyp, bTyp)}
+
+   (* XXX Generation of recursive datatypes could probably be improved.
+    *
+    * We are somewhat more ambitious here than what is done in the
+    * original QuickCheck library.  As noted in the QuickCheck paper,
+    * naive generation of recursive datatypes may not terminate (for one
+    * thing).  The simplistic heuristic used below is to reduce the size
+    * whenever the recursive branch is chosen.  This guarantees
+    * termination in many cases, but not all.  However, it is probably
+    * possible to devise a much smarter algorithm.  Namely, one could
+    * compute a "probability of recursion" of some kind and then use that
+    * while choosing which branch to generate.  Consider the following
+    * datatype:
+    *
+    *>  datatype foo = ALWAYS of foo * foo | SOMETIMES of foo option
+    *
+    * Intuitively the "recursion probabilities" of the ALWAYS and
+    * SOMETIMES branches are different.  It seems plausible that this
+    * could be exploited to guarantee termination.
+    *
+    * Actually, it would probably be more fruitful to use an estimate of
+    * the expected "size" of the complete generated data structure to
+    * guide the generation process.
+    *)
+
+   fun (IN {gen = aGen, cog = aCog, typ = aTyp, ...}) +`
+       (IN {gen = bGen, cog = bCog, typ = bTyp, ...}) = let
+      val aGen = G.prj aGen INL
+      val bGen = G.prj bGen INR
+      val halve = G.resize (op div /> 2)
+      val aGenHalf = G.frequency [(2, halve aGen), (1, bGen)]
+      val bGenHalf = G.frequency [(1, aGen), (2, halve bGen)]
+   in
+      IN {gen = case Typ.hasRecData aTyp & Typ.hasRecData bTyp of
+                   true  & false => G.sized (fn 0 => bGen | _ => aGenHalf)
+                 | false & true  => G.sized (fn 0 => aGen | _ => bGenHalf)
+                 | _     & _     =>
+                   G.bool >>= (fn false => aGen | true  => bGen),
+          cog = fn n => fn INL a => G.split 0w423 o aCog n a
+                         | INR b => G.split 0w324 o bCog n b,
+          typ = Typ.+` (aTyp, bTyp)}
+   end
+
+   fun (IN {gen = aGen, cog = aCog, typ = aTyp, ...}) -->
+       (IN {gen = bGen, cog = bCog, typ = bTyp, ...}) =
+       IN {gen = G.promote (fn a => fn n => bGen n o aCog n a),
+           cog = fn n => fn a2b => fn r =>
+                    bCog n (a2b (aGen n (G.split 0w3 r))) (G.split 0w4 r),
+           typ = Typ.--> (aTyp, bTyp)}
+
+   val exn = let val e = Fail "Arbitrary.exn not supported yet"
+             in IN {gen = failing e, cog = failing e, typ = Typ.exn}
+             end
+   fun regExn _ _ = ()
+
+   fun list (IN {gen = xGen, cog = xCog, typ = xTyp, ...}) = let
+      val xsGen = G.sized (0 <\ G.intInRange) >>= G.list xGen
+      fun xsCog _ []      t = G.split 0w5 t
+        | xsCog n (x::xs) t = xsCog n xs (xCog n x t)
+   in
+      IN {gen = xsGen, cog = xsCog, typ = Typ.list xTyp}
+   end
+
+   fun array a = iso (list a) Array.isoList (* XXX not quite right with Typ *)
+   fun refc a = iso a (!, ref)              (* XXX not quite right with Typ *)
+
+   fun vector a = iso (list a) Vector.isoList
+
+   val char = IN {gen = G.prj (G.intInRange (0, Char.maxOrd)) chr,
+                  cog = const (G.split o W.fromInt o ord),
+                  typ = Typ.char}
+
+   val string = iso (list char) String.isoList
+
+   val largeInt  = iso int  (Iso.swap I.isoLarge)
+   val largeWord = iso word (Iso.swap W.isoLarge)
+   val largeReal = iso real (Iso.swap (R.isoLarge IEEEReal.TO_NEAREST))
+
+   local
+      fun mk large = iso word (Iso.<--> (Iso.swap W.isoLarge, large))
+   in
+      val word8  = mk Word8.isoLarge
+      val word16 = mk Word16.isoLarge
+      val word32 = mk Word32.isoLarge
+      val word64 = mk Word64.isoLarge
+   end
+end


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

[MLton-commit] r5016

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

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

A   mltonlib/trunk/com/ssh/misc-util/unstable/

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

[MLton-commit] r5015

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

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

A   mltonlib/trunk/com/ssh/misc-util/

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

[MLton-commit] r5014

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

Implemented a more precise algorithm to eliminate redundant parentheses
from the show-basis output.

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

U   mlton/trunk/mlton/ast/prim-tycons.fun
U   mlton/trunk/mlton/ast/prim-tycons.sig
U   mlton/trunk/mlton/ast/sources.cm
U   mlton/trunk/mlton/ast/sources.mlb
U   mlton/trunk/mlton/atoms/hash-type.fun
U   mlton/trunk/mlton/elaborate/elaborate-env.fun
U   mlton/trunk/mlton/elaborate/interface.fun
U   mlton/trunk/mlton/elaborate/interface.sig
U   mlton/trunk/mlton/elaborate/type-env.fun
U   mlton/trunk/mlton/elaborate/type-env.sig
U   mlton/trunk/mlton/ssa/ssa-tree2.fun

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

Modified: mlton/trunk/mlton/ast/prim-tycons.fun
===================================================================
--- mlton/trunk/mlton/ast/prim-tycons.fun	2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/ast/prim-tycons.fun	2007-01-07 16:33:41 UTC (rev 5014)
@@ -11,6 +11,18 @@
 
 open S
 
+structure BindingStrength =
+   struct
+      datatype t =
+         Arrow
+       | Tuple
+       | Unit
+
+      val arrow = Arrow
+      val tuple = Tuple
+      val unit = Unit
+   end
+
 datatype z = datatype RealSize.t
 
 type tycon = t
@@ -165,7 +177,8 @@
 val deIntX = fn c => if equals (c, intInf) then NONE else SOME (deIntX c)
 
 fun layoutApp (c: t,
-               args: (Layout.t * {isChar: bool, needsParen: bool}) vector) =
+               args: (Layout.t * ({isChar: bool}
+                                  * BindingStrength.t)) vector) =
    let
       local
          open Layout
@@ -174,37 +187,52 @@
          val seq = seq
          val str = str
       end
-      fun maybe (l, {isChar = _, needsParen}) =
-         if needsParen
-            then Layout.paren l
-         else l
+      datatype z = datatype BindingStrength.t
+      datatype binding_context =
+         ArrowLhs
+       | ArrowRhs
+       | TupleElem
+       | Tyseq1
+       | TyseqN
+      fun maybe bindingContext (l, ({isChar = _}, bindingStrength)) =
+         case (bindingStrength, bindingContext) of
+            (Unit, _) => l
+          | (Tuple, ArrowLhs) => l
+          | (Tuple, ArrowRhs) => l
+          | (Tuple, TyseqN) => l
+          | (Arrow, ArrowRhs) => l
+          | (Arrow, TyseqN) =>  l
+          | _ => Layout.paren l
       fun normal () =
          let
             val ({isChar}, lay) =
                case Vector.length args of
                   0 => ({isChar = equals (c, defaultChar ())}, layout c)
                 | 1 => ({isChar = false},
-                        seq [maybe (Vector.sub (args, 0)), str " ", layout c])
+                        seq [maybe Tyseq1 (Vector.sub (args, 0)),
+                             str " ", layout c])
                 | _ => ({isChar = false},
-                        seq [Layout.tuple (Vector.toListMap (args, maybe)),
+                        seq [Layout.tuple
+                             (Vector.toListMap (args, maybe TyseqN)),
                              str " ", layout c])
          in
-            (lay, {isChar = isChar, needsParen = false})
+            (lay, ({isChar = isChar}, Unit))
          end
    in
       if equals (c, arrow)
-         then (mayAlign [maybe (Vector.sub (args, 0)),
-                         seq [str "-> ", maybe (Vector.sub (args, 1))]],
-               {isChar = false, needsParen = true})
+         then (mayAlign [maybe ArrowLhs (Vector.sub (args, 0)),
+                         seq [str "-> ",
+                              maybe ArrowRhs (Vector.sub (args, 1))]],
+               ({isChar = false}, Arrow))
       else if equals (c, tuple)
          then if 0 = Vector.length args
-                 then (str "unit", {isChar = false, needsParen = false})
+                 then (str "unit", ({isChar = false}, Unit))
               else (mayAlign (Layout.separateLeft
-                              (Vector.toListMap (args, maybe), "* ")),
-                    {isChar = false, needsParen = true})
+                              (Vector.toListMap (args, maybe TupleElem), "* ")),
+                    ({isChar = false}, Tuple))
       else if equals (c, vector)
-         then if #isChar (#2 (Vector.sub (args, 0)))
-                 then (str "string", {isChar = false, needsParen = false})
+         then if #isChar (#1 (#2 (Vector.sub (args, 0))))
+                 then (str "string", ({isChar = false}, Unit))
               else normal ()
       else normal ()
    end

Modified: mlton/trunk/mlton/ast/prim-tycons.sig
===================================================================
--- mlton/trunk/mlton/ast/prim-tycons.sig	2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/ast/prim-tycons.sig	2007-01-07 16:33:41 UTC (rev 5014)
@@ -27,10 +27,21 @@
       val layout: t -> Layout.t
    end
 
+signature BINDING_STRENGTH =
+   sig
+      type t
+
+      val arrow: t
+      val tuple: t
+      val unit: t
+   end
+
 signature PRIM_TYCONS =
    sig
       include PRIM_TYCONS_SUBSTRUCTS
 
+      structure BindingStrength: BINDING_STRENGTH
+
       type tycon
 
       val array: tycon
@@ -57,8 +68,8 @@
       val isRealX: tycon -> bool
       val isWordX: tycon -> bool
       val layoutApp:
-         tycon * (Layout.t * {isChar: bool, needsParen: bool}) vector
-         -> Layout.t * {isChar: bool, needsParen: bool}
+         tycon * (Layout.t * ({isChar: bool} * BindingStrength.t)) vector
+         -> Layout.t * ({isChar: bool} * BindingStrength.t)
       val list: tycon
       val pointer: tycon
       val prims: {admitsEquality: AdmitsEquality.t,

Modified: mlton/trunk/mlton/ast/sources.cm
===================================================================
--- mlton/trunk/mlton/ast/sources.cm	2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/ast/sources.cm	2007-01-07 16:33:41 UTC (rev 5014)
@@ -10,6 +10,7 @@
 
 signature ADMITS_EQUALITY
 signature AST
+signature BINDING_STRENGTH
 signature CHAR_SIZE
 signature FIELD
 signature INT_SIZE

Modified: mlton/trunk/mlton/ast/sources.mlb
===================================================================
--- mlton/trunk/mlton/ast/sources.mlb	2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/ast/sources.mlb	2007-01-07 16:33:41 UTC (rev 5014)
@@ -56,6 +56,7 @@
 in
    signature ADMITS_EQUALITY
    signature AST
+   signature BINDING_STRENGTH
    signature CHAR_SIZE
    signature FIELD
    signature INT_SIZE

Modified: mlton/trunk/mlton/atoms/hash-type.fun
===================================================================
--- mlton/trunk/mlton/atoms/hash-type.fun	2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/atoms/hash-type.fun	2007-01-07 16:33:41 UTC (rev 5014)
@@ -84,8 +84,9 @@
       fun layout (ty: t): Layout.t =
          #1 (hom {con = Tycon.layoutApp,
                   ty = ty,
-                  var = fn a => (Tyvar.layout a, {isChar = false,
-                                                  needsParen = false})})
+                  var = fn a => (Tyvar.layout a,
+                                 ({isChar = false},
+                                  Tycon.BindingStrength.unit))})
 
       val toString = Layout.toString o layout
 

Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun	2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun	2007-01-07 16:33:41 UTC (rev 5014)
@@ -84,7 +84,7 @@
       fun explainDoesNotAdmitEquality (t: t): Layout.t =
          let
             open Layout
-            val wild = (str "_", {isChar = false, needsParen = false})
+            val wild = (str "_", ({isChar = false}, Tycon.BindingStrength.unit))
             fun con (c, ts) =
                let
                   fun keep {showInside: bool} =
@@ -101,7 +101,8 @@
                   case ! (Tycon.admitsEquality c) of
                      Always => NONE
                    | Never => SOME (bracket (#1 (keep {showInside = false})),
-                                    {isChar = false, needsParen = false})
+                                    ({isChar = false},
+                                     Tycon.BindingStrength.unit))
                    | Sometimes =>
                         if Vector.exists (ts, Option.isSome)
                            then SOME (keep {showInside = true})
@@ -134,7 +135,7 @@
                                        seq [Field.layout f, str ": ", z] :: ac),
                                 ",")),
                               str ending],
-                             {isChar = false, needsParen = false})
+                             ({isChar = false}, Tycon.BindingStrength.unit))
                          end
                     | SOME v =>
                          Tycon.layoutApp

Modified: mlton/trunk/mlton/elaborate/interface.fun
===================================================================
--- mlton/trunk/mlton/elaborate/interface.fun	2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/elaborate/interface.fun	2007-01-07 16:33:41 UTC (rev 5014)
@@ -144,7 +144,8 @@
                     ("id", TyconId.layout id)]
          end
 
-      fun layoutApp (t, _) = (layout t, {isChar = false, needsParen = false})
+      fun layoutApp (t, _) =
+          (layout t, ({isChar = false}, Etycon.BindingStrength.unit))
 
       val copies: copy list ref = ref []
 
@@ -247,7 +248,7 @@
 
       local
          open Layout
-         fun simple l = (l, {isChar = false, needsParen = false})
+         fun simple l = (l, ({isChar = false}, Etycon.BindingStrength.unit))
          fun loop t =
             case t of
                Con (c, ts) => Tycon.layoutApp (c, Vector.map (ts, loop))

Modified: mlton/trunk/mlton/elaborate/interface.sig
===================================================================
--- mlton/trunk/mlton/elaborate/interface.sig	2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/elaborate/interface.sig	2007-01-07 16:33:41 UTC (rev 5014)
@@ -15,6 +15,8 @@
             structure Kind: TYCON_KIND
             structure Tycon:
                sig
+                  structure BindingStrength: BINDING_STRENGTH
+
                   type t
 
                   val admitsEquality: t -> AdmitsEquality.t ref
@@ -23,8 +25,9 @@
                   val exn: t
                   val layout: t -> Layout.t
                   val layoutApp:
-                     t * (Layout.t * {isChar: bool, needsParen: bool}) vector
-                     -> Layout.t * {isChar: bool, needsParen: bool}
+                     t * (Layout.t
+                          * ({isChar: bool} * BindingStrength.t)) vector
+                     -> Layout.t * ({isChar: bool} * BindingStrength.t)
                   val tuple: t
                end
 

Modified: mlton/trunk/mlton/elaborate/type-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.fun	2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/elaborate/type-env.fun	2007-01-07 16:33:41 UTC (rev 5014)
@@ -84,10 +84,10 @@
 
 structure Lay =
    struct
-      type t = Layout.t * {isChar: bool, needsParen: bool}
+      type t = Layout.t * ({isChar: bool} * Tycon.BindingStrength.t)
 
       fun simple (l: Layout.t): t =
-         (l, {isChar = false, needsParen = false})
+         (l, ({isChar = false}, Tycon.BindingStrength.unit))
    end
 
 structure UnifyResult =
@@ -370,11 +370,11 @@
    Trace.trace ("TypeEnv.tyvarTime", Tyvar.layout, Ref.layout Time.layout) tyvarTime
 
 local
-   type z = Layout.t * {isChar: bool, needsParen: bool}
+   type z = Layout.t * ({isChar: bool} * Tycon.BindingStrength.t)
    open Layout
 in
    fun simple (l: Layout.t): z =
-      (l, {isChar = false, needsParen = false})
+      (l, ({isChar = false}, Tycon.BindingStrength.unit))
    val dontCare: z = simple (str "_")
    fun bracket l = seq [str "[", l, str "]"]
    fun layoutRecord (ds: (Field.t * bool * z) list, flexible: bool) =
@@ -600,8 +600,9 @@
          end
 
       fun makeLayoutPretty (): {destroy: unit -> unit,
-                                lay: t -> Layout.t * {isChar: bool,
-                                                      needsParen: bool}} =
+                                lay: t -> Layout.t
+                                          * ({isChar: bool}
+                                          * Tycon.BindingStrength.t)} =
          let
             val str = Layout.str
             fun con (_, c, ts) = Tycon.layoutApp (c, ts)
@@ -946,10 +947,9 @@
                          (NotUnifiable (l, l'),
                           Unknown (Unknown.new {canGeneralize = true}))
                       val bracket =
-                         fn (l, {isChar, needsParen = _}) =>
+                         fn (l, ({isChar}, _)) =>
                          (bracket l,
-                          {isChar = isChar,
-                           needsParen = false})
+                          ({isChar = isChar}, Tycon.BindingStrength.unit))
                       fun notUnifiableBracket (l, l') =
                          notUnifiable (bracket l, bracket l')
                       fun flexToRecord (fields, spine) =

Modified: mlton/trunk/mlton/elaborate/type-env.sig
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.sig	2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/elaborate/type-env.sig	2007-01-07 16:33:41 UTC (rev 5014)
@@ -53,8 +53,8 @@
                                                   hom: t -> 'a}
             val makeLayoutPretty:
                unit -> {destroy: unit -> unit,
-                        lay: t -> Layout.t * {isChar: bool,
-                                              needsParen: bool}}
+                        lay: t -> Layout.t * ({isChar: bool}
+                                              * Tycon.BindingStrength.t)}
             (* minTime (t, time) makes every component of t occur no later than
              * time.  This will display a type error message if time is before
              * the definition time of some component of t.

Modified: mlton/trunk/mlton/ssa/ssa-tree2.fun
===================================================================
--- mlton/trunk/mlton/ssa/ssa-tree2.fun	2006-12-31 02:43:51 UTC (rev 5013)
+++ mlton/trunk/mlton/ssa/ssa-tree2.fun	2007-01-07 16:33:41 UTC (rev 5014)
@@ -59,7 +59,8 @@
                                        then seq [layout elt, str " ref"]
                                     else layout elt
                               in
-                                 (lay, {isChar = false, needsParen = false})
+                                 (lay, ({isChar = false},
+                                        Tycon.BindingStrength.unit))
                               end))))
       end