[MLton-commit] r5628
Vesa Karvonen
vesak at mlton.org
Sat Jun 16 03:26:41 PDT 2007
Refactoring.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun
U mltonlib/trunk/com/ssh/generic/unstable/detail/join-generics.fun
U mltonlib/trunk/com/ssh/generic/unstable/detail/open-generic.fun
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun 2007-06-16 09:53:59 UTC (rev 5627)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun 2007-06-16 10:26:40 UTC (rev 5628)
@@ -4,6 +4,17 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
+functor CloseGenericRep (Arg : OPEN_GENERIC_REP) :>
+ CLOSED_GENERIC_REP
+ where type 'a t = ('a, Unit.t) Arg.t
+ where type 'a s = ('a, Unit.t) Arg.s
+ where type ('a, 'k) p = ('a, 'k, Unit.t) Arg.p =
+struct
+ type 'a t = ('a, Unit.t) Arg.t
+ type 'a s = ('a, Unit.t) Arg.s
+ type ('a, 'k) p = ('a, 'k, Unit.t) Arg.p
+end
+
functor CloseGeneric (Arg : OPEN_GENERIC) :>
CLOSED_GENERIC
where type 'a Rep.t = ('a, Unit.t) Arg.Rep.t
@@ -14,11 +25,7 @@
open TopLevel
(* SML/NJ workaround --> *)
- structure Rep : CLOSED_GENERIC_REP = struct
- type 'a t = ('a, Unit.t) Arg.Rep.t
- type 'a s = ('a, Unit.t) Arg.Rep.s
- type ('a, 'k) p = ('a, 'k, Unit.t) Arg.Rep.p
- end
+ structure Rep = CloseGenericRep (Arg.Rep)
fun morph m = m (const ignore)
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/join-generics.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/join-generics.fun 2007-06-16 09:53:59 UTC (rev 5627)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/join-generics.fun 2007-06-16 10:26:40 UTC (rev 5628)
@@ -4,6 +4,35 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
+signature JOIN_GENERIC_REPS_DOM = sig
+ structure Outer : OPEN_GENERIC_REP
+ structure Inner : OPEN_GENERIC_REP
+end
+
+functor JoinGenericReps (Arg : JOIN_GENERIC_REPS_DOM) :
+ OPEN_GENERIC_REP
+ where type ('a, 'x) t =
+ ('a, ('a, 'x) Arg.Inner.t) Arg.Outer.t
+ where type ('a, 'x) s =
+ ('a, ('a, 'x) Arg.Inner.s) Arg.Outer.s
+ where type ('a, 'k, 'x) p =
+ ('a, 'k, ('a, 'k, 'x) Arg.Inner.p) Arg.Outer.p =
+struct
+ open Arg
+
+ type ('a, 'x) t = ('a, ('a, 'x) Inner.t) Outer.t
+ fun getT ? = Inner.getT (Outer.getT ?)
+ fun mapT ? = Outer.mapT (Inner.mapT ?)
+
+ type ('a, 'x) s = ('a, ('a, 'x) Inner.s) Outer.s
+ fun getS ? = Inner.getS (Outer.getS ?)
+ fun mapS ? = Outer.mapS (Inner.mapS ?)
+
+ type ('a, 'k, 'x) p = ('a, 'k, ('a, 'k, 'x) Inner.p) Outer.p
+ fun getP ? = Inner.getP (Outer.getP ?)
+ fun mapP ? = Outer.mapP (Inner.mapP ?)
+end
+
functor JoinGenerics (Arg : JOIN_GENERICS_DOM) :>
OPEN_GENERIC
where type ('a, 'x) Rep.t =
@@ -14,21 +43,8 @@
('a, 'k, ('a, 'k, 'x) Arg.Inner.Rep.p) Arg.Outer.Rep.p =
struct
open Arg
-
- structure Rep : OPEN_GENERIC_REP = struct
- type ('a, 'x) t = ('a, ('a, 'x) Inner.Rep.t) Outer.Rep.t
- fun getT ? = Inner.Rep.getT (Outer.Rep.getT ?)
- fun mapT ? = Outer.Rep.mapT (Inner.Rep.mapT ?)
-
- type ('a, 'x) s = ('a, ('a, 'x) Inner.Rep.s) Outer.Rep.s
- fun getS ? = Inner.Rep.getS (Outer.Rep.getS ?)
- fun mapS ? = Outer.Rep.mapS (Inner.Rep.mapS ?)
-
- type ('a, 'k, 'x) p = ('a, 'k, ('a, 'k, 'x) Inner.Rep.p) Outer.Rep.p
- fun getP ? = Inner.Rep.getP (Outer.Rep.getP ?)
- fun mapP ? = Outer.Rep.mapP (Inner.Rep.mapP ?)
- end
-
+ structure Rep = JoinGenericReps (structure Outer = Outer.Rep
+ structure Inner = Inner.Rep)
fun iso ? = Outer.iso (Inner.iso ?)
fun isoProduct ? = Outer.isoProduct (Inner.isoProduct ?)
fun isoSum ? = Outer.isoSum (Inner.isoSum ?)
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/open-generic.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/open-generic.fun 2007-06-16 09:53:59 UTC (rev 5627)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/open-generic.fun 2007-06-16 10:26:40 UTC (rev 5628)
@@ -4,6 +4,28 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
+functor OpenGenericRep (Arg : CLOSED_GENERIC_REP) :
+ OPEN_GENERIC_REP
+ where type ('a, 'x) t = 'a Arg.t * 'x
+ where type ('a, 'x) s = 'a Arg.s * 'x
+ where type ('a, 'k, 'x) p = ('a, 'k) Arg.p * 'x =
+struct
+ val get = Pair.snd
+ fun map f = Pair.map (Fn.id, f)
+
+ type ('a, 'x) t = 'a Arg.t * 'x
+ val getT = get
+ val mapT = map
+
+ type ('a, 'x) s = 'a Arg.s * 'x
+ val getS = get
+ val mapS = map
+
+ type ('a, 'k, 'x) p = ('a, 'k) Arg.p * 'x
+ val getP = get
+ val mapP = map
+end
+
functor OpenGeneric (Arg : CLOSED_GENERIC) :>
OPEN_GENERIC
where type ('a, 'x) Rep.t = 'a Arg.Rep.t * 'x
@@ -14,23 +36,8 @@
open TopLevel
(* SML/NJ workaround --> *)
- structure Rep : OPEN_GENERIC_REP = struct
- val get = Pair.snd
- fun map f = Pair.map (id, f)
+ structure Rep = OpenGenericRep (Arg.Rep)
- type ('a, 'x) t = 'a Arg.Rep.t * 'x
- val getT = get
- val mapT = map
-
- type ('a, 'x) s = 'a Arg.Rep.s * 'x
- val getS = get
- val mapS = map
-
- type ('a, 'k, 'x) p = ('a, 'k) Arg.Rep.p * 'x
- val getP = get
- val mapP = map
- end
-
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
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-06-16 09:53:59 UTC (rev 5627)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-06-16 10:26:40 UTC (rev 5628)
@@ -24,26 +24,15 @@
structure G = RandomGen and I = Int and R = Real and W = Word
- datatype 'a u = IN of {gen : 'a G.t, cog : 'a -> Univ.t G.t UnOp.t}
+ datatype 'a t = IN of {gen : 'a G.t, cog : 'a -> Univ.t G.t UnOp.t}
fun out (IN r) = r
- structure Rep : OPEN_GENERIC_REP = struct
- fun get get = Pair.snd o get
- fun map map f = map (Pair.map (id, f))
+ structure Rep =
+ JoinGenericReps
+ (structure Outer = Arg.Rep
+ structure Inner =
+ OpenGenericRep (MkClosedGenericRep (type 'a t = 'a t)))
- type ('a, 'x) t = ('a, 'a u * 'x) Arg.Rep.t
- fun getT ? = get Arg.Rep.getT ?
- fun mapT ? = map Arg.Rep.mapT ?
-
- type ('a, 'x) s = ('a, 'a u * 'x) Arg.Rep.s
- fun getS ? = get Arg.Rep.getS ?
- fun mapS ? = map Arg.Rep.mapS ?
-
- type ('a, 'k, 'x) p = ('a, 'k, 'a u * 'x) Arg.Rep.p
- fun getP ? = get Arg.Rep.getP ?
- fun mapP ? = map Arg.Rep.mapP ?
- end
-
structure Arbitrary = Rep
fun universally ? = G.mapUnOp (Univ.newIso ()) ?
More information about the MLton-commit
mailing list