[MLton-commit] r6421
Vesa Karvonen
vesak at mlton.org
Fri Feb 29 08:52:43 PST 2008
Added an initial implementation of a generic value enumeration.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/enum.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/lib.use
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/value/enum.sig
A mltonlib/trunk/com/ssh/generic/unstable/with/enum.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm 2008-02-26 18:28:21 UTC (rev 6420)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm 2008-02-29 16:52:38 UTC (rev 6421)
@@ -26,6 +26,7 @@
../../../public/value/arbitrary.sig
../../../public/value/data-rec-info.sig
../../../public/value/dynamic.sig
+ ../../../public/value/enum.sig
../../../public/value/eq.sig
../../../public/value/fmap.sig
../../../public/value/hash.sig
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2008-02-26 18:28:21 UTC (rev 6420)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2008-02-29 16:52:38 UTC (rev 6421)
@@ -28,6 +28,7 @@
../../value/data-rec-info.sml
../../value/debug.sml
../../value/dynamic.sml
+ ../../value/enum.sml
../../value/eq.sml
../../value/fmap.sml
../../value/hash.sml
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/enum.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/enum.sml 2008-02-26 18:28:21 UTC (rev 6420)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/enum.sml 2008-02-29 16:52:38 UTC (rev 6421)
@@ -0,0 +1,164 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+functor WithEnum (Arg : WITH_ENUM_DOM) = let
+ structure Result = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix 4 <\
+ infix 0 &
+ (* SML/NJ workaround --> *)
+
+ infixr :::
+
+ structure Enum = struct
+ datatype 'a t = IN of Unit.t -> ('a * 'a t) Option.t
+ fun get (IN t) = t ()
+ val empty = IN (fn () => NONE)
+(*
+ fun takeAtMost (e, n) =
+ IN (fn () =>
+ if n <= 0
+ then NONE
+ else case get e
+ of NONE => NONE
+ | SOME (x, e) => SOME (x, takeAtMost (e, n-1)))
+ fun toList e = let
+ fun lp (xs, e) =
+ case get e
+ of NONE => rev xs
+ | SOME (x, e) => lp (x::xs, e)
+ in
+ lp ([], e)
+ end
+*)
+ fun interleave (xs, ys) =
+ IN (fn () =>
+ case get xs
+ of NONE => get ys
+ | SOME (x, xs) => SOME (x, interleave (ys, xs)))
+(*
+ fun iterate f x =
+ IN (fn () => SOME (x, iterate f (f x)))
+*)
+ fun iterateUnless f x =
+ IN (fn () => SOME (x, iterateUnless f (f x) handle _ => empty))
+ fun map f xs =
+ IN (fn () =>
+ case get xs
+ of NONE => NONE
+ | SOME (x, xs) => SOME (f x, map f xs))
+ fun nonEmptyTails xs =
+ IN (fn () =>
+ case get xs
+ of NONE => NONE
+ | SOME (_, xs') => SOME (xs, nonEmptyTails xs'))
+ fun x ::: xs = IN (fn () => SOME (x, xs))
+ end
+
+ open Enum
+
+ fun iso' b (_, b2a) = map b2a b
+
+ fun product (xs, ys) = let
+ fun lp zss =
+ IN (fn () =>
+ case get zss
+ of NONE => NONE
+ | SOME (zs, zss) => get (interleave (zs, lp zss)))
+ in
+ lp (map (fn xs => map (fn y => #1 (valOf (get xs)) & y) ys)
+ (nonEmptyTails xs))
+ end
+
+ fun list' a =
+ IN (fn () => get (interleave ([]:::empty,
+ map (fn x & xs => x::xs)
+ (product (a, list' a)))))
+
+ fun mkInt zero one ~ op + =
+ interleave (iterateUnless ( one <\ op +) zero,
+ iterateUnless (~one <\ op +) (~one))
+
+ fun mkWord one op + (min, max) =
+ iterateUnless (fn w => if w = max then raise Overflow else w + one)
+ min
+
+ fun mkReal zero posInf ~ nextAfter =
+ interleave (iterateUnless (fn r => nextAfter (r, posInf)) zero,
+ iterateUnless (fn r => nextAfter (r, ~posInf)) (~zero))
+
+ structure EnumRep = LayerRep (open Arg structure Rep = MkClosedRep (Enum))
+
+ open EnumRep.This
+
+ val enum = getT
+
+ structure Open = LayerDepCases
+ (fun iso bT = iso' (getT bT)
+ fun isoProduct bP = iso' (getP bP)
+ fun isoSum bS = iso' (getS bS)
+
+ fun op *` (xs, ys) = product (getP xs, getP ys)
+ val T = getT
+ fun R _ = getT
+ val tuple = getP
+ val record = getP
+
+ fun op +` (aS, bS) = let
+ val a = map INL (getS aS)
+ val b = map INR (getS bS)
+ in
+ interleave (if Arg.hasBaseCase aS then (a, b) else (b, a))
+ end
+ val unit = ():::empty
+ fun C0 _ = unit
+ fun C1 _ = getT
+ val data = getS
+
+ fun Y ? = Tie.iso Tie.function (fn IN ? => ?, IN) ?
+
+ fun op --> _ = empty (* XXX: not yet implemented *)
+
+ val exn = empty (* XXX: not yet implemented *)
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
+
+ fun list a = list' (getT a)
+ fun vector a = iso' (list a) Vector.isoList
+
+ fun array a = iso' (list a) Array.isoList
+ fun refc a = iso a (undefined, ref)
+
+ val fixedInt = mkInt 0 1 ~ FixedInt.+
+ val largeInt = mkInt 0 1 ~ LargeInt.+
+
+ val largeReal = mkReal 0.0 LargeReal.posInf ~ LargeReal.nextAfter
+ val largeWord = mkWord 0w1 op + LargeWord.bounds
+
+ val bool = false:::true:::empty
+ val char = iterateUnless (chr o 1 <\ op + o ord) Char.minValue
+ val int = mkInt 0 1 ~ Int.+
+ val real = mkReal 0.0 Real.posInf ~ Real.nextAfter
+ val string = iso' (list' char) String.isoList
+ val word = mkWord 0w1 op + Word.bounds
+
+ val word8 = mkWord 0w1 op + Word8.bounds
+ val word32 = mkWord 0w1 op + Word32.bounds
+(*
+ val word64 = mkWord 0w1 op + Word64.bounds
+*)
+
+ fun hole () = IN undefined
+
+ open Arg EnumRep)
+ end
+in
+ Result :> ENUM_CASES
+ where type ('a, 'x) Open.Rep.t = ('a, 'x) Result.Open.Rep.t
+ where type ('a, 'x) Open.Rep.s = ('a, 'x) Result.Open.Rep.s
+ where type ('a, 'k, 'x) Open.Rep.p = ('a, 'k, 'x) Result.Open.Rep.p
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/enum.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2008-02-26 18:28:21 UTC (rev 6420)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2008-02-29 16:52:38 UTC (rev 6421)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+(* Copyright (C) 2007-2008 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.
@@ -86,6 +86,9 @@
public/value/dynamic.sig
detail/value/dynamic.sml
+ public/value/enum.sig
+ detail/value/enum.sml
+
public/value/eq.sig
detail/value/eq.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.use
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.use 2008-02-26 18:28:21 UTC (rev 6420)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.use 2008-02-29 16:52:38 UTC (rev 6421)
@@ -51,6 +51,8 @@
"detail/value/debug.sml",
"public/value/dynamic.sig",
"detail/value/dynamic.sml",
+ "public/value/enum.sig",
+ "detail/value/enum.sml",
"public/value/eq.sig",
"detail/value/eq.sml",
"public/value/fmap.sig",
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2008-02-26 18:28:21 UTC (rev 6420)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2008-02-29 16:52:38 UTC (rev 6421)
@@ -144,6 +144,10 @@
and WITH_DYNAMIC_DOM = WITH_DYNAMIC_DOM
functor WithDynamic (Arg : WITH_DYNAMIC_DOM) : DYNAMIC_CASES = WithDynamic (Arg)
+signature ENUM = ENUM and ENUM_CASES = ENUM_CASES
+ and WITH_ENUM_DOM = WITH_ENUM_DOM
+functor WithEnum (Arg : WITH_ENUM_DOM) : ENUM_CASES = WithEnum (Arg)
+
signature EQ = EQ and EQ_CASES = EQ_CASES and WITH_EQ_DOM = WITH_EQ_DOM
functor WithEq (Arg : WITH_EQ_DOM) : EQ_CASES = WithEq (Arg)
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/enum.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/enum.sig 2008-02-26 18:28:21 UTC (rev 6420)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/enum.sig 2008-02-29 16:52:38 UTC (rev 6421)
@@ -0,0 +1,41 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * Signature for a generic value enumeration.
+ *
+ * The main application of enumeration is testing.
+ *)
+signature ENUM = sig
+ structure EnumRep : OPEN_REP
+
+ structure Enum : sig
+ type 'a t
+ (** Type of enumeration streams. *)
+
+ val get : ('a, 'a t) Reader.t
+ (**
+ * Reader for enumeration streams.
+ *
+ * Enumeration streams are not memoized. Each time {Enum.get} is
+ * called, a new value is created and all mutable substructures
+ * generated from an enumeration will be distinct.
+ *)
+ end
+
+ val enum : ('a, 'x) EnumRep.t -> 'a Enum.t
+ (**
+ * Returns a stream that enumerates through finite, acyclic values of
+ * the type.
+ *)
+end
+
+signature ENUM_CASES = sig
+ include CASES ENUM
+ sharing Open.Rep = EnumRep
+end
+
+signature WITH_ENUM_DOM = TYPE_INFO_CASES
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/enum.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/with/enum.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/with/enum.sml 2008-02-26 18:28:21 UTC (rev 6420)
+++ mltonlib/trunk/com/ssh/generic/unstable/with/enum.sml 2008-02-29 16:52:38 UTC (rev 6421)
@@ -0,0 +1,19 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+signature Generic = sig
+ include Generic ENUM
+end
+
+functor MkGeneric (Arg : Generic) = struct
+ structure Open = MkGeneric (Arg)
+ open Arg Open
+ structure EnumRep = Open.Rep
+end
+
+structure Generic =
+ MkGeneric (structure Open = WithEnum (Generic)
+ open Generic Open)
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/with/enum.sml
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list