[MLton-commit] r5723
Vesa Karvonen
vesak at mlton.org
Wed Jul 4 02:22:44 PDT 2007
Just minor cleanups.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-07-04 09:21:49 UTC (rev 5722)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-07-04 09:22:44 UTC (rev 5723)
@@ -43,18 +43,22 @@
structure Layered = LayerDepGeneric
(structure Outer = Arg and Result = Arbitrary
+
fun iso' (IN {gen, cog}) (a2b, b2a) =
IN {gen = map b2a gen, cog = cog o a2b}
- fun iso ? = iso' (getT ?)
+
+ fun iso ? = iso' (getT ?)
fun isoProduct ? = iso' (getP ?)
- fun isoSum ? = iso' (getS ?)
+ fun isoSum ? = iso' (getS ?)
+
fun op *`` (IN {gen = aGen, cog = aCog}, IN {gen = bGen, cog = bCog}) =
IN {gen = G.Monad.>>& (aGen, bGen), cog = fn a & b => aCog a o bCog b}
fun op *` (a, b) = op *`` (getP a, getP b)
- val T = getT
- fun R _ = getT
- val tuple = getP
+ val T = getT
+ fun R _ = getT
+ val tuple = getP
val record = getP
+
fun op +` (aS, bS) = let
val aGen = map INL (genS aS)
val bGen = map INR (genS bS)
@@ -74,17 +78,21 @@
fun C0 _ = unit
fun C1 _ = getT
val data = getS
+
fun Y ? = let open Tie in iso (G.Y *` function) end
(fn IN {gen = a, cog = b} => a & b,
fn a & b => IN {gen = a, cog = b}) ?
+
fun op -->` (IN {gen = aGen, cog = aCog}, IN {gen = bGen, cog = bCog}) =
IN {gen = G.promote (fn a => universally (aCog a) bGen),
cog = fn f => fn g =>
aGen >>= (fn a => universally (bCog (f a)) g)}
fun op --> (a, b) = op -->` (getT a, getT b)
+
val exn = IN {gen = G.return Empty,
cog = failing "Arbitrary.exn unsupported"}
fun regExn _ _ = ()
+
fun list' (IN {gen = xGen, cog = xCog}) = let
val xsGen = G.sized (0 <\ G.intInRange) >>= G.list xGen
fun xsCog [] = G.variant 0
@@ -94,31 +102,37 @@
IN {gen = xsGen, cog = xsCog}
end
fun list ? = list' (getT ?)
- fun array a = iso' (list a) Array.isoList
+
+ fun array a = iso' (list a) Array.isoList
+ fun vector a = iso' (list a) Vector.isoList
+
fun refc a = iso' (getT a) (!, ref)
- fun vector a = iso' (list a) Vector.isoList
+
+ val char = IN {gen = map chr (G.intInRange (0, Char.maxOrd)),
+ cog = G.variant o ord}
+ val string as IN {cog = stringCog, ...} = iso' (list' char) String.isoList
+
+ val bool = IN {gen = G.bool, cog = G.variant o Bool.toInt}
+
val int = IN {gen = map (fn w => W.toIntX (w - G.RNG.maxValue div 0w2))
(* XXX result may not fit an Int.t *)
(G.lift G.RNG.value),
cog = G.variant}
- val largeInt = iso' int (Iso.swap I.isoLarge)
val word = IN {gen = G.lift G.RNG.value, cog = G.variant o W.toIntX}
+ val real = IN {gen = G.sized ((fn r => G.realInRange (~r, r)) o real),
+ cog = stringCog o R.toString} (* XXX Real cog *)
+
+ val largeInt = iso' int (Iso.swap I.isoLarge)
val largeWord = iso' word (Iso.swap W.isoLarge)
+ val largeReal = iso' real (Iso.swap (R.isoLarge IEEEReal.TO_NEAREST))
+
local
fun mk large = iso' word (Iso.<--> (Iso.swap W.isoLarge, large))
in
val word8 = mk Word8.isoLarge
- (* val word16 = mk Word16.isoLarge (* Word16 not provided by SML/NJ *) *)
val word32 = mk Word32.isoLarge
val word64 = mk Word64.isoLarge
- end
- val bool = IN {gen = G.bool, cog = G.variant o Bool.toInt}
- val char = IN {gen = map chr (G.intInRange (0, Char.maxOrd)),
- cog = G.variant o ord}
- val string as IN {cog = stringCog, ...} = iso' (list' char) String.isoList
- val real = IN {gen = G.sized ((fn r => G.realInRange (~r, r)) o real),
- cog = stringCog o R.toString} (* XXX Real cog *)
- val largeReal = iso' real (Iso.swap (R.isoLarge IEEEReal.TO_NEAREST)))
+ end)
open Layered
end
More information about the MLton-commit
mailing list