[MLton-commit] r5330
Vesa Karvonen
vesak at mlton.org
Mon Feb 26 00:55:39 PST 2007
Using the (preliminary) Monad framework from the Extended Basis.
----------------------------------------------------------------------
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/qc-test-example.sml
U mltonlib/trunk/com/ssh/misc-util/unstable/random-gen.sig
U mltonlib/trunk/com/ssh/misc-util/unstable/sorted-list-test.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-02-26 07:43:31 UTC (rev 5329)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/arbitrary.sml 2007-02-26 08:55:20 UTC (rev 5330)
@@ -52,7 +52,7 @@
IN {gen = gen, cog = cog, typ = typ}
fun iso (IN {gen, cog, typ, ...}) (iso as (a2b, b2a)) =
- IN {gen = G.prj gen b2a,
+ IN {gen = G.map b2a gen,
cog = fn n => cog n o a2b,
typ = Typ.iso typ iso}
@@ -62,9 +62,9 @@
val bool = IN {gen = G.bool,
cog = const (G.split o (fn false => 0w1 | true => 0w2)),
typ = Typ.bool}
- val int = IN {gen = G.prj (G.lift G.value)
- (fn w => (* XXX result may not fit an Int.int *)
- W.toIntX (w - G.maxValue div 0w2)),
+ val int = IN {gen = G.map (fn w => (* XXX result may not fit an Int.int *)
+ W.toIntX (w - G.maxValue div 0w2))
+ (G.lift G.value),
cog = const (G.split o W.fromInt),
typ = Typ.int}
val word = IN {gen = G.lift G.value,
@@ -114,8 +114,8 @@
fun (IN {gen = aGen, cog = aCog, typ = aTyp, ...}) +`
(IN {gen = bGen, cog = bCog, typ = bTyp, ...}) = let
- val aGen = G.prj aGen INL
- val bGen = G.prj bGen INR
+ val aGen = G.map INL aGen
+ val bGen = G.map INR bGen
val halve = G.resize (op div /> 2)
val aGenHalf = G.frequency [(2, halve aGen), (1, bGen)]
val bGenHalf = G.frequency [(1, aGen), (2, halve bGen)]
@@ -155,7 +155,7 @@
fun vector a = iso (list a) Vector.isoList
- val char = IN {gen = G.prj (G.intInRange (0, Char.maxOrd)) chr,
+ val char = IN {gen = G.map chr (G.intInRange (0, Char.maxOrd)),
cog = const (G.split o W.fromInt o ord),
typ = Typ.char}
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/mk-random-gen.fun
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/mk-random-gen.fun 2007-02-26 07:43:31 UTC (rev 5329)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/mk-random-gen.fun 2007-02-26 08:55:20 UTC (rev 5330)
@@ -19,16 +19,23 @@
type 'a gen = Int.t -> t -> 'a
val lift = const
- fun return a _ _ = a
- fun (m >>= k) n r = k (m n (split 0w314 r)) n (split 0w159 r)
- fun prj gb b2a n = b2a o gb n
+
+ (*fun prj gb b2a n = b2a o gb n*)
+
+ 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))
+
+ 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 inRange bInRange (a2b, b2a) =
- flip prj b2a o bInRange o Pair.map (Sq.mk a2b)
+ map b2a o bInRange o Pair.map (Sq.mk a2b)
fun wordInRange (l, h) =
(D.assert 0 (fn () => l <= h)
@@ -40,8 +47,8 @@
fun intInRange (l, h) =
(D.assert 0 (fn () => l <= h)
- ; prj (inRange wordInRange (Iso.swap W.isoInt) (0, h - l))
- (op + /> l))
+ ; map (op + /> l)
+ (inRange wordInRange (Iso.swap W.isoInt) (0, h - l)))
local
val w2r = R.fromLargeInt o W.toLargeInt
@@ -55,7 +62,7 @@
fun elements xs =
let val xs = V.fromList xs
- in prj (intInRange (0, V.length xs)) (xs <\ V.sub)
+ in map (xs <\ V.sub) (intInRange (0, V.length xs))
end
fun oneOf gs = elements gs >>= id
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/qc-test-example.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/qc-test-example.sml 2007-02-26 07:43:31 UTC (rev 5329)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/qc-test-example.sml 2007-02-26 08:55:20 UTC (rev 5330)
@@ -32,7 +32,7 @@
let
val l = list int
in
- withGen (RanQD1Gen.prj (arbitrary l) stableSort) l
+ withGen (RanQD1Gen.map stableSort (arbitrary l)) l
end
(* Note that one can (of course) make local auxiliary definitions, like
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/random-gen.sig
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/random-gen.sig 2007-02-26 07:43:31 UTC (rev 5329)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/random-gen.sig 2007-02-26 08:55:20 UTC (rev 5330)
@@ -18,11 +18,8 @@
val lift : (t -> 'a) -> 'a gen
- val return : 'a -> 'a gen
- val >>= : 'a gen * ('a -> 'b gen) -> 'b gen
+ include MONAD where type 'a monad = 'a 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
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/sorted-list-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/sorted-list-test.sml 2007-02-26 07:43:31 UTC (rev 5329)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/sorted-list-test.sml 2007-02-26 08:55:20 UTC (rev 5330)
@@ -25,7 +25,7 @@
val sortedList = let
val l = list int
in
- fn #? => withGen (RanQD1Gen.prj (arbitrary l) (stableSort #?)) l
+ fn #? => withGen (RanQD1Gen.map (stableSort #?) (arbitrary l)) l
end
fun revPartition3Way c = let
Modified: mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml 2007-02-26 07:43:31 UTC (rev 5329)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/unit-test.sml 2007-02-26 08:55:20 UTC (rev 5330)
@@ -428,13 +428,13 @@
fun skip _ _ = (NONE, [], [])
fun classify tOpt p =
- G.prj p (fn p as (r, ts, msg) =>
+ G.map (fn p as (r, ts, msg) =>
case tOpt & r of
NONE & _ => p
| _ & NONE => p
- | SOME t & _ => (r, t::ts, msg))
+ | SOME t & _ => (r, t::ts, msg)) p
fun trivial b = classify (if b then SOME "trivial" else NONE)
fun collect t v p =
- G.prj p (fn (r, ts, msg) => (r, pretty NONE (layout t v)::ts, msg))
+ G.map (fn (r, ts, msg) => (r, pretty NONE (layout t v)::ts, msg)) p
end
More information about the MLton-commit
mailing list