mlton-commit — [MLton-commit] Code commits

[MLton-commit] r5063

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/type.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/type.sml	2007-01-12 12:39:02 UTC (rev 5062)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/type.sml	2007-01-12 12:39:26 UTC (rev 5063)
@@ -0,0 +1,201 @@
+(* 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 {TYPE} signature done by combining some of the
+ * utility implementations of the {TYPE} signature.
+ *)
+
+structure Type :>
+   sig
+      include TYPE
+
+      (** == STRUCTURAL TYPE-INDEXED VALUES == *)
+
+      include ARBITRARY
+      include COMPARE
+      include EQ
+
+      (** == NOMINAL TYPE-INDEXED VALUES == *)
+
+      include SHOW
+
+      (* 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))))
+
+      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
+
+      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)
+
+      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
+
+      (* 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 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
+
+      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)
+
+      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
+
+      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
+   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


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

[MLton-commit] r5062

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/type.sig
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/type.sig	2007-01-12 12:38:34 UTC (rev 5061)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/type.sig	2007-01-12 12:39:02 UTC (rev 5062)
@@ -0,0 +1,139 @@
+(* 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 generic signature for nominal type-indexed values.
+ *
+ * This signature differs from the {STRUCTURAL_TYPE} signature in that an
+ * implementations of this signature can make use of nominal data (names
+ * of record labels and datatype constructors) as well as can distinguish
+ * between complete and incomplete sums, records and tuples.  The
+ * additional data makes it possible to, for example, convert an arbitrary
+ * SML value to a textual presentation that matches the syntax of SML.
+ * Indeed, a type-index specified using the combinators of this signature
+ * is essentially a transliteration of the SML type.
+ *)
+
+signature TYPE = sig
+   type 'a t       (** Type of complete type-indices. *)
+   type 'a s       (** Type of incomplete sum type-indices. *)
+   type ('a, 'k) p (** Type of incomplete product type-indices. *)
+
+   (** == SUPPORT FOR USER-DEFINED TYPES == *)
+
+   val iso : 'b t -> ('a, 'b) Iso.t -> 'a t
+   (**
+    * Given a type-index {'b t} and an isomorphism between {'a} and
+    * {'b}, returns a type-index {'a t}.  The purpose of {iso} is to
+    * support user-defined types.
+    *)
+
+   val isoProduct : ('b, 'k) p -> ('a, 'b) Iso.t -> ('a, 'k) p
+   (**
+    * Given a type-index {('b, 'k) p} and an isomorphism between {'a}
+    * and {'b}, returns a type-index {('a, 'k) p}.
+    *)
+
+   val isoSum : 'b s -> ('a, 'b) Iso.t -> 'a s
+   (**
+    * Given a type-index {'b s} and an isomorphism between {'a} and
+    * {'b}, returns a type-index {'a s}.
+    *)
+
+   (** == SUPPORT FOR TUPLES AND RECORDS == *)
+
+   val *` : ('a, 'k) p * ('b, 'k) p -> (('a, 'b) Product.t, 'k) p
+   (**
+    * Given type-indices for fields of type {'a} and {'b} of the same
+    * kind {'k} (tuple or record), returns a type-index for the product
+    * {('a, 'b) product}.
+    *)
+
+   val T : 'a t -> ('a, TypeSupport.tuple) p
+   (** Specifies a field of a tuple. *)
+
+   val R : TypeSupport.label -> 'a t -> ('a, TypeSupport.record) p
+   (** Specifies a field of a record. *)
+
+   val tuple  : ('a, TypeSupport.tuple) p -> 'a t
+   (** Specifies a tuple. *)
+
+   val record : ('a, TypeSupport.record) p -> 'a t
+   (** Specifies a record. *)
+
+   (** == SUPPORT FOR DATATYPES == *)
+
+   val +` : 'a s * 'b s -> (('a, 'b) Sum.t) s
+   (**
+    * Given type-indices for variants of type {'a} and {'b}, returns a
+    * type-index for the sum {('a, 'b) sum}.
+    *)
+
+   val C0 : TypeSupport.constructor -> Unit.t s
+   (** Specifies a nullary constructor. *)
+
+   val C1 : TypeSupport.constructor -> 'a t -> 'a s
+   (** Specifies a unary constructor. *)
+
+   val data : 'a s -> 'a t
+   (** Specifies a complete datatype. *)
+
+   val unit : Unit.t t
+   (**
+    * Type-index for the {unit} type.  Using {unit} and {+} one can
+    * actually encode {bool}, {word}, and much more.
+    *)
+
+   val Y : 'a t Tie.t
+   (** Fixpoint tier to support recursive datatypes. *)
+
+   (** == SUPPORT FOR FUNCTIONS == *)
+
+   val --> : 'a t * 'b t -> ('a -> 'b) t
+
+   (** == SUPPORT FOR EXCEPTIONS == *)
+
+   val exn : Exn.t t
+   (** Universal type-index for exceptions. *)
+
+   val regExn : 'a s -> ('a, Exn.t) Emb.t Effect.t
+   (** Registers a handler for exceptions. *)
+
+   (** == SUPPORT FOR TYPES WITH IDENTITY == *)
+
+   val array : 'a t -> 'a Array.t t
+   val refc  : 'a t -> 'a Ref.t   t
+
+   (** == SUPPORT FOR FUNCTIONAL AGGREGATE TYPES == *)
+
+   val vector : 'a t -> 'a Vector.t t
+
+   (** == SUPPORT FOR ARBITRARY INTEGERS, WORDS, AND REALS == *)
+
+   val largeInt  : LargeInt.t  t
+   val largeReal : LargeReal.t t
+   val largeWord : LargeWord.t t
+
+   (** == SUPPORT FOR BINARY DATA == *)
+
+   val word8  : Word8.t  t
+   val word16 : Word16.t t
+   val word32 : Word32.t t
+   val word64 : Word64.t t
+
+   (** == SUPPORT FOR SOME BUILT-IN TYPE CONSTRUCTORS == *)
+
+   val list : 'a t -> 'a List.t t
+
+   (** == SUPPORT FOR SOME BUILT-IN BASE TYPES == *)
+
+   val bool   : Bool.t   t
+   val char   : Char.t   t
+   val int    : Int.t    t
+   val real   : Real.t   t
+   val string : String.t t
+   val word   : Word.t   t
+end


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

[MLton-commit] r5061

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/type-pair.fun
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/type-pair.fun	2007-01-12 12:37:50 UTC (rev 5060)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/type-pair.fun	2007-01-12 12:38:34 UTC (rev 5061)
@@ -0,0 +1,72 @@
+(* 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 combining implementations of the {TYPE} signature.
+ *)
+
+functor TypePair
+           (structure A : TYPE
+            structure B : TYPE) : TYPE = struct
+   type 'a t = 'a A.t * 'a B.t
+   type 'a s = 'a A.s * 'a B.s
+   type ('a, 'b) p = ('a, 'b) A.p * ('a, 'b) B.p
+
+   local
+      fun mk aIso bIso (a, b) i = (aIso a i, bIso b i)
+   in
+      fun iso        ? = mk A.iso        B.iso        ?
+      fun isoProduct ? = mk A.isoProduct B.isoProduct ?
+      fun isoSum     ? = mk A.isoSum     B.isoSum     ?
+   end
+
+   local
+      fun mk t = Pair.map t o Pair.swizzle
+   in
+      fun op *`  ? = mk (A.*`,  B.*`)  ?
+      fun op +`  ? = mk (A.+`,  B.+`)  ?
+      fun op --> ? = mk (A.-->, B.-->) ?
+   end
+
+   fun T ? = Pair.map (A.T, B.T) ?
+   fun R ? = Pair.map (A.R ?, B.R ?)
+
+   fun C0 ? = (A.C0 ?, B.C0 ?)
+   fun C1 ? = Pair.map (A.C1 ?, B.C1 ?)
+
+   fun Y ? = Tie.tuple2 (A.Y, B.Y) ?
+
+   val exn = (A.exn, B.exn)
+   fun regExn (a, b) emb = (A.regExn a emb ; B.regExn b emb)
+
+   fun tuple  ? = Pair.map (A.tuple,  B.tuple)  ?
+   fun record ? = Pair.map (A.record, B.record) ?
+   fun data   ? = Pair.map (A.data,   B.data)   ?
+
+   fun array ? = Pair.map (A.array, B.array) ?
+   fun refc  ? = Pair.map (A.refc,  B.refc)  ?
+
+   fun vector ? = Pair.map (A.vector, B.vector) ?
+
+   fun list ? = Pair.map (A.list, B.list) ?
+
+   val bool   = (A.bool,   B.bool)
+   val char   = (A.char,   B.char)
+   val int    = (A.int,    B.int)
+   val real   = (A.real,   B.real)
+   val string = (A.string, B.string)
+   val unit   = (A.unit,   B.unit)
+   val word   = (A.word,   B.word)
+
+   val largeInt  = (A.largeInt,  B.largeInt)
+   val largeReal = (A.largeReal, B.largeReal)
+   val largeWord = (A.largeWord, B.largeWord)
+
+   val word8  = (A.word8,  B.word8)
+   val word16 = (A.word16, B.word16)
+   val word32 = (A.word32, B.word32)
+   val word64 = (A.word64, B.word64)
+end


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

[MLton-commit] r5060

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/type-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/type-info.sml	2007-01-12 12:37:27 UTC (rev 5059)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/type-info.sml	2007-01-12 12:37:50 UTC (rev 5060)
@@ -0,0 +1,134 @@
+(* 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 function for tracking a number of
+ * important type properties.
+ *
+ * These type properties can be useful for both optimizations and for
+ * ensuring correctness.  As an optimization one could, for example,
+ * determine whether one needs to handle cyclic values (which can be
+ * costly) or not.  As a correctness issue, one can avoid generating
+ * infinite data structures or avoid performing non-terminating operations
+ * on infinite data structures.
+ *
+ * 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 TYPE_INFO = sig
+   type 'a type_info_t
+
+   val hasExn : 'a type_info_t UnPr.t
+   (** Returns true iff the type {'a} contains the type {exn}. *)
+
+   val hasRecData : 'a type_info_t UnPr.t
+   (**
+    * Returns true iff the type {'a} contains recursive references to
+    * datatypes.
+    *)
+
+   val isRefOrArray : 'a type_info_t UnPr.t
+   (**
+    * Returns true iff the type {'a} is of the form {'b array} or of
+    * the form {'b ref}.
+    *)
+
+   val canBeCyclic : 'a type_info_t UnPr.t
+   (**
+    * Returns true iff {'a} is of the form {'b ref} or {'b array} and
+    * it can not be ruled out that values of the type can form cycles.
+    *
+    * Note: Functions are not considered to form cycles.
+    *)
+end
+
+functor LiftTypeInfo
+           (include TYPE_INFO
+            type 'a t
+            val lift : ('a type_info_t, 'a t) Lift.t Thunk.t) : TYPE_INFO = struct
+   type 'a type_info_t = 'a t
+   val hasExn       = fn ? => Lift.get lift hasExn       ?
+   val hasRecData   = fn ? => Lift.get lift hasRecData   ?
+   val isRefOrArray = fn ? => Lift.get lift isRefOrArray ?
+   val canBeCyclic  = fn ? => Lift.get lift canBeCyclic  ?
+end
+
+structure TypeInfo :> sig
+   include STRUCTURAL_TYPE
+   include TYPE_INFO where type 'a type_info_t = 'a t
+end = struct
+   datatype u = IN of {exn : Bool.t, pure : Bool.t, recs : Int.t List.t}
+   fun out (IN t) = t
+   type 'a t = u
+   type 'a type_info_t = 'a t
+
+   val hasExn = #exn o out
+   val hasRecData = not o null o #recs o out
+   val isRefOrArray = not o #pure o out
+   val canBeCyclic = isRefOrArray andAlso (hasExn orElse hasRecData)
+
+   val base = IN {exn = false, pure = true, recs = []}
+   fun pure (IN {exn, recs, ...}) = IN {exn = exn, pure = true, recs = recs}
+   fun impure (IN {exn, recs, ...}) =
+       IN {exn = exn, pure = false, recs = recs}
+   fun combine (IN {exn = hl, recs = rl, ...},
+                IN {exn = hr, recs = rr, ...}) =
+       IN {exn = hl orelse hr, pure = true,
+           recs = SortedList.merge#1 Int.compare (rl, rr)}
+
+   val iso = const
+
+   val op *` = combine
+   val op +` = combine
+
+   val unit = base
+
+   local
+      val id = ref 0
+   in
+      fun Y ? =
+          Tie.pure
+             (fn () => let
+                 val this = !id before id += 1
+              in
+                 (IN {exn = false, pure = true, recs = [this]},
+                  fn IN {exn, pure, recs} =>
+                     IN {exn = exn, pure = pure,
+                         recs = SortedList.remove
+                                   #1 Int.compare this recs})
+              end) ?
+   end
+
+   fun _ --> _ = base
+
+   val exn = IN {exn = true, pure = true, recs = []}
+   fun regExn _ _ = ()
+
+   val array = impure
+   val refc  = impure
+
+   val vector = pure
+
+   val largeInt  = base
+   val largeReal = base
+   val largeWord = base
+
+   val list = pure
+
+   val bool   = base
+   val char   = base
+   val int    = base
+   val real   = base
+   val string = base
+   val word   = base
+
+   val word8  = base
+   val word16 = base
+   val word32 = base
+   val word64 = base
+end


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

[MLton-commit] r5059

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/test.mlb
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/test.mlb	2007-01-12 12:37:06 UTC (rev 5058)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/test.mlb	2007-01-12 12:37:27 UTC (rev 5059)
@@ -0,0 +1,24 @@
+(* 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 building tests.
+ *)
+
+local
+   unit-test.mlb (* This should always be the first. *)
+
+   $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+   lib.mlb
+
+   misc-test.sml
+   prettier-test.sml
+   promise-test.sml
+   qc-test-example.sml
+   show-test.sml
+   sorted-list-test.sml
+in
+end


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

[MLton-commit] r5058

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

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

A   mltonlib/trunk/com/ssh/misc-util/unstable/structural-type-to-type.fun

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/structural-type-to-type.fun
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/structural-type-to-type.fun	2007-01-12 12:36:24 UTC (rev 5057)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/structural-type-to-type.fun	2007-01-12 12:37:06 UTC (rev 5058)
@@ -0,0 +1,35 @@
+(* 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 lifting a structural type-index to a type-index.
+ *)
+
+functor StructuralTypeToType
+           (S : STRUCTURAL_TYPE) :>
+TYPE
+   where type 'a t = 'a S.t
+   where type 'a s = 'a S.t
+   where type ('a, 'k) p = 'a S.t = struct
+   open S
+
+   type 'a s = 'a t
+   type ('a, 'k) p = 'a t
+
+   val isoProduct = iso
+   val isoSum     = iso
+
+   val T = id
+   fun R _ = id
+
+   val tuple = id
+   val record = id
+
+   fun C0 _ = unit
+   fun C1 _ = id
+
+   val data = id
+end


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

[MLton-commit] r5057

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/structural-type.sig
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/structural-type.sig	2007-01-12 12:36:07 UTC (rev 5056)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/structural-type.sig	2007-01-12 12:36:24 UTC (rev 5057)
@@ -0,0 +1,114 @@
+(* 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 generic signature for "structural" type-indexed values.
+ *
+ * The intended usage of this signature includes type-indexed values such
+ * as
+ * - generic (as opposed to polymorphic) equality (eq),
+ * - generic hashing (hash),
+ * - generic ordering (compare),
+ * - generic generation of random values (arbitrary), and
+ * - generic serialization (pickle).
+ *
+ * In general, this signature is intended for type-indexed values whose
+ * domain is (almost all of) SML types.  Conversely, this signature is not
+ * designed for domain specific type-indexed values whose domain does not
+ * directly match the SML type system.
+ *
+ * As you can see, of the integer types, only {int} and {largeInt} are
+ * specialized, while a much wider range of word types is supported.  The
+ * intention is that the integer types should not be used for things such
+ * as serialization.  If sized integer types are really needed, they are
+ * to be implemented through the corresponding sized word types.
+ *)
+
+signature STRUCTURAL_TYPE = sig
+   type 'a t
+   (** Type of type-indices. *)
+
+   (** == SUPPORT FOR USER-DEFINED TYPES == *)
+
+   val iso : 'b t -> ('a, 'b) Iso.t -> 'a t
+   (**
+    * Given an isomorphism between {'a} and {'b} and a type-index for
+    * {'b}, returns a type-index for {'a}.  The purpose of {iso} is to
+    * support user-defined types.
+    *)
+
+   (** == SUPPORT FOR TUPLES AND RECORDS == *)
+
+   val *` : 'a t * 'b t -> ('a, 'b) Product.t t
+   (**
+    * Given type-indices for fields of type {'a} and {'b}, returns a
+    * type-index for the product {('a, 'b) product}.
+    *)
+
+   (** == SUPPORT FOR DATATYPES == *)
+
+   val +` : 'a t * 'b t -> ('a, 'b) Sum.t t
+   (**
+    * Given type-indices for variants of type {'a} and {'b}, returns a
+    * type-index for the sum {('a, 'b) sum}.
+    *)
+
+   val unit : Unit.t t
+   (**
+    * Type-index for the {unit} type.  Using {unit} and {+} one can
+    * actually encode {bool}, {word}, and much more.
+    *)
+
+   val Y : 'a t Tie.t
+   (** Fixpoint tier to support recursive datatypes. *)
+
+   (** == SUPPORT FOR FUNCTIONS == *)
+
+   val --> : 'a t * 'b t -> ('a -> 'b) t
+
+   (** == SUPPORT FOR EXCEPTIONS == *)
+
+   val exn : Exn.t t
+   (** Universal type-index for exceptions. *)
+
+   val regExn : 'a t -> ('a, Exn.t) Emb.t Effect.t
+   (** Registers a handler for exceptions. *)
+
+   (** == SUPPORT FOR TYPES WITH IDENTITY == *)
+
+   val array : 'a t -> 'a Array.t t
+   val refc  : 'a t -> 'a Ref.t   t
+
+   (** == SUPPORT FOR FUNCTIONAL AGGREGATE TYPES == *)
+
+   val vector : 'a t -> 'a Vector.t t
+
+   (** == SUPPORT FOR ARBITRARY INTEGERS, WORDS, AND REALS == *)
+
+   val largeInt  : LargeInt.t  t
+   val largeReal : LargeReal.t t
+   val largeWord : LargeWord.t t
+
+   (** == SUPPORT FOR BINARY DATA == *)
+
+   val word8  : Word8.t  t
+   val word16 : Word16.t t
+   val word32 : Word32.t t
+   val word64 : Word64.t t
+
+   (** == SUPPORT FOR SOME BUILT-IN TYPE CONSTRUCTORS == *)
+
+   val list : 'a t -> 'a List.t t
+
+   (** == SUPPORT FOR SOME BUILT-IN BASE TYPES == *)
+
+   val bool   : Bool.t   t
+   val char   : Char.t   t
+   val int    : Int.t    t
+   val real   : Real.t   t
+   val string : String.t t
+   val word   : Word.t   t
+end


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

[MLton-commit] r5056

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

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

A   mltonlib/trunk/com/ssh/misc-util/unstable/structural-type-pair.fun

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/structural-type-pair.fun
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/structural-type-pair.fun	2007-01-12 12:35:53 UTC (rev 5055)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/structural-type-pair.fun	2007-01-12 12:36:07 UTC (rev 5056)
@@ -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.
+ *)
+
+(*
+ * A functor for combining implementations of the {STRUCTURAL_TYPE}
+ * signature.
+ *)
+
+functor StructuralTypePair
+           (structure A : STRUCTURAL_TYPE
+            structure B : STRUCTURAL_TYPE) : STRUCTURAL_TYPE = struct
+   type 'a t = 'a A.t * 'a B.t
+
+   fun iso (a, b) i = (A.iso a i, B.iso b i)
+
+   local
+      fun mk t = Pair.map t o Pair.swizzle
+   in
+      fun op *`  ? = mk (A.*`,  B.*`)  ?
+      fun op +`  ? = mk (A.+`,  B.+`)  ?
+      fun op --> ? = mk (A.-->, B.-->) ?
+   end
+
+   fun Y ? = Tie.tuple2 (A.Y, B.Y) ?
+
+   val exn = (A.exn, B.exn)
+   fun regExn (a, b) emb = (A.regExn a emb ; B.regExn b emb)
+
+   fun array ? = Pair.map (A.array, B.array) ?
+   fun refc  ? = Pair.map (A.refc,  B.refc)  ?
+
+   fun vector ? = Pair.map (A.vector, B.vector) ?
+
+   fun list ? = Pair.map (A.list, B.list) ?
+
+   val bool   = (A.bool,   B.bool)
+   val char   = (A.char,   B.char)
+   val int    = (A.int,    B.int)
+   val real   = (A.real,   B.real)
+   val string = (A.string, B.string)
+   val unit   = (A.unit,   B.unit)
+   val word   = (A.word,   B.word)
+
+   val largeInt  = (A.largeInt,  B.largeInt)
+   val largeReal = (A.largeReal, B.largeReal)
+   val largeWord = (A.largeWord, B.largeWord)
+
+   val word8  = (A.word8,  B.word8)
+   val word16 = (A.word16, B.word16)
+   val word32 = (A.word32, B.word32)
+   val word64 = (A.word64, B.word64)
+end


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

[MLton-commit] r5055

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/sorted-list-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/sorted-list-test.sml	2007-01-12 12:35:32 UTC (rev 5054)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/sorted-list-test.sml	2007-01-12 12:35:53 UTC (rev 5055)
@@ -0,0 +1,104 @@
+(* 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 {SortedList} module.
+ *)
+
+val () = let
+   open Type UnitTest
+
+   local
+      fun mk f = flip f Int.compare
+      open SortedList
+   in
+      val insert     = mk insert
+      val isSorted   = mk isSorted
+      val merge      = mk merge
+      val remove     = mk remove
+      val stableSort = mk stableSort
+   end
+
+   val sortedList = let
+      val l = list int
+   in
+      fn #? => withGen (RanQD1Gen.prj (arbitrary l) (stableSort #?)) l
+   end
+
+   fun revPartition3Way c = let
+      fun lp (ls, es, gs) =
+          fn [] => (ls, es, gs)
+           | x::xs =>
+             lp (case c x of
+                    LESS    => (x::ls, es, gs)
+                  | EQUAL   => (ls, x::es, gs)
+                  | GREATER => (ls, es, x::gs))
+                xs
+   in lp ([], [], [])
+   end
+
+   fun quickSort cmp = let
+      fun lp sorted =
+          fn p::xs =>
+             let val (ls, es, gs) = revPartition3Way (cmp /> p) xs
+             in lp (p::es @ lp sorted gs) ls
+             end
+           | [] => sorted
+   in lp []
+   end
+
+   fun divide xs = let
+      fun lp (gs, xs) x =
+          fn (y::ys) =>
+             lp (if x = y then
+                    (gs, x::xs)
+                 else
+                    ((x, xs)::gs, []))
+                y ys
+           | [] => rev ((x, xs)::gs)
+   in
+      case quickSort Int.compare xs of
+         [] => []
+       | x::xs => lp ([], []) x xs
+   end
+in
+   unitTests
+      (title "SortedList")
+
+      (chk (all (sortedList #n &` int)
+                (fn xs & x => let
+                       val ys = insert #n x xs
+                    in
+                       that (isSorted #n ys andalso
+                             length ys = length xs + 1)
+                    end)))
+
+      (chk (all (sq (sortedList #n))
+                (fn (xs, ys) =>  let
+                       val zs = merge #n (xs, ys)
+                    in
+                       that (isSorted #n zs andalso
+                             divide zs = divide (xs @ ys))
+                    end)))
+
+      (chk (all (list int)
+                (fn xs => let
+                       val ys = stableSort #n xs
+                    in
+                       that (isSorted #n ys andalso
+                             divide xs = divide ys)
+                    end)))
+
+      (chk (all (list int)
+                (fn xs => let
+                       val ys = stableSort #1 xs
+                    in
+                       that (isSorted #1 ys andalso
+                             map #1 (divide xs) = ys)
+                    end)))
+
+      $
+end


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

[MLton-commit] r5054

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/sorted-list.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/sorted-list.sml	2007-01-12 12:35:12 UTC (rev 5053)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/sorted-list.sml	2007-01-12 12:35:32 UTC (rev 5054)
@@ -0,0 +1,142 @@
+(* 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.
+ *)
+
+(*
+ * Operations on sorted (or ordered) lists.  The provided signature is not
+ * type safe meaning that it is possible to apply these operations to
+ * unsorted lists as well as lists sorted with a different compare
+ * function.
+ *)
+
+structure SortedList :> sig
+   type 'a policy
+   type 'a card = {1 : 'a policy, n : 'a policy} -> 'a policy
+   (**
+    * Cardinality policy is specified as either {#1} or {#n}.  {#1}
+    * means that a sorted list has at most 1 element of any value,
+    * while {#n} means that a list may have any number of equal values.
+    *)
+
+   val insert : 'a card -> 'a Cmp.t -> 'a -> 'a List.t UnOp.t
+      (** {insert #? cmp x xs = merge #? cmp ([x], xs)} *)
+
+   val isSorted : 'a card -> 'a Cmp.t -> 'a List.t UnPr.t
+   (**
+    * Returns true iff the list is sorted to the specified cardinality and
+    * ordering.
+    *)
+
+   val merge : 'a card -> 'a Cmp.t -> 'a List.t BinOp.t
+   (**
+    * Merges two lists sorted to the specified cardinality and ordering.
+    *
+    * It is guaranteed that in {merge #n cmp (l, r)} elements from the
+    * list {l} appear before equal elements from the list {r}.
+    *)
+
+   val remove : 'a card -> 'a Cmp.t -> 'a -> 'a List.t UnOp.t
+   (**
+    * Removes the specified cardinality of elements that compare equal to
+    * the specified element from the sorted list.
+    *)
+
+   val stableSort : 'a card -> 'a Cmp.t -> 'a List.t UnOp.t
+   (**
+    * Sorts the given list to the specified cardinality and ordering.
+    *
+    * It is guaranteed that the relative ordering of equal elements is
+    * retained.
+    *)
+end = struct
+   type 'a policy = {cond : Order.t UnPr.t,
+                     cont : 'a List.t Sq.t UnOp.t UnOp.t,
+                     dups : 'a * 'a List.t -> 'a List.t}
+   type 'a card = {1 : 'a policy, n : 'a policy} -> 'a policy
+
+   fun P m (c : 'a card) =
+       {1 = {cond = LESS <\ op =,
+             cont = const id,
+             dups = Pair.snd},
+        n = {cond = GREATER <\ op <>,
+             cont = id,
+             dups = op ::}} >| c >| m
+
+   fun isSorted card compare = let
+      fun lp [] = true
+        | lp [_] = true
+        | lp (x1::(xs as x2::_)) =
+          P #cond card (compare (x1, x2))
+          andalso lp xs
+   in
+      lp
+   end
+
+   fun revMerge' #? compare (xs, ys) = let
+      fun lp ([], ys, zs) = (ys, zs)
+        | lp (xs, [], zs) = (xs, zs)
+        | lp (x::xs, y::ys, zs) =
+          case compare (x, y) of
+             LESS => lp (xs, y::ys, x::zs)
+           | EQUAL => lp (xs, P #dups #? (y, ys), x::zs)
+           | GREATER => lp (x::xs, ys, y::zs)
+   in
+      lp (xs, ys, [])
+   end
+
+   fun merge #? ? = List.revAppend o Pair.swap o revMerge' #? ?
+
+   fun insert #? compare x xs = merge #? compare ([x], xs)
+
+   fun remove #? compare x ys = let
+      fun lp (zs, []) = (zs, [])
+        | lp (zs, y::ys) =
+          case compare (x, y) of
+             LESS => (zs, y::ys)
+           | EQUAL => P #cont #? lp (zs, ys)
+           | GREATER => lp (y::zs, ys)
+   in
+      List.revAppend (lp ([], ys))
+   end
+
+   (*
+    * This is an optimized implementation of merge sort that tries to
+    * avoid unnecessary list reversals.  This is done by performing
+    * reverse merges and flipping the compare direction as appropriate.
+    *)
+   fun stableSort #? compare = let
+      fun revOdd (w, l) = if Word.isEven w then l else rev l
+      fun merge r =
+          List.revAppend o (if Word.isOdd r then revMerge' #? compare
+                            else revMerge' #? (compare o Pair.swap) o Pair.swap)
+      val finish =
+          fn [] => []
+           | e::es =>
+             revOdd
+                (foldl
+                    (fn ((r1, l1), (r0, l0)) =>
+                        (r1+0w1, merge (r1+0w1) (revOdd (r1-r0, l0), l1)))
+                    e es)
+      fun build (stack as ((r0, l0)::(r1, l1)::rest)) =
+          if r0 <> r1 then push stack
+          else build ((r1+0w1, merge (r1+0w1) (l0, l1))::rest)
+        | build stack = push stack
+      and push stack =
+          fn [] => finish stack
+           | x::xs => let
+             fun lp y ys =
+                 fn [] => finish ((0w1, y::ys)::stack)
+                  | x::xs =>
+                    case compare (x, y) of
+                       LESS => build ((0w1, y::ys)::stack) (x::xs)
+                     | EQUAL => lp x (P #dups #? (y, ys)) xs
+                     | GREATER => lp x (y::ys) xs
+          in
+             lp x [] xs
+          end
+   in
+      push []
+   end
+end


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

[MLton-commit] r5053

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/sml-syntax.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/sml-syntax.sml	2007-01-12 12:34:47 UTC (rev 5052)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/sml-syntax.sml	2007-01-12 12:35:12 UTC (rev 5053)
@@ -0,0 +1,35 @@
+(* 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 dealing with the syntax of Standard ML.
+ *)
+
+structure SmlSyntax :> sig
+   (** == PREDICATES FOR IDENTIFIERS == *)
+
+   val isAlphaNumId : String.t UnPr.t
+   val isId         : String.t UnPr.t
+   val isLabel      : String.t UnPr.t
+   val isLongId     : String.t UnPr.t
+   val isNumLabel   : String.t UnPr.t
+end = struct
+   structure C = Char and L = List and S = String
+   val isSym = C.contains "!%&$#+-/:<=>?@\\~`^|*"
+   val isntEmpty = 0 <\ op < o size
+   val isSymId = isntEmpty andAlso S.all isSym
+   val isAlphaNumId = isntEmpty
+                      andAlso C.isAlpha o S.sub /> 0
+                      andAlso S.all (C.isAlphaNum
+                                     orElse #"'" <\ op =
+                                     orElse #"_" <\ op =)
+   val isNumLabel = isntEmpty
+                    andAlso #"0" <\ op <> o S.sub /> 0
+                    andAlso S.all C.isDigit
+   val isId = isAlphaNumId orElse isSymId
+   val isLongId = L.all isId o S.fields (#"." <\ op =)
+   val isLabel = isId orElse isNumLabel
+end


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

[MLton-commit] r5052

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/show-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/show-test.sml	2007-01-12 12:34:02 UTC (rev 5051)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/show-test.sml	2007-01-12 12:34:47 UTC (rev 5052)
@@ -0,0 +1,101 @@
+(* 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 {Show} module.
+ *)
+
+val () = let
+   open Type UnitTest
+
+   fun tst n t s v =
+       testEq
+          string
+          (fn () =>
+              {expect = s,
+               actual = show n t v})
+in
+   unitTests
+      (title "Show")
+
+      (tst NONE unit "()" ())
+
+      (tst NONE word "0wx15" 0wx15)
+
+      (tst (SOME 6) (list int)
+           "[1,\n 2,\n 3]"
+           [1, 2, 3])
+
+      (tst (SOME 2) (vector bool)
+           "#[true,\n\
+           \  false]"
+           (Vector.fromList [true, false]))
+
+      (tst (SOME 15) (tuple3 (option unit, string, exn))
+           "(NONE,\n\
+           \ \"a\",\n\
+           \ Empty)"
+           (NONE, "a", Empty))
+
+      (tst NONE (array unit) "#()" (Array.array (0, ())))
+
+      (tst NONE real "~3.141" ~3.141)
+
+      (tst (SOME 22)
+           ((order |` unit) &` order &` (unit |` order))
+           "&\n\
+           \ (& (INL LESS, EQUAL),\n\
+           \  INR GREATER)"
+           (INL LESS & EQUAL & INR GREATER))
+
+      let
+         fun chk s e = tst (SOME 11) string e s
+      in
+         fn ? =>
+            (pass ?)
+               (chk "does not fit"   "\"does not fit\"")
+               (chk "does\nnot\nfit" "\"does\\n\\\n\\not\\n\\\n\\fit\"")
+               (chk "does fit"       "\"does fit\"")
+               (chk "does\nfit"      "\"does\\nfit\"")
+      end
+
+      let
+         exception Unknown
+      in
+         tst NONE exn "#Unknown" Unknown
+      end
+
+      (tst (SOME 9)
+           (iso (record (R' "1" int *`
+                                        R' "+" (uop int) *`
+                                                             R' "c" char))
+                (fn {1 = a, + = b, c = c} => a & b & c,
+                 fn a & b & c => {1 = a, + = b, c = c}))
+           "{1 = 2,\n\
+           \ + = #fn,\n\
+           \ c =\n\
+           \  #\"d\"}"
+           {1 = 2, + = id, c = #"d"})
+
+      let
+         datatype s = S of s option ref Sq.t
+         val x as S (l, r) = S (ref NONE, ref NONE)
+         val () = (l := SOME x ; r := SOME x)
+      in
+         tst (SOME 50)
+             (Tie.fix Y (fn s =>
+                            iso (data (C1' "S" (sq (refc (option s)))))
+                                (fn S ? => ?, S)))
+             "S\n\
+             \ (#0 as ref\n\
+             \   (SOME (S (#0, #1 as ref (SOME (S (#0, #1)))))),\n\
+             \  #0 as ref\n\
+             \   (SOME (S (#1 as ref (SOME (S (#1, #0))), #0))))"
+             x
+      end
+
+      $
+end


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

[MLton-commit] r5051

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/show.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/show.sml	2007-01-12 12:33:38 UTC (rev 5050)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/show.sml	2007-01-12 12:34:02 UTC (rev 5051)
@@ -0,0 +1,219 @@
+(* 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 function for pretty printing values
+ * of arbitrary SML datatypes.  See
+ *
+ *   http://mlton.org/TypeIndexedValues
+ *
+ * for further discussion.
+ *)
+
+(* XXX show sharing *)
+(* XXX pretty printing could use some tuning *)
+(* XXX parameters for pretty printing? *)
+(* XXX parameters for depth, length, etc... for showing only partial data *)
+
+signature SHOW = sig
+   type 'a show_t
+   type 'a show_s
+   type ('a, 'k) show_p
+
+   val layout : 'a show_t -> 'a -> Prettier.t
+   (** Extracts the prettifying function. *)
+
+   val show : Int.t Option.t -> 'a show_t -> 'a -> String.t
+   (** {show m t = Prettier.pretty m o layout t} *)
+end
+
+functor LiftShow
+           (include SHOW
+            type 'a t
+            type 'a s
+            type ('a, 'k) p
+            val liftT : ('a show_t, 'a t) Lift.t Thunk.t) : SHOW = struct
+   type 'a show_t = 'a t
+   type 'a show_s = 'a s
+   type ('a, 'k) show_p = ('a, 'k) p
+   val layout = fn ? => Lift.get liftT layout ?
+   val show   = fn m => Lift.get liftT (show m)
+end
+
+structure Show :> sig
+   include TYPE
+   include SHOW
+      where type 'a show_t = 'a t
+      where type 'a show_s = 'a s
+      where type ('a, 'k) show_p = ('a, 'k) p
+end = struct
+   local
+      open Prettier
+      type u = Bool.t * t
+      fun atomic    doc = (true,  doc)
+      fun nonAtomic doc = (false, doc)
+      val uop : t UnOp.t -> u UnOp.t = id <\ Pair.map
+      val bop : t BinOp.t -> u BinOp.t =
+          fn f => nonAtomic o f o Pair.map (Sq.mk Pair.snd)
+   in
+      type u = u
+
+      val parens       = (1, (lparen,   rparen))
+      val hashParens   = (2, (txt "#(", rparen))
+      val braces       = (1, (lbrace,   rbrace))
+      val brackets     = (1, (lbracket, rbracket))
+      val hashBrackets = (2, (txt "#[", rbracket))
+
+      val comma  = atomic comma
+      val equals = atomic equals
+
+      val txt = atomic o txt
+      fun surround (n, p) = atomic o group o nest n o enclose p o Pair.snd
+      fun atomize (d as (a, _)) = if a then d else surround parens d
+      val punctuate = fn (_, s) => punctuate s o map Pair.snd
+      val fill = fn ? => nonAtomic (vsep ?)
+      val group = uop group
+      val nest = uop o nest
+      val op <^> = fn ((al, dl), (ar, dr)) => (al andalso ar, dl <^> dr)
+      val op <$> = bop op <$>
+      val op </> = bop op </>
+   end
+
+   local
+      open TypeSupport
+   in
+      val C = C
+      val l2s = labelToString
+      val c2s = constructorToString
+   end
+
+   type 'a t = exn list * 'a -> u
+   type 'a s = 'a t
+   type ('a, 'k) p = 'a t
+   type 'a show_t = 'a t
+   type 'a show_s = 'a s
+   type ('a, 'k) show_p = ('a, 'k) p
+
+   fun layout t x = Pair.snd (t ([], x))
+   fun show m t = Prettier.pretty m o layout t
+
+   fun inj b a2b = b o Pair.map (id, a2b)
+   fun iso b = inj b o Iso.to
+   val isoProduct = iso
+   val isoSum = iso
+
+   fun (l *` r) (env, a & b) = l (env, a) <^> comma <$> r (env, b)
+
+   val T = id
+   fun R label = let
+      val txtLabel = txt (l2s label)
+      fun fmt t ? = group (nest 1 (txtLabel </> equals </> t ?))
+   in
+      fmt
+   end
+
+   fun tuple t = surround parens o t
+   fun record t = surround braces o t
+
+   fun l +` r = fn (env, INL a) => l (env, a)
+                 | (env, INR b) => r (env, b)
+
+   fun C0 ctor = const (txt (c2s ctor))
+   fun C1 ctor = let
+      val txtCtor = txt (c2s ctor)
+   in
+      fn t => fn ? => nest 1 (group (txtCtor <$> atomize (t ?)))
+   end
+
+   val data = id
+
+   val Y = Tie.function
+
+   val exn : exn t ref =
+       ref (txt o "#" <\ op ^ o General.exnName o #2)
+   fun regExn t (_, prj) =
+       Ref.modify (fn exn => fn (env, e) =>
+                      case prj e of
+                         NONE => exn (env, e)
+                       | SOME x => t (env, x)) exn
+   val exn = fn ? => !exn ?
+
+   val txtAs = txt "as"
+   fun cyclic t = let
+      exception E of ''a * bool ref
+   in
+      fn (env, v : ''a) => let
+         val idx = Int.toString o length
+         fun lp (E (v', c)::env) =
+             if v' <> v then
+                lp env
+             else
+                (c := false ; txt ("#"^idx env))
+           | lp (_::env) = lp env
+           | lp [] = let
+            val c = ref true
+            val r = t (E (v, c)::env, v)
+         in
+            if !c then
+               r
+            else
+               txt ("#"^idx env) </> txtAs </> r
+         end
+      in
+         lp env
+      end
+   end
+   fun aggregate style toL t (env, a) =
+       surround style o fill o punctuate comma o map (curry t env) |< toL a
+
+   val ctorRef = C "ref"
+   fun refc  ? = cyclic o flip inj ! |< C1 ctorRef ?
+   fun array ? = cyclic |< aggregate hashParens Array.toList ?
+
+   fun vector ? = aggregate hashBrackets Vector.toList ?
+
+   fun list ? = aggregate brackets id ?
+
+   val txtFn = txt "#fn"
+   fun _ --> _ = const txtFn
+
+   local
+      open Prettier
+      val toLit = txt o String.toString
+      val nlbs = txt "\\n\\"
+   in
+      fun string (_, s) =
+          (true,
+           group o dquotes |< choice
+              {wide = toLit s,
+               narrow = lazy (fn () =>
+                                 List.foldl1 (fn (x, s) =>
+                                                 s <^> nlbs <$> backslash <^> x)
+                                             (map toLit
+                                                  (String.fields
+                                                      (#"\n" <\ op =) s)))})
+   end
+
+   fun mk toS : 'a t = txt o toS o Pair.snd
+   fun enc l r toS x = concat [l, toS x, r]
+   fun mkWord toString = mk ("0wx" <\ op ^ o toString)
+
+   val bool = mk Bool.toString
+   val char = mk (enc "#\"" "\"" Char.toString)
+   val int  = mk Int.toString
+   val real = mk Real.toString
+   val unit = mk (Thunk.mk "()")
+   val word = mkWord Word.toString
+
+   val largeInt  = mk LargeInt.toString
+   val largeReal = mk LargeReal.toString
+   val largeWord = mkWord LargeWord.toString
+
+   val word8  = mkWord Word8.toString
+   val word16 = mkWord Word16.toString
+   val word32 = mkWord Word32.toString
+   val word64 = mkWord Word64.toString
+end


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

[MLton-commit] r5050

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/rng.sig
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/rng.sig	2007-01-12 12:33:24 UTC (rev 5049)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/rng.sig	2007-01-12 12:33:38 UTC (rev 5050)
@@ -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.
+ *)
+
+(*
+ * Signature for functional random number generators.
+ *)
+
+signature RNG = sig
+   type t
+   (** The type of random number generator state or seed. *)
+
+   val value : t -> Word.t
+   (** Extracts the current random word from the seed. *)
+
+   val next : t UnOp.t
+   (** Computes the next seed. *)
+
+   val split : Word.t -> t UnOp.t
+   (** Computes a new seed based on the given seed and word index. *)
+
+   val maxValue : Word.t
+   (** The range of generated random words is {{0w0, ..., maxValue}}. *)
+end


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

[MLton-commit] r5049

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/README
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/README	2007-01-12 12:33:12 UTC (rev 5048)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/README	2007-01-12 12:33:24 UTC (rev 5049)
@@ -0,0 +1,2 @@
+This library contains some miscellaneous utilities.  The goal is to
+reorganize these into a more useful collection of libraries.


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

[MLton-commit] r5048

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/ranqd1-gen.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/ranqd1-gen.sml	2007-01-12 12:32:59 UTC (rev 5047)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/ranqd1-gen.sml	2007-01-12 12:33:12 UTC (rev 5048)
@@ -0,0 +1,24 @@
+(* 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 quick-and-dirty random generator.
+ *)
+
+structure RanQD1Gen :> sig
+   include RANDOM_GEN
+   val make : Word32.t -> t
+end = struct
+   structure G =
+      MkRandomGen
+         (type t = Word32.t
+          val (value, seed) = Iso.<--> (Iso.swap Word.isoLarge, Word32.isoLarge)
+          val next = Misc.ranqd1
+          fun split w = #2 o Misc.psdes /> seed w
+          val maxValue = value Word32.maxWord)
+   open G
+   val make = id
+end


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

[MLton-commit] r5047

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/random-gen.sig
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/random-gen.sig	2007-01-12 12:32:40 UTC (rev 5046)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/random-gen.sig	2007-01-12 12:32:59 UTC (rev 5047)
@@ -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.
+ *)
+
+(*
+ * A signature for random value generators.  The design is based on the
+ * QuickCheck library by Koen Claessen and John Hughes:
+ *
+ *   http://www.cs.chalmers.se/~rjmh/QuickCheck/ .
+ *)
+
+signature RANDOM_GEN = sig
+   include RNG
+
+   type 'a gen = Int.t -> t -> 'a
+
+   val lift : (t -> 'a) -> 'a gen
+
+   val return : 'a -> 'a gen
+   val >>= : 'a gen * ('a -> 'b gen) -> 'b gen
+
+   val prj : 'b gen -> ('b -> 'a) -> 'a gen
+
+   val promote : ('a -> 'b gen) -> ('a -> 'b) gen
+
+   val sized : (Int.t -> 'a gen) -> 'a gen
+   val resize : Int.t UnOp.t -> 'a gen UnOp.t
+
+   val elements : 'a List.t -> 'a gen
+   val oneOf : 'a gen List.t -> 'a gen
+   val frequency : (Int.t * 'a gen) List.t -> 'a gen
+
+   val inRange : ('b Sq.t -> 'b gen) -> ('a, 'b) Iso.t -> 'a Sq.t -> 'a gen
+
+   val intInRange  : Int.t  Sq.t -> Int.t  gen
+   val realInRange : Real.t Sq.t -> Real.t gen
+   val wordInRange : Word.t Sq.t -> Word.t gen
+
+   val bool : Bool.t gen
+
+   val list : 'a gen -> Int.t -> 'a List.t gen
+end


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

[MLton-commit] r5046

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/random-dev.sig
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/random-dev.sig	2007-01-12 12:31:55 UTC (rev 5045)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/random-dev.sig	2007-01-12 12:32:40 UTC (rev 5046)
@@ -0,0 +1,27 @@
+(* 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 accessing some (unspecified) system supplied source of
+ * randomness (e.g. /dev/random and /dev/urandom).  Modules implementing
+ * this signature should not be used as general purpose random number
+ * generators, but should rather be used to seed other pseudo random
+ * number generators.
+ *)
+
+signature RANDOM_DEV = sig
+   val seed : Word.t Option.t Thunk.t
+   (**
+    * Returns a high-quality random word.  A call to seed may block until
+    * enough random bits are available.
+    *)
+
+   val useed : Word.t Option.t Thunk.t
+   (**
+    * Returns a random word.  If there aren't enough high-quality random
+    * bits available, a lower quality random word will be returned.
+    *)
+end


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

[MLton-commit] r5045

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/random-dev-mlton.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/random-dev-mlton.sml	2007-01-12 12:31:16 UTC (rev 5044)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/random-dev-mlton.sml	2007-01-12 12:31:55 UTC (rev 5045)
@@ -0,0 +1,11 @@
+(* 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.
+ *)
+
+(*
+ * Implementation of the {RANDOM_DEV} signature for MLton.
+ *)
+
+structure RandomDev : RANDOM_DEV = MLton.Random


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

[MLton-commit] r5044

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml	2007-01-12 12:30:48 UTC (rev 5043)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/queue.sml	2007-01-12 12:31:16 UTC (rev 5044)
@@ -0,0 +1,41 @@
+(* 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 {QUEUE} signature.  This is based on a space
+ * safe implementation by Stephen Weeks posted on the MLton developers
+ * mailing list.
+ *)
+
+structure Queue :> QUEUE = struct
+   structure N = Node
+
+   datatype 'a t = IN of {back : 'a N.t Ref.t,
+                          front : 'a N.t Ref.t}
+
+   fun new () = let
+      val n = N.new ()
+   in
+      IN {back = ref n, front = ref n}
+   end
+
+   fun isEmpty (IN {front, ...}) =
+       not (isSome (N.get (!front)))
+
+   fun enque (IN {back, ...}) =
+       fn a => let
+          val r = !back
+          val n = N.new ()
+       in
+          N.<- (r, SOME (a, n))
+        ; back := n
+       end
+
+   fun deque (IN {front, ...}) =
+       case N.get (!front) of
+          NONE => NONE
+        | SOME (a, n) => (front := n ; SOME a)
+end


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

[MLton-commit] r5043

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/queue.sig
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/queue.sig	2007-01-12 12:30:34 UTC (rev 5042)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/queue.sig	2007-01-12 12:30:48 UTC (rev 5043)
@@ -0,0 +1,20 @@
+(* 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 queue.
+ *)
+
+signature QUEUE = sig
+   type 'a t
+
+   val new : 'a t Thunk.t
+
+   val isEmpty : 'a t UnPr.t
+
+   val deque : 'a t -> 'a Option.t
+   val enque : 'a t -> 'a Effect.t
+end


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

[MLton-commit] r5042

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/qc-test-example.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/qc-test-example.sml	2007-01-12 12:30:10 UTC (rev 5041)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/qc-test-example.sml	2007-01-12 12:30:34 UTC (rev 5042)
@@ -0,0 +1,134 @@
+(* 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.
+ *)
+
+(*
+ * Simple examples of specifying QuickCheck -style randomized tests using
+ * the UnitTest framework.  The example laws are from the QuickCheck paper
+ * by Koen Claessen and John Hughes.
+ *)
+
+val () = let
+   open Type UnitTest
+
+   local
+      fun mk f = f #n Int.compare
+
+      (* The functions in the SortedList module are parameterized on both
+       * a duplicate cardinality (either #1 or #n duplicates are allowed
+       * and produced) and an ordering (a compare function).
+       *)
+
+      open SortedList
+   in
+      val insert     = mk insert
+      val isSorted   = mk isSorted
+      val stableSort = mk stableSort
+   end
+
+   val sortedList =
+       let
+          val l = list int
+       in
+          withGen (RanQD1Gen.prj (arbitrary l) stableSort) l
+       end
+
+   (* Note that one can (of course) make local auxiliary definitions, like
+    * here, to help with testing.
+    *)
+in
+   unitTests
+      (title "Reverse")
+
+      (chk (all int
+                (fn x =>
+                    that (rev [x] = [x]))))
+
+      (* Read the above as:
+       *
+       *   "check for all integers x that the reverse of the singleton
+       *    list x equals the singleton list x"
+       *
+       * (Of course, in reality, the property is only checked for a small
+       * finite number of random integers at a time.)
+       *
+       * In contrast to QuickCheck/Haskell, one must explicitly lift
+       * boolean values to properties using {that}.
+       *)
+
+      (chk (all (sq (list int))
+                (fn (xs, ys) =>
+                    that (rev (xs @ ys) = rev ys @ rev xs))))
+
+      (chk (all (list int)
+                (fn xs =>
+                    that (rev (rev xs) = xs))))
+
+      (title "Functions")
+
+      let
+         infix ===
+         fun (f === g) x = that (f x = g x)
+         (* An approximation of extensional equality for functions. *)
+      in
+         chk (all (uop int &` uop int &` uop int)
+                  (fn f & g & h =>
+                      all int
+                          (f o (g o h) === (f o g) o h)))
+
+         (* Note that one can (of course) also write local auxiliary
+          * definitions inside let -expressions.
+          *)
+      end
+
+      (title "Conditional laws")
+
+      (chk (all (sq int)
+                (fn (x, y) =>
+                    if x <= y then
+                       that (Int.max (x, y) = y)
+                    else
+                       skip)))
+
+      (* Read the above as:
+       *
+       *   "check for all integer pairs (x, y) that
+       *    if x <= y then max (x, y) = y"
+       *
+       * In contrast to QuickCheck/Haskell, conditional properties are
+       * specified using conditionals and {skip} rather than using an
+       * implication operator.
+       *)
+
+      (title "Monitoring test data")
+
+      (chk (all (int &` list int)
+                (fn x & xs =>
+                    if isSorted xs then
+                       (trivial (null xs))
+                          (that (isSorted (insert x xs)))
+                    else
+                       skip)))
+
+      (chk (all (int &` list int)
+                (fn x & xs =>
+                    if isSorted xs then
+                       (collect int (length xs))
+                          (that (isSorted (insert x xs)))
+                    else
+                       skip)))
+
+      (chk (all (int &` sortedList)
+                (fn x & xs =>
+                    that o isSorted |< insert x xs)))
+
+      (* Above we use a custom test data generator for sorted (or ordered)
+       * lists.  In contrast to QuickCheck/Haskell, the custom data
+       * generator needs to be injected into a type-index (recall the use
+       * of {withGen} in the implementation of sortedList above).
+       *)
+
+      $
+end


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

[MLton-commit] r5041

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/promise-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/promise-test.sml	2007-01-12 12:29:56 UTC (rev 5040)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/promise-test.sml	2007-01-12 12:30:10 UTC (rev 5041)
@@ -0,0 +1,179 @@
+(* 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.
+ *)
+
+(*
+ * Copyright (c) 2006 SSH Communications Security, Helsinki, Finland
+ *               All rights reserved.
+ *
+ * Unit tests for the {Promise} module.
+ *)
+
+val () = let
+   open Type UnitTest
+
+   val fix = Tie.fix
+
+   local
+      open Promise
+   in
+      val D = delay
+      val E = eager
+      val F = force
+      val L = lazy
+      val Y = Y
+   end
+
+   (* lazy stream *)
+   datatype 'a stream' = NIL | CONS of 'a * 'a stream
+   withtype 'a stream = 'a stream' Promise.t
+
+   local
+      fun strip s = case F s of NIL => raise Empty | CONS x => x
+   in
+      fun hd s = #1 (strip s)
+      fun tl s = #2 (strip s)
+   end
+
+   fun cons x = E (CONS x)
+
+   fun streamDrop (s, i) =
+       L (fn () =>
+             if 0 = i then
+                s
+             else
+                streamDrop (tl s, i - 1))
+
+   fun streamSub (s, i) = hd (streamDrop (s, i))
+
+   (* helpers *)
+   fun inc x = (x += 1 ; !x)
+in
+   unitTests
+      (title "Promise.fix")
+
+      (testRaises
+          Fix.Fix
+          (fn () =>
+              fix Y (fn invalid =>
+                        (F invalid ; E ()))))
+
+      (testEq
+          int
+          (fn () => let
+                 fun streamZipWith fxy (xs, ys) =
+                     D (fn () =>
+                           CONS (fxy (hd xs, hd ys),
+                                 streamZipWith fxy (tl xs, tl ys)))
+
+                 val fibs =
+                     fix Y (fn fibs =>
+                               0 </cons/> 1 </cons/>
+                                 (streamZipWith
+                                     op +
+                                     (L (fn () => tl fibs), fibs)))
+              in
+                 {expect = 8,
+                  actual = streamSub (fibs, 6)}
+              end))
+
+      (title "Promise - memoization")
+
+      (testEq
+          (list int)
+          (fn () => let
+                 val count = ref 0
+                 val s = D (fn () => inc count)
+              in
+                 {expect = [1, 1, 1],
+                  actual = [F s, F s, !count]}
+              end))
+
+      (testEq
+          (list int)
+          (fn () => let
+                 val count = ref 0
+                 val s = D (fn () => inc count)
+              in
+                 {expect = [2, 1],
+                  actual = [F s + F s, !count]}
+              end))
+
+      (testEq
+          (list int)
+          (fn () => let
+                 val count = ref 0
+                 val r = D (fn () => inc count)
+                 val s = L (Thunk.mk r)
+                 val t = L (Thunk.mk s)
+              in
+                 {expect = [1, 1, 1],
+                  actual = [F t, F r, !count]}
+              end))
+
+      (testEq
+          (list int)
+          (fn () => let
+                 val count = ref 0
+                 fun ones () = D (fn () => CONS (inc count, ones ()))
+                 val s = ones ()
+              in
+                 {expect = [5, 5, 5],
+                  actual = [streamSub (s, 4), streamSub (s, 4), !count]}
+              end))
+
+      (title "Promise - reentrancy")
+
+      (testEq
+          (list int)
+          (fn () => let
+                 val count = ref 0
+                 val x = ref 5
+                 val p = fix Y (fn p =>
+                                   D (fn () =>
+                                         if inc count > !x then
+                                            !count
+                                         else
+                                            F p))
+              in
+                 {expect = [6, 6],
+                  actual = [F p, (x := 10 ; F p)]}
+              end))
+
+      (testEq
+          int
+          (fn () => let
+                 val first = ref true
+                 val f = fix Y (fn f =>
+                                   D (fn () =>
+                                         if !first then
+                                            (first := false ; F f)
+                                         else
+                                            2))
+              in
+                 {expect = 2,
+                  actual = F f}
+              end))
+
+      (testEq
+          (list int)
+          (fn () => let
+                 val count = ref 5
+                 val p = fix Y (fn p =>
+                                   D (fn () =>
+                                         if !count <= 0 then
+                                            !count
+                                         else
+                                            (count -= 1
+                                           ; ignore (F p)
+                                           ; count += 2
+                                           ; !count)))
+              in
+                 {expect = [5, 0, 10],
+                  actual = [!count, F p, !count]}
+              end))
+
+      $
+end


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

[MLton-commit] r5040

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/prettier-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/prettier-test.sml	2007-01-12 12:29:42 UTC (rev 5039)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/prettier-test.sml	2007-01-12 12:29:56 UTC (rev 5040)
@@ -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.
+ *)
+
+(*
+ * Unit tests for the {Prettier} module.
+ *)
+
+val () = let
+   open Type UnitTest Prettier
+
+   datatype tree = N of String.t * tree List.t
+
+   local
+      fun tree (N (s, [])) = txt s
+        | tree (N (s, ts)) =
+          group (txt s <^> nest (1+size s) (brackets (trees ts)))
+      and trees [] = empty
+        | trees [t] = tree t
+        | trees (t::ts) = tree t <^> comma <$> trees ts
+   in
+      val layoutTree = tree
+   end
+
+   val aTree =
+       N ("aaa", [N ("bbbbb", [N ("ccc", []), N ("dd", [])]),
+                  N ("eee", []),
+                  N ("ffff", [N ("gg", []), N ("hhh", []), N ("ii", [])])])
+in
+   unitTests
+      (title "Prettier")
+
+      (testEq string
+              (fn () =>
+                  {expect = "this is\n\
+                            \level one\n\
+                            \text\n\
+                            \  some\n\
+                            \  level\n\
+                            \  two text\n\
+                            \    level\n\
+                            \    three\n\
+                            \    text\n\
+                            \  level\n\
+                            \  two text\n\
+                            \  again",
+                   actual = pretty (SOME 10)
+                                   (str "this is level one text\n\
+                                        \  some level two text\n\
+                                        \    level three text\n\
+                                        \  level two text again")}))
+      (testEq string
+              (fn () =>
+                  {expect = "aaa[bbbbb[ccc, dd],\n\
+                            \    eee,\n\
+                            \    ffff[gg, hhh, ii]]",
+                   actual = pretty (SOME 30) (layoutTree aTree)}))
+
+      $
+end


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

[MLton-commit] r5039

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

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

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

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

Added: mltonlib/trunk/com/ssh/misc-util/unstable/prettier.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/prettier.sml	2007-01-12 12:29:27 UTC (rev 5038)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/prettier.sml	2007-01-12 12:29:42 UTC (rev 5039)
@@ -0,0 +1,463 @@
+(* 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 pretty-printing library.  The design is primarily based on Philip
+ * Wadler's article ``A prettier printer''
+ *
+ *   http://homepages.inf.ed.ac.uk/wadler/topics/language-design.html
+ *
+ * which is a redesign of John Hughes's pretty-printing library described
+ * in ``The Design of a Pretty-Printing Library''
+ *
+ *   http://www.cs.chalmers.se/~rjmh/Papers/pretty.html
+ *
+ * Some of Daan Leijen's PPrint library
+ *
+ *   http://www.cs.uu.nl/~daan/pprint.html
+ *
+ * has also been implemented.
+ *)
+
+structure Prettier :> sig
+   type t
+   (** The abstract type of documents. *)
+
+   datatype elem =
+      STRING of String.t
+    | NEWLINE of Int.t
+
+   val fold : (elem * 'a -> 'a) -> 'a -> Int.t Option.t -> t -> 'a
+   (**
+    * Linearizes the given document and folds the linearized document with
+    * the given function.
+    *)
+
+   val app : elem Effect.t -> Int.t Option.t -> t Effect.t
+   (** {app e = fold (e o #1) ()} *)
+
+   val pretty : Int.t Option.t -> t -> String.t
+   (** {pretty n d = concat (rev (fold op:: [] n d))} *)
+
+   val println : TextIO.outstream -> Int.t Option.t -> t Effect.t
+   (**
+    * Writes the document to the specified stream with a newline and
+    * flushes the stream.
+    *)
+
+   (** == BASIC COMBINATORS == *)
+
+   val empty : t
+   (** The empty document is semantically equivalent to {txt ""}. *)
+
+   val chr : Char.t -> t
+   (**
+    * {chr c} contains the character {c}.  The character shouldn't be a
+    * newline.
+    *)
+
+   val txt : String.t -> t
+   (**
+    * {txt s} contains the string {s}.  The string shouldn't contain any
+    * newline characters.
+    *)
+
+   val str : String.t -> t
+   (**
+    * Converts a simple preformatted string into a document.  The idea is
+    * that newlines separate paragraphs and spaces after a newline specify
+    * indentation.  Spaces inside paragraph are replaced by softlines,
+    * paragraphs are prefixed with a line, nested by the specified
+    * indentation level, and grouped.  Everything is then concatenated
+    * together.
+    *)
+
+   val <^> : t BinOp.t
+   (**
+    * {l <^> r} is the concatenation of the documents {l} and {r}.
+    *
+    * Note: This is the same as the operator <> used in the original
+    * Haskell libraries.  In SML, <> is already used.
+    *)
+
+   val nest : Int.t -> t UnOp.t
+   (**
+    * {nest n d} renders document {d} indented by {n} more columns.
+    *
+    * Note that in order for {nest} to have any effect, you must have line
+    * breaks in {group}s in {d}.
+    *)
+
+   val line : t
+   (**
+    * Advances to the next line and indents, unless undone by {group} in
+    * which case {line} behaves like {txt " "}.
+    *)
+
+   val linebreak : t
+   (**
+    * Advances to the next line and indents, unless undone by {group} in
+    * which case {linebreak} behaves like {empty}.
+    *)
+
+   val group : t UnOp.t
+   (**
+    * Used to specify alternative layouts.  {group d} undoes all line
+    * breaks in document {d}.  The resulting line of text is added to the
+    * current output line if it fits.  Otherwise, the document is rendered
+    * without changes (with line breaks).
+    *)
+
+   val choice : {wide : t, narrow : t} -> t
+   (**
+    * Used to specify alternative documents.  The wider document is added
+    * to the current output line if it fits.  Otherwise, the narrow
+    * document is rendered.
+    *
+    * Warning: This operation allows one to create documents whose
+    * rendering may not produce optimal or easily predictable results.
+    *)
+
+   val lazy : t Thunk.t -> t
+   (**
+    * Creates a lazily computed document.  {lazy (fn () => doc)} is
+    * equivalent to {doc} except that the expression {doc} may not be
+    * evaluated at all.
+    *
+    * Note: This is primarily useful for specifying the narrow alternative
+    * to {choice} - unless, of course, there is a chance that the whole
+    * document will not be rendered at all.
+    *)
+
+   val softline : t
+   (**
+    * Behaves like a space if the resulting output fits, otherwise behaves
+    * like {line}.
+    *)
+
+   val softbreak : t
+   (**
+    * Behaves like {empty} if the resulting output fits, otherwise behaves
+    * like {line}.
+    *)
+
+   (** == ALIGNMENT COMBINATORS == *)
+
+   val column : (Int.t -> t) -> t
+   val nesting : (Int.t -> t) -> t
+
+   val indent : Int.t -> t UnOp.t
+   val hang : Int.t -> t UnOp.t
+   val align : t UnOp.t
+
+   val width : (Int.t -> t) -> t UnOp.t
+
+   val fillBreak : Int.t -> t UnOp.t
+   val fill : Int.t -> t UnOp.t
+
+   (** == OPERATORS == *)
+
+   val <+>  : t BinOp.t  (** Concatenates with a {space}. *)
+   val <$>  : t BinOp.t  (** Concatenates with a {line}. *)
+   val </>  : t BinOp.t  (** Concatenates with a {softline}. *)
+   val <$$> : t BinOp.t  (** Concatenates with a {linebreak}. *)
+   val <//> : t BinOp.t  (** Concatenates with a {softbreak}. *)
+
+   (** == LIST COMBINATORS == *)
+
+   val sep : t List.t -> t  (** {sep = group o vsep} *)
+   val cat : t List.t -> t  (** {cat = group o vcat} *)
+
+   val punctuate : t -> t List.t UnOp.t
+   (**
+    * {punctuate sep docs} concatenates {sep} to the right of each
+    * document in {docs} except the last one.
+    *)
+
+   val hsep    : t List.t -> t  (** Concatenates with {<+>}. *)
+   val vsep    : t List.t -> t  (** Concatenates with {<$>}. *)
+   val fillSep : t List.t -> t  (** Concatenates with {</>}. *)
+   val hcat    : t List.t -> t  (** Concatenates with {<^>}. *)
+   val vcat    : t List.t -> t  (** Concatenates with {<$$>}. *)
+   val fillCat : t List.t -> t  (** Concatenates with {<//>}. *)
+
+   (** == BRACKETING COMBINATORS == *)
+
+   val enclose : t Sq.t -> t UnOp.t
+   (** {enclose (l, r) d = l <^> d <^> r} *)
+
+   val squotes  : t UnOp.t  (** {squotes  = enclose (squote, squote)} *)
+   val dquotes  : t UnOp.t  (** {dquotes  = enclose (dquote, dquote)} *)
+   val parens   : t UnOp.t  (** {parens   = enclose (lparen, rparen)} *)
+   val angles   : t UnOp.t  (** {angles   = enclose (langle, rangle)} *)
+   val braces   : t UnOp.t  (** {braces   = enclose (lbrace, rbrace)} *)
+   val brackets : t UnOp.t  (** {brackets = enclose (lbracket, rbracket)} *)
+
+   (** == CHARACTER DOCUMENTS == *)
+
+   val lparen    : t  (** {txt "("} *)
+   val rparen    : t  (** {txt ")"} *)
+   val langle    : t  (** {txt "<"} *)
+   val rangle    : t  (** {txt ">"} *)
+   val lbrace    : t  (** {txt "{"} *)
+   val rbrace    : t  (** {txt "}"} *)
+   val lbracket  : t  (** {txt "["} *)
+   val rbracket  : t  (** {txt "]"} *)
+   val squote    : t  (** {txt "'"} *)
+   val dquote    : t  (** {txt "\""} *)
+   val semi      : t  (** {txt ";"} *)
+   val colon     : t  (** {txt ":"} *)
+   val comma     : t  (** {txt ","} *)
+   val space     : t  (** {txt " "} *)
+   val dot       : t  (** {txt "."} *)
+   val backslash : t  (** {txt "\\"} *)
+   val equals    : t  (** {txt "="} *)
+end = struct
+   structure Dbg = MkDbg (open DbgDefs val name = "Prettier")
+         and C = Char and S = String and SS = Substring and P = Promise
+
+   local
+      open P
+   in
+      val E = eager
+      val F = force
+      val L = lazy
+   end
+
+   datatype t' =
+      EMPTY
+    | LINE of bool
+    | JOIN of t Sq.t
+    | NEST of Int.t * t
+    | TEXT of String.t
+    | CHOICE of {wide : t, narrow : t}
+    | COLUMN of Int.t -> t
+    | NESTING of Int.t -> t
+   withtype t = t' P.t
+
+   datatype elem =
+      STRING of String.t
+    | NEWLINE of Int.t
+
+   val lazy = L
+
+   val empty = E EMPTY
+   val line = E (LINE false)
+   val linebreak = E (LINE true)
+   val column = E o COLUMN
+   val nesting = E o NESTING
+
+   local
+      fun assertAllPrint str =
+          Dbg.assert 0 (fn () => S.all C.isPrint str)
+   in
+      val txt' = E o TEXT
+      val txt = txt' o Effect.obs assertAllPrint
+      val chr = txt o str
+   end
+
+   val parens   as (lparen,   rparen)   = (txt' "(", txt' ")")
+   val angles   as (langle,   rangle)   = (txt' "<", txt' ">")
+   val braces   as (lbrace,   rbrace)   = (txt' "{", txt' "}")
+   val brackets as (lbracket, rbracket) = (txt' "[", txt' "]")
+   val squote    = txt' "'"
+   val dquote    = txt' "\""
+   val semi      = txt' ";"
+   val colon     = txt' ":"
+   val comma     = txt' ","
+   val space     = txt' " "
+   val dot       = txt' "."
+   val backslash = txt' "\\"
+   val equals    = txt' "="
+
+   val op <^> = E o JOIN
+
+   fun punctuate sep =
+       fn [] => []
+        | d::ds => let
+          fun lp rs d1 =
+              fn [] => List.revAppend (rs, [d1])
+               | d2::ds => lp (d1 <^> sep::rs) d2 ds
+       in
+          lp [] d ds
+       end
+
+   fun nest n = E o n <\ NEST
+
+   fun spaces n = S.tabulate (n, const #" ")
+
+   fun align d = column (fn k => nesting (fn i => nest (k-i) d))
+   fun hang i d = align (nest i d)
+   fun indent i d = hang i (txt (spaces i) <^> d)
+
+   fun width f d = column (fn l => d <^> column (fn r => f (r-l)))
+
+   local
+      fun mk p t f =
+          width (fn w => if p (f, w) then t f else txt (spaces (f-w)))
+   in
+      val fillBreak = mk op <  (flip nest linebreak)
+      val fill      = mk op <= (const empty)
+   end
+
+   local
+      fun flatten doc =
+          L (fn () =>
+                case F doc of
+                   EMPTY =>
+                   doc
+                 | JOIN (lhs, rhs) =>
+                   E (JOIN (flatten lhs, flatten rhs))
+                 | NEST (cols, doc) =>
+                   E (NEST (cols, flatten doc))
+                 | TEXT _ =>
+                   doc
+                 | LINE b =>
+                   if b then empty else space
+                 | CHOICE {wide, ...} =>
+                   wide
+                 | COLUMN f =>
+                   E (COLUMN (flatten o f))
+                 | NESTING f =>
+                   E (NESTING (flatten o f)))
+   in
+      fun choice {wide, narrow} =
+          E (CHOICE {wide = flatten wide, narrow = narrow})
+      fun group doc =
+          choice {wide = doc, narrow = doc}
+   end
+
+   val softline = group line
+   val softbreak = group linebreak
+
+   local
+      fun mk m (l, r) = l <^> m <^> r
+   in
+      val op <+>  = mk space
+      val op <$>  = mk line
+      val op </>  = mk softline
+      val op <$$> = mk linebreak
+      val op <//> = mk softbreak
+   end
+
+   local
+      fun mk bop xs =
+          case rev xs of
+             [] => empty
+           | x::xs =>
+             foldl bop x xs
+   in
+      val hsep    = mk op <+>
+      val vsep    = mk op <$>
+      val fillSep = mk op </>
+      val hcat    = mk op <^>
+      val vcat    = mk op <$$>
+      val fillCat = mk op <//>
+   end
+
+   val sep = group o vsep
+   val cat = group o vcat
+
+   fun enclose (l, r) d = l <^> d <^> r
+   val squotes  = enclose (Sq.mk squote)
+   val dquotes  = enclose (Sq.mk dquote)
+   val parens   = enclose parens
+   val angles   = enclose angles
+   val braces   = enclose braces
+   val brackets = enclose brackets
+
+   fun fold f s maxCols doc = let
+      datatype t' =
+         NIL
+       | PRINT of String.t * t
+       | LINEFEED of Int.t * t
+      withtype t = t' P.t
+
+      fun layout s doc =
+          case F doc of
+             NIL => s
+           | PRINT (str, doc) =>
+             layout (f (STRING str, s)) doc
+           | LINEFEED (cols, doc) =>
+             layout (f (NEWLINE cols, s)) doc
+
+      fun fits usedCols doc =
+          NONE = maxCols orelse
+          usedCols <= valOf maxCols andalso
+          case F doc of
+             NIL => true
+           | LINEFEED _ => true
+           | PRINT (str, doc) =>
+             fits (usedCols + size str) doc
+
+      fun best usedCols work =
+          L (fn () =>
+                case work of
+                   [] => E NIL
+                 | (nestCols, doc)::rest =>
+                   case F doc of
+                      EMPTY =>
+                      best usedCols rest
+                    | JOIN (lhs, rhs) =>
+                      best usedCols ((nestCols, lhs)::
+                                     (nestCols, rhs)::rest)
+                    | NEST (cols, doc) =>
+                      best usedCols ((nestCols + cols, doc)::rest)
+                    | TEXT str =>
+                      E (PRINT (str, best (usedCols + size str) rest))
+                    | LINE _ =>
+                      E (LINEFEED (nestCols, best nestCols rest))
+                    | CHOICE {wide, narrow} => let
+                      val wide = best usedCols ((nestCols, wide)::rest)
+                   in
+                      if fits usedCols wide then
+                         wide
+                      else
+                         best usedCols ((nestCols, narrow)::rest)
+                   end
+                    | COLUMN f =>
+                      best usedCols ((nestCols, f usedCols)::rest)
+                    | NESTING f =>
+                      best usedCols ((nestCols, f nestCols)::rest))
+   in
+      layout s (best 0 [(0, doc)])
+   end
+
+   fun app e = fold (e o #1) ()
+
+   fun pretty n d =
+       concat o rev |< fold (fn (STRING s, ss) => s::ss
+                              | (NEWLINE n, ss) =>
+                                spaces n::"\n"::ss) [] n d
+
+   local
+      val join =
+          fn [] => empty
+           | (_, d)::xs =>
+             group d <^> hcat (map (group o uncurry nest o
+                                    Pair.map (id, line <\ op <^>)) xs)
+   in
+      val str =
+          join o
+          map (Pair.map (SS.size,
+                         fillSep o
+                         map (txt' o SS.string) o
+                         SS.fields C.isSpace) o
+               SS.splitl C.isSpace) o
+          SS.fields (#"\n" <\ op =) o
+          SS.dropl C.isSpace o
+          SS.full
+   end
+
+   fun println os n d =
+       (app (fn STRING s => TextIO.output (os, s)
+              | NEWLINE n =>
+                (TextIO.output1 (os, #"\n")
+               ; repeat (fn () => TextIO.output1 (os, #" ")) n ()))
+            n d
+      ; TextIO.output1 (os, #"\n")
+      ; TextIO.flushOut os)
+end


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