[MLton-commit] r5574
Vesa Karvonen
vesak at mlton.org
Mon May 28 07:27:21 PDT 2007
Faked first-class polymorphism through a universal type in Arbitrary.
Reorganized the RANDOM_GEN signature.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/misc-util/unstable/arbitrary.sml
U mltonlib/trunk/com/ssh/misc-util/unstable/mk-random-gen.fun
U mltonlib/trunk/com/ssh/misc-util/unstable/random-gen.sig
U mltonlib/trunk/com/ssh/misc-util/unstable/ranqd1-gen.sml
U mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/arbitrary.sml 2007-05-28 12:38:06 UTC (rev 5573)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/arbitrary.sml 2007-05-28 14:27:20 UTC (rev 5574)
@@ -15,10 +15,10 @@
signature ARBITRARY = sig
type 'a arbitrary_t
- val arbitrary : 'a arbitrary_t -> 'a RanQD1Gen.gen
+ val arbitrary : 'a arbitrary_t -> 'a RanQD1Gen.t
(** Extracts the random value generator. *)
- val withGen : 'a RanQD1Gen.gen -> 'a arbitrary_t UnOp.t
+ val withGen : 'a RanQD1Gen.t -> 'a arbitrary_t UnOp.t
(** Functionally updates the random value generator. *)
end
@@ -39,12 +39,14 @@
structure G = RanQD1Gen and I = Int and R = Real and W = Word
and Typ = TypeInfo
- datatype 'a t =
- IN of {gen : 'a G.gen,
- cog : int -> 'a -> G.t UnOp.t,
- typ : 'a Typ.t}
+ datatype 'a t
+ = IN of {gen : 'a G.t,
+ cog : 'a -> Univ.t G.t UnOp.t,
+ typ : 'a Typ.t}
type 'a arbitrary_t = 'a t
+ fun universally ? = G.mapUnOp (Univ.newIso ()) ?
+
val map = G.Monad.map
val op >>= = G.>>=
@@ -54,50 +56,37 @@
fun iso (IN {gen, cog, typ, ...}) (iso as (a2b, b2a)) =
IN {gen = map b2a gen,
- cog = fn n => cog n o a2b,
+ cog = cog o a2b,
typ = Typ.iso typ iso}
- val unit = IN {gen = const (const ()),
- cog = const (const (G.split 0w0)),
- typ = Typ.unit}
+ val unit = IN {gen = G.return (), cog = const (G.variant 0), typ = Typ.unit}
val bool = IN {gen = G.bool,
- cog = const (G.split o (fn false => 0w1 | true => 0w2)),
+ cog = G.variant o (fn true => 1 | false => 0),
typ = Typ.bool}
- val int = IN {gen = map (fn w => W.toIntX (w - G.maxValue div 0w2))
+ val int = IN {gen = map (fn w => W.toIntX (w - G.RNG.maxValue div 0w2))
(* XXX result may not fit an Int.int *)
- (G.lift G.value),
- cog = const (G.split o W.fromInt),
+ (G.lift G.RNG.value),
+ cog = G.variant,
typ = Typ.int}
- val word = IN {gen = G.lift G.value,
- cog = const G.split,
+ val word = IN {gen = G.lift G.RNG.value,
+ cog = G.variant o W.toIntX,
typ = Typ.word}
val real = IN {gen = G.sized ((fn r => G.realInRange (~r, r)) o real),
- cog = const (G.split o W.fromLarge o
- PackWord32Little.subVec /> 0 o
- PackReal32Little.toBytes o
- Real32.fromLarge IEEEReal.TO_NEAREST o
- R.toLarge),
+ cog = (G.variant o LargeWord.toIntX o
+ PackWord32Little.subVec /> 0 o
+ PackReal32Little.toBytes o
+ Real32.fromLarge IEEEReal.TO_NEAREST o
+ R.toLarge),
typ = Typ.real}
- fun Y ? = let
- open Tie
- val genFn = pure (fn () => let
- val r = ref (raising Fix.Fix)
- fun f x = !r x
- in
- (G.resize (op div /> 2) f,
- fn f' => (r := f' ; f'))
- end)
- in
- iso (genFn *` function *` Typ.Y)
- (fn IN {gen = a, cog = b, typ = c} => a & b & c,
- fn a & b & c => IN {gen = a, cog = b, typ = c})
- end ?
+ fun Y ? = let open Tie in iso (G.Y *` function *` Typ.Y) end
+ (fn IN {gen = a, cog = b, typ = c} => a & b & c,
+ fn a & b & c => IN {gen = a, cog = b, typ = c}) ?
fun (IN {gen = aGen, cog = aCog, typ = aTyp, ...}) *`
(IN {gen = bGen, cog = bCog, typ = bTyp, ...}) =
IN {gen = G.Monad.>>& (aGen, bGen),
- cog = fn n => fn a & b => aCog n a o G.split 0w643 o bCog n b,
+ cog = fn a & b => aCog a o bCog b,
typ = Typ.*` (aTyp, bTyp)}
fun (IN {gen = aGen, cog = aCog, typ = aTyp, ...}) +`
@@ -112,27 +101,27 @@
| _ => gen
in
IN {gen = G.sized (fn 0 => gen0 | _ => gen),
- cog = fn n => fn INL a => G.split 0w423 o aCog n a
- | INR b => G.split 0w324 o bCog n b,
+ cog = fn INL a => G.variant 0 o aCog a
+ | INR b => G.variant 1 o bCog b,
typ = Typ.+` (aTyp, bTyp)}
end
fun (IN {gen = aGen, cog = aCog, typ = aTyp, ...}) -->
(IN {gen = bGen, cog = bCog, typ = bTyp, ...}) =
- IN {gen = G.promote (fn a => fn n => bGen n o aCog n a),
- cog = fn n => fn a2b => fn r =>
- bCog n (a2b (aGen n (G.split 0w3 r))) (G.split 0w4 r),
+ IN {gen = G.promote (fn a => universally (aCog a) bGen),
+ cog = fn f => fn g => aGen >>= (fn a => universally (bCog (f a)) g),
typ = Typ.--> (aTyp, bTyp)}
val exn = let val e = Fail "Arbitrary.exn not supported yet"
- in IN {gen = raising e, cog = raising e, typ = Typ.exn}
+ in IN {gen = G.return Empty, cog = raising e, typ = Typ.exn}
end
fun regExn _ _ = ()
fun list (IN {gen = xGen, cog = xCog, typ = xTyp, ...}) = let
val xsGen = G.sized (0 <\ G.intInRange) >>= G.list xGen
- fun xsCog _ [] t = G.split 0w5 t
- | xsCog n (x::xs) t = xsCog n xs (xCog n x t)
+ fun xsCog [] = G.variant 0
+ | xsCog (x::xs) =
+ universally (xCog x) o G.variant 1 o universally (xsCog xs)
in
IN {gen = xsGen, cog = xsCog, typ = Typ.list xTyp}
end
@@ -143,7 +132,7 @@
fun vector a = iso (list a) Vector.isoList
val char = IN {gen = map chr (G.intInRange (0, Char.maxOrd)),
- cog = const (G.split o W.fromInt o ord),
+ cog = G.variant o ord,
typ = Typ.char}
val string = iso (list char) String.isoList
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/mk-random-gen.fun
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/mk-random-gen.fun 2007-05-28 12:38:06 UTC (rev 5573)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/mk-random-gen.fun 2007-05-28 14:27:20 UTC (rev 5574)
@@ -9,40 +9,61 @@
* providing a random number generator.
*)
-functor MkRandomGen (RNG : RNG) :>
- RANDOM_GEN
- where type t = RNG.t = struct
+functor MkRandomGen (RNG : RNG) :> RANDOM_GEN where type RNG.t = RNG.t = struct
structure D = MkDbg (open DbgDefs val name = "MkRandomGen")
and A = Array and R = Real and V = Vector and W = Word
- open RNG
- type 'a gen = Int.t -> t -> 'a
+ structure RNG = RNG
- val lift = const
+ type 'a dom = Int.t * RNG.t and 'a cod = 'a
+ type 'a t = 'a dom -> 'a cod
- (*fun prj gb b2a n = b2a o gb n*)
+ fun generate n t =
+ pass (W.toInt (RNG.value t mod (W.fromInt n)), RNG.next t)
+ fun lift r2a = r2a o Pair.snd
+
structure Monad =
- MkMonad (type 'a monad = 'a gen
- fun return a _ _ = a
- fun (m >>= k) n r = k (m n (split 0w314 r)) n (split 0w159 r))
+ MkMonad (type 'a monad = 'a t
+ val return = const
+ fun (m >>= k) (n, r) =
+ k (m (n, RNG.split 0w314 r)) (n, RNG.split 0w159 r))
open Monad
- fun promote a2b n r a = a2b a n r
- fun sized i2g n r = i2g n n r
- fun resize f g = g o f
- fun bool _ r = maxValue div 0w2 < value r
+ fun map a2b ga = a2b o ga
+ fun promote a2b (n, r) a = a2b a (n, r)
+
+ fun variant v m = m o Pair.map (id, RNG.split (W.fromInt v + 0w1))
+
+ fun mapUnOp (to, from) eG2eG = let
+ fun map f g = f o g
+ in
+ Fn.map (map to, map from) eG2eG
+ end
+
+ fun sized i2g (n, r) = i2g n (n, r)
+ fun resize f g = g o Pair.map (f, id)
+ fun bool (_, r) = RNG.maxValue div 0w2 < RNG.value r
+
+ fun Y ? = Tie.pure (fn () => let
+ val r = ref (raising Fix.Fix)
+ fun f x = !r x
+ in
+ (resize (op div /> 2) f,
+ fn f' => (r := f' ; f'))
+ end) ?
+
fun inRange bInRange (a2b, b2a) =
map b2a o bInRange o Pair.map (Sq.mk a2b)
fun wordInRange (l, h) =
(D.assert 0 (fn () => l <= h)
- ; let val n = h - l + 0w1 (* XXX may overflow *)
- val d = maxValue div n (* XXX may result in zero *)
+ ; let val n = h - l + 0w1 (* XXX may overflow *)
+ val d = RNG.maxValue div n (* XXX may result in zero *)
val m = n * d
- in lift (fn r => value r mod m div d + l)
+ in lift (fn r => RNG.value r mod m div d + l)
end)
fun intInRange (l, h) =
@@ -55,8 +76,8 @@
in
fun realInRange (l, h) =
(D.assert 0 (fn () => l <= h)
- ; let val m = (h - l) / w2r maxValue
- in const (fn r => w2r (value r) * m + l)
+ ; let val m = (h - l) / w2r RNG.maxValue
+ in fn (_, r) => w2r (RNG.value r) * m + l
end)
end
@@ -92,10 +113,10 @@
lp []
end
in
- fun list ga m n r =
+ fun list ga m (n, r) =
unfold (op = /> 0w0)
(op - /> 0w1)
- (ga n o flip split r)
+ (fn i => ga (n, RNG.split i r))
(W.fromInt m)
end
end
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/random-gen.sig
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/random-gen.sig 2007-05-28 12:38:06 UTC (rev 5573)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/random-gen.sig 2007-05-28 14:27:20 UTC (rev 5574)
@@ -12,32 +12,40 @@
*)
signature RANDOM_GEN = sig
- include RNG
+ structure RNG : RNG
- type 'a gen = Int.t -> t -> 'a
+ type 'a dom and 'a cod
+ type 'a t = 'a dom -> 'a cod
- val lift : (t -> 'a) -> 'a gen
+ val generate : Int.t -> RNG.t -> 'a t -> 'a
- include MONAD_CORE where type 'a monad = 'a gen
+ val lift : (RNG.t -> 'a) -> 'a t
- structure Monad : MONAD where type 'a monad = 'a gen
+ include MONAD_CORE where type 'a monad = 'a t
- val promote : ('a -> 'b gen) -> ('a -> 'b) gen
+ structure Monad : MONAD where type 'a monad = 'a t
- val sized : (Int.t -> 'a gen) -> 'a gen
- val resize : Int.t UnOp.t -> 'a gen UnOp.t
+ val promote : ('a -> 'b t) -> ('a -> 'b) 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 Y : 'a t Tie.t
- val inRange : ('b Sq.t -> 'b gen) -> ('a, 'b) Iso.t -> 'a Sq.t -> 'a gen
+ val variant : Int.t -> 'a t UnOp.t
+ val mapUnOp : ('a, 'b) Iso.t -> 'b t UnOp.t -> 'a t UnOp.t
- 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 sized : (Int.t -> 'a t) -> 'a t
+ val resize : Int.t UnOp.t -> 'a t UnOp.t
- val bool : Bool.t gen
+ val elements : 'a List.t -> 'a t
+ val oneOf : 'a t List.t -> 'a t
+ val frequency : (Int.t * 'a t) List.t -> 'a t
- val list : 'a gen -> Int.t -> 'a List.t gen
+ val inRange : ('b Sq.t -> 'b t) -> ('a, 'b) Iso.t -> 'a Sq.t -> 'a t
+
+ val intInRange : Int.t Sq.t -> Int.t t
+ val realInRange : Real.t Sq.t -> Real.t t
+ val wordInRange : Word.t Sq.t -> Word.t t
+
+ val bool : Bool.t t
+
+ val list : 'a t -> Int.t -> 'a List.t t
end
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/ranqd1-gen.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/ranqd1-gen.sml 2007-05-28 12:38:06 UTC (rev 5573)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/ranqd1-gen.sml 2007-05-28 14:27:20 UTC (rev 5574)
@@ -10,7 +10,7 @@
structure RanQD1Gen :> sig
include RANDOM_GEN
- val make : Word32.t -> t
+ val make : Word32.t -> RNG.t
end = struct
structure G =
MkRandomGen
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml 2007-05-28 12:38:06 UTC (rev 5573)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml 2007-05-28 14:27:20 UTC (rev 5574)
@@ -319,7 +319,7 @@
(* RANDOM TESTING INTERFACE *)
- type law = (Bool.t Option.t * String.t List.t * Prettier.t List.t) G.gen
+ type law = (Bool.t Option.t * String.t List.t * Prettier.t List.t) G.t
local
fun mk field value = Fold.step0 (updCfg (U field value) $)
@@ -376,8 +376,9 @@
else if skipM <= skipN then
done "Arguments exhausted after" passN allTags
else
- case prop (size passN)
- (!rng before Ref.modify G.next rng) of
+ case G.generate (size passN)
+ (!rng before Ref.modify G.RNG.next rng)
+ prop of
(NONE, _, _) =>
lp passN (skipN + 1) allTags
| (SOME true, tags, _) =>
@@ -393,16 +394,19 @@
fun all t toProp =
G.>>= (arbitrary t,
- fn v => fn n => fn g =>
- try (fn () => toProp v n g,
- fn (r as SOME false, ts, msgs) =>
- (r, ts, named t "with" v :: msgs)
- | p => p,
- fn e => (SOME false, [],
- [named t "with" v,
- named exn "raised" e])))
+ fn v => fn ? =>
+ (G.>>= (toProp v,
+ fn (r as SOME false, ts, msgs) =>
+ G.return (r, ts, named t "with" v :: msgs)
+ | p =>
+ G.return p) ?
+ handle e =>
+ G.return (SOME false, [],
+ [named t "with" v,
+ named exn "raised" e]) ?))
+
fun that b = G.return (SOME b, [], [])
- fun skip _ _ = (NONE, [], [])
+ val skip = G.return (NONE, [], [])
fun classify tOpt p =
G.Monad.map (fn p as (r, ts, msg) =>
More information about the MLton-commit
mailing list