[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