[MLton-commit] r5635
Vesa Karvonen
vesak at mlton.org
Sat Jun 16 10:35:44 PDT 2007
Factored the definition of open generic functions.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/generics-util.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/open-generic.fun
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/generics-util.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/generics-util.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/generics-util.sml 2007-06-16 16:12:34 UTC (rev 5634)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/generics-util.sml 2007-06-16 17:35:43 UTC (rev 5635)
@@ -13,6 +13,23 @@
fun failCat ss = fail (concat ss)
fun failExn e = failCat ["unregistered exn ", `e]
fun failExnSq (l, r) = failCat ["unregistered exns ", `l, " and ", `r]
+
+ fun op0 outer t x = outer (t, x)
+ fun op1 outer f g = outer (Pair.map (f, g))
+ fun op2 outer f g = outer (Pair.map (f, g) o Pair.swizzle)
+
+ fun t outer t2p x2y = outer (Pair.map (t2p, x2y))
+ fun r outer lt2p lx2y = outer (Pair.map o Pair.map (lt2p, lx2y) o Sq.mk)
+
+ fun c0 outer l2s l2x = outer (Pair.map (l2s, l2x) o Sq.mk)
+ fun c1 outer lt2s lx2y = outer (Pair.map o Pair.map (lt2s, lx2y) o Sq.mk)
+
+ fun y outer x y = outer (Tie.tuple2 (x, y))
+
+ fun morph outer iso' f = outer (fn (a, x) => fn i => (iso' a i, f x i))
+
+ fun re outer ex ey =
+ outer (fn (x, y) => fn e => (ex x e : Unit.t ; ey y e : Unit.t))
end
functor MkClosedGenericRep (type 'a t) : CLOSED_GENERIC_REP = struct
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/open-generic.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/open-generic.fun 2007-06-16 16:12:34 UTC (rev 5634)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/open-generic.fun 2007-06-16 17:35:43 UTC (rev 5635)
@@ -38,43 +38,43 @@
structure Rep = OpenGenericRep (Arg.Rep)
- fun unary arg fx = Pair.map (arg, fx)
- fun binary arg fxy x = Pair.map (arg x, fxy x)
- fun binop arg fxy = Pair.map (arg, fxy) o Pair.swizzle
- fun morph arg f (a, x) aIb = (arg a aIb, f x aIb)
+ fun op0 ? = GenericsUtil.op0 id ?
+ fun op1 ? = GenericsUtil.op1 id ?
+ fun op2 ? = GenericsUtil.op2 id ?
+ fun morph ? = GenericsUtil.morph id ?
fun iso ? = morph Arg.iso ?
fun isoProduct ? = morph Arg.isoProduct ?
fun isoSum ? = morph Arg.isoSum ?
- fun op *` ? = binop Arg.*` ?
- fun T ? = unary Arg.T ?
- fun R ? = binary Arg.R ?
- fun tuple ? = unary Arg.tuple ?
- fun record ? = unary Arg.record ?
- fun op +` ? = binop Arg.+` ?
- fun C0 fc c = (Arg.C0 c, fc c)
- fun C1 ? = binary Arg.C1 ?
- fun data ? = unary Arg.data ?
- fun unit x = (Arg.unit, x)
- fun Y y = Tie.tuple2 (Arg.Y, y)
- fun op --> ? = binop Arg.--> ?
- fun exn x = (Arg.exn, x)
- fun regExn x2ef (a, x) = Pair.app (Arg.regExn a, x2ef x) o Sq.mk
- fun array ? = unary Arg.array ?
- fun refc ? = unary Arg.refc ?
- fun vector ? = unary Arg.vector ?
- fun largeInt x = (Arg.largeInt, x)
- fun largeReal x = (Arg.largeReal, x)
- fun largeWord x = (Arg.largeWord, x)
- fun word8 x = (Arg.word8, x)
-(* fun word16 x = (Arg.word16, x) (* Word16 not provided by SML/NJ *) *)
- fun word32 x = (Arg.word32, x)
- fun word64 x = (Arg.word64, x)
- fun list ? = unary Arg.list ?
- fun bool x = (Arg.bool, x)
- fun char x = (Arg.char, x)
- fun int x = (Arg.int, x)
- fun real x = (Arg.real, x)
- fun string x = (Arg.string, x)
- fun word x = (Arg.word, x)
+ fun op *` ? = op2 Arg.*` ?
+ fun T ? = GenericsUtil.t id Arg.T ?
+ fun R ? = GenericsUtil.r id Arg.R ?
+ fun tuple ? = op1 Arg.tuple ?
+ fun record ? = op1 Arg.record ?
+ fun op +` ? = op2 Arg.+` ?
+ fun C0 ? = GenericsUtil.c0 id Arg.C0 ?
+ fun C1 ? = GenericsUtil.c1 id Arg.C1 ?
+ fun data ? = op1 Arg.data ?
+ fun unit ? = op0 Arg.unit ?
+ fun Y ? = GenericsUtil.y id Arg.Y ?
+ fun op --> ? = op2 Arg.--> ?
+ fun exn ? = op0 Arg.exn ?
+ fun regExn ? = GenericsUtil.re id Arg.regExn ?
+ fun array ? = op1 Arg.array ?
+ fun refc ? = op1 Arg.refc ?
+ fun vector ? = op1 Arg.vector ?
+ fun largeInt ? = op0 Arg.largeInt ?
+ fun largeReal ? = op0 Arg.largeReal ?
+ fun largeWord ? = op0 Arg.largeWord ?
+ fun word8 ? = op0 Arg.word8 ?
+(* fun word16 x = op0 Arg.word16 ? (* Word16 not provided by SML/NJ *) *)
+ fun word32 ? = op0 Arg.word32 ?
+ fun word64 ? = op0 Arg.word64 ?
+ fun list ? = op1 Arg.list ?
+ fun bool ? = op0 Arg.bool ?
+ fun char ? = op0 Arg.char ?
+ fun int ? = op0 Arg.int ?
+ fun real ? = op0 Arg.real ?
+ fun string ? = op0 Arg.string ?
+ fun word ? = op0 Arg.word ?
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-06-16 16:12:34 UTC (rev 5634)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-06-16 17:35:43 UTC (rev 5635)
@@ -20,6 +20,8 @@
infixr 0 -->
(* SML/NJ workaround --> *)
+ open GenericsUtil
+
structure RandomGen = Arg.RandomGen
structure G = RandomGen and I = Int and R = Real and W = Word
@@ -49,70 +51,63 @@
fun iso' (IN {gen, cog}) (a2b, b2a) =
IN {gen = map b2a gen, cog = cog o a2b}
- fun morph outer f = outer (fn (a, x) => fn i => (iso' a i, f x i))
- fun nullary outer t x = outer (t, x)
- fun binop outer f g = outer (Pair.map (f, g) o Pair.swizzle)
- fun unary outer f g = outer (Pair.map (f, g))
+ fun iso ? = morph Arg.iso iso' ?
+ fun isoProduct ? = morph Arg.isoProduct iso' ?
+ fun isoSum ? = morph Arg.isoSum iso' ?
- fun iso ? = morph Arg.iso ?
- fun isoProduct ? = morph Arg.isoProduct ?
- fun isoSum ? = morph Arg.isoSum ?
-
val unit' = IN {gen = G.return (), cog = const (G.variant 0)}
- fun unit ? = nullary Arg.unit unit' ?
- fun bool ? =
- nullary Arg.bool (IN {gen = G.bool, cog = G.variant o Bool.toInt}) ?
+ fun unit ? = op0 Arg.unit unit' ?
+ fun bool ? = op0 Arg.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}
- fun int ? = nullary Arg.int int' ?
+ fun int ? = op0 Arg.int int' ?
val word' = IN {gen = G.lift G.RNG.value, cog = G.variant o W.toIntX}
- fun word ? = nullary Arg.word word' ?
+ fun word ? = op0 Arg.word word' ?
- fun Y y = Arg.Y (let open Tie in iso (G.Y *` function *` y) end
- (fn (IN {gen = a, cog = b}, c) => a & b & c,
- fn a & b & c => (IN {gen = a, cog = b}, c)))
+ fun Y ? = y Arg.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 *` ? = binop Arg.*`
- (fn (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 *` ? = op2 Arg.*`
+ (fn (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 +` xy2z (a, b) =
- binop Arg.+`
- (fn (IN {gen = aGen, cog = aCog}, IN {gen = bGen, cog = bCog}) =>
- let
- val aGen = map INL aGen
- val bGen = map INR bGen
- val gen = G.frequency [(Arg.numAlts a, aGen),
- (Arg.numAlts b, bGen)]
- val gen0 =
- case Arg.hasBaseCase a & Arg.hasBaseCase b of
- true & false => aGen
- | false & true => bGen
- | _ => gen
- in
- IN {gen = G.sized (fn 0 => gen0 | _ => gen),
- cog = fn INL a => G.variant 0 o aCog a
- | INR b => G.variant 1 o bCog b}
- end) xy2z (a, b)
+ op2 Arg.+`
+ (fn (IN {gen = aGen, cog = aCog}, IN {gen = bGen, cog = bCog}) => let
+ val aGen = map INL aGen
+ val bGen = map INR bGen
+ val gen = G.frequency [(Arg.numAlts a, aGen),
+ (Arg.numAlts b, bGen)]
+ val gen0 =
+ case Arg.hasBaseCase a & Arg.hasBaseCase b of
+ true & false => aGen
+ | false & true => bGen
+ | _ => gen
+ in
+ IN {gen = G.sized (fn 0 => gen0 | _ => gen),
+ cog = fn INL a => G.variant 0 o aCog a
+ | INR b => G.variant 1 o bCog b}
+ end) xy2z (a, b)
fun op --> ? =
- binop Arg.-->
- (fn (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)}) ?
+ op2 Arg.-->
+ (fn (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 exn ? =
- nullary Arg.exn (IN {gen = G.return Empty,
- cog = failing "Arbitrary.exn unsupported"}) ?
+ op0 Arg.exn (IN {gen = G.return Empty,
+ cog = failing "Arbitrary.exn unsupported"}) ?
- fun regExn ef = Arg.regExn (ef o Pair.snd)
+ fun regExn ? = re Arg.regExn (const ignore) ?
fun list' (IN {gen = xGen, cog = xCog}) = let
val xsGen = G.sized (0 <\ G.intInRange) >>= G.list xGen
@@ -122,31 +117,31 @@
in
IN {gen = xsGen, cog = xsCog}
end
- fun list ? = unary Arg.list list' ?
+ fun list ? = op1 Arg.list list' ?
val char' = IN {gen = map chr (G.intInRange (0, Char.maxOrd)),
cog = G.variant o ord}
- fun char ? = nullary Arg.char char' ?
+ fun char ? = op0 Arg.char char' ?
val string' as IN {cog = stringCog', ...} = iso' (list' char') String.isoList
- fun string ? = nullary Arg.string string' ?
+ fun string ? = op0 Arg.string string' ?
- fun array ? = unary Arg.array (fn a => iso' (list' a) Array.isoList) ?
- fun refc ? = unary Arg.refc (fn a => iso' a (!, ref)) ?
- fun vector ? = unary Arg.vector (fn a => iso' (list' a) Vector.isoList) ?
+ fun array ? = op1 Arg.array (fn a => iso' (list' a) Array.isoList) ?
+ fun refc ? = op1 Arg.refc (fn a => iso' a (!, ref)) ?
+ fun vector ? = op1 Arg.vector (fn a => iso' (list' a) Vector.isoList) ?
- fun largeInt ? = nullary Arg.largeInt (iso' int' (Iso.swap I.isoLarge)) ?
- fun largeWord ? = nullary Arg.largeWord (iso' word' (Iso.swap W.isoLarge)) ?
+ fun largeInt ? = op0 Arg.largeInt (iso' int' (Iso.swap I.isoLarge)) ?
+ fun largeWord ? = op0 Arg.largeWord (iso' word' (Iso.swap W.isoLarge)) ?
val real' = IN {gen = G.sized ((fn r => G.realInRange (~r, r)) o real),
cog = stringCog' o R.toString} (* XXX Real cog *)
- fun real ? = nullary Arg.real real' ?
+ fun real ? = op0 Arg.real real' ?
fun largeReal ? =
- nullary Arg.largeReal
- (iso' real' (Iso.swap (R.isoLarge IEEEReal.TO_NEAREST))) ?
+ op0 Arg.largeReal
+ (iso' real' (Iso.swap (R.isoLarge IEEEReal.TO_NEAREST))) ?
local
fun mk outer large =
- nullary outer (iso' word' (Iso.<--> (Iso.swap W.isoLarge, large)))
+ op0 outer (iso' word' (Iso.<--> (Iso.swap W.isoLarge, large)))
in
fun word8 ? = mk Arg.word8 Word8.isoLarge ?
(* fun word16 ? = mk Arg.word16 Word16.isoLarge ?
@@ -157,11 +152,11 @@
(* Trivialities *)
- fun T ? = unary Arg.T id ?
- fun R f = Arg.R (fn l => Pair.map (id, f l))
- fun tuple ? = unary Arg.tuple id ?
- fun record ? = unary Arg.record id ?
- fun C0 f = Arg.C0 (fn l => (unit', f l))
- fun C1 f = Arg.C1 (fn l => Pair.map (id, f l))
- fun data ? = unary Arg.data id ?
+ fun T ? = t Arg.T id ?
+ fun R ? = r Arg.R (const id) ?
+ fun tuple ? = op1 Arg.tuple id ?
+ fun record ? = op1 Arg.record id ?
+ fun C0 ? = c0 Arg.C0 (const unit') ?
+ fun C1 ? = c1 Arg.C1 (const id) ?
+ fun data ? = op1 Arg.data id ?
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-06-16 16:12:34 UTC (rev 5634)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2007-06-16 17:35:43 UTC (rev 5635)
@@ -20,6 +20,8 @@
infixr 0 -->
(* SML/NJ workaround --> *)
+ open GenericsUtil
+
structure W = Word
type 'a t = 'a -> {maxWidth : Int.t, maxDepth : Int.t} -> Word.t UnOp.t
@@ -47,17 +49,12 @@
fun iso' bH (a2b, _) = bH o a2b
- fun morph outer f = outer (fn (a, x) => fn i => (iso' a i, f x i))
- fun nullary outer t x = outer (t, x)
- fun bop outer f g = outer (Pair.map (f, g) o Pair.swizzle)
- fun uop outer f g = outer (Pair.map (f, g))
+ fun iso ? = morph Arg.iso iso' ?
+ fun isoProduct ? = morph Arg.isoProduct iso' ?
+ fun isoSum ? = morph Arg.isoSum iso' ?
- fun iso ? = morph Arg.iso ?
- fun isoProduct ? = morph Arg.isoProduct ?
- fun isoSum ? = morph Arg.isoSum ?
-
fun op *` xy2z (aT, bT) =
- bop Arg.*`
+ op2 Arg.*`
(fn (aH, bH) =>
fn a & b => fn {maxWidth, maxDepth} => let
val aN = Arg.numElems aT
@@ -71,22 +68,22 @@
xy2z (aT, bT)
fun op +` ? =
- bop Arg.+`
+ op2 Arg.+`
(Sum.sum o
Pair.map (HC.withConst 0wx96BA232,
HC.withConst 0wxCF2465)) ?
- fun Y y = Arg.Y (Tie.tuple2 (Tie.function, y))
+ fun Y ? = y Arg.Y Tie.function ?
- fun op --> ? = bop Arg.--> (fn _ => failing "Hash.--> unsupported") ?
+ fun op --> ? = op2 Arg.--> (fn _ => failing "Hash.--> unsupported") ?
- fun exn ? = nullary Arg.exn (failing "Hash.exn unsupported") ?
- fun regExn ef = Arg.regExn (ef o Pair.snd)
+ fun exn ? = op0 Arg.exn (failing "Hash.exn unsupported") ?
+ fun regExn ? = re Arg.regExn (const ignore) ?
- fun refc ? = uop Arg.refc (HC.withConst 0wx178A2346 o HC.map !) ?
+ fun refc ? = op1 Arg.refc (HC.withConst 0wx178A2346 o HC.map !) ?
fun list ? =
- uop Arg.list
+ op1 Arg.list
(fn hX => fn xs => fn {maxWidth, maxDepth} => fn h => let
val m = Int.quot (maxWidth, 2)
fun len n [] = n
@@ -115,20 +112,20 @@
end
end
- fun array ? = uop Arg.array (hashSeq Array.length Array.sub) ?
- fun vector ? = uop Arg.vector (hashSeq Vector.length Vector.sub) ?
+ fun array ? = op1 Arg.array (hashSeq Array.length Array.sub) ?
+ fun vector ? = op1 Arg.vector (hashSeq Vector.length Vector.sub) ?
val char' = HC.lift (Word.fromInt o ord)
- fun char ? = nullary Arg.char char' ?
+ fun char ? = op0 Arg.char char' ?
val string' = hashSeq String.length String.sub char'
- fun string ? = nullary Arg.string string' ?
+ fun string ? = op0 Arg.string string' ?
val unit' = HC.lift (Thunk.mk 0wx2F785)
- fun unit ? = nullary Arg.unit unit' ?
+ fun unit ? = op0 Arg.unit unit' ?
local
- fun mk outer toWord ? = nullary outer (HC.lift toWord) ?
+ fun mk outer toWord ? = op0 outer (HC.lift toWord) ?
in
fun largeInt ? =
mk Arg.largeInt
@@ -147,26 +144,26 @@
end
(* XXX SML/NJ does not provide a function to convert a real to bits *)
- fun largeReal ? = nullary Arg.largeReal (HC.map LargeReal.toString string') ?
- fun real ? = nullary Arg.real (HC.map Real.toString string') ?
+ fun largeReal ? = op0 Arg.largeReal (HC.map LargeReal.toString string') ?
+ fun real ? = op0 Arg.real (HC.map Real.toString string') ?
(* Trivialities *)
- fun T ? = uop Arg.T id ?
- fun R f = Arg.R (fn l => Pair.map (id, f l))
+ fun T ? = t Arg.T id ?
+ fun R ? = r Arg.R (const id) ?
local
fun width h : 'a t =
fn a => fn p => if #maxWidth p = 0 then id else h a p
in
- fun tuple ? = uop Arg.tuple width ?
- fun record ? = uop Arg.record width ?
+ fun tuple ? = op1 Arg.tuple width ?
+ fun record ? = op1 Arg.record width ?
end
- fun C0 f = Arg.C0 (fn l => (unit', f l))
- fun C1 f = Arg.C1 (fn l => Pair.map (id, f l))
+ fun C0 ? = c0 Arg.C0 (const unit') ?
+ fun C1 ? = c1 Arg.C1 (const id) ?
fun data ? =
- uop Arg.data
+ op1 Arg.data
(fn h => fn a => fn {maxDepth, maxWidth} =>
if maxDepth = 0 then id
else h a {maxDepth = maxDepth - 1,
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/generics-util.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/generics-util.sig 2007-06-16 16:12:34 UTC (rev 5634)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/generics-util.sig 2007-06-16 17:35:43 UTC (rev 5635)
@@ -8,6 +8,33 @@
* Signature for utilities for defining generic values.
*)
signature GENERICS_UTIL = sig
+ (** == For Defining Closed Generic Functions == *)
+
val failExn : Exn.t -> 'a
val failExnSq : Exn.t Sq.t -> 'a
+
+ (** == For Defining Open Generic Functions == *)
+
+ val op0 : ('a * 'b -> 'c) -> 'a -> 'b -> 'c
+ val op1 : ((('a, 'b) Pair.t -> ('c, 'd) Pair.t) -> 'e)
+ -> ('a -> 'c) -> ('b -> 'd) -> 'e
+ val op2 : ((('a, 'b) Pair.t * ('c, 'd) Pair.t -> ('e, 'f) Pair.t) -> 'g)
+ -> ('a * 'c -> 'e) -> ('b * 'd -> 'f) -> 'g
+
+ val t : ((('a, 'b) Pair.t -> ('c, 'd) Pair.t) -> 'e)
+ -> ('a -> 'c) -> ('b -> 'd) -> 'e
+ val r : (('a -> ('b, 'c) Pair.t -> ('d, 'e) Pair.t) -> 'f)
+ -> ('a -> 'b -> 'd) -> ('a -> 'c -> 'e) -> 'f
+
+ val c0 : (('a -> ('b, 'c) Pair.t) -> 'd) -> ('a -> 'b) -> ('a -> 'c) -> 'd
+ val c1 : (('a -> ('b, 'c) Pair.t -> ('d, 'e) Pair.t) -> 'f)
+ -> ('a -> 'b -> 'd) -> ('a -> 'c -> 'e) -> 'f
+
+ val y : (('a * 'b) Tie.t -> 'c) -> 'a Tie.t -> 'b Tie.t -> 'c
+
+ val morph : (('a * 'b -> 'c -> 'd * 'e) -> 'f)
+ -> ('a -> 'c -> 'd) -> ('b -> 'c -> 'e) -> 'f
+
+ val re : (('a * 'b -> 'c -> Unit.t) -> 'd)
+ -> ('a -> 'c -> Unit.t) -> ('b -> 'c -> Unit.t) -> 'd
end
More information about the MLton-commit
mailing list