[MLton-commit] r5640
Vesa Karvonen
vesak at mlton.org
Sun Jun 17 05:54:36 PDT 2007
Using smarter layering.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml 2007-06-17 12:33:43 UTC (rev 5639)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml 2007-06-17 12:54:36 UTC (rev 5640)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-local
+functor WithDummy (Arg : OPEN_GENERIC) : DUMMY_GENERIC = struct
(* <-- SML/NJ workaround *)
open TopLevel
infix 7 *`
@@ -12,9 +12,20 @@
infix 0 &
(* SML/NJ workaround --> *)
- structure Dummy : CLOSED_GENERIC = struct
- structure Rep = MkClosedGenericRep (Thunk)
+ structure Dummy =
+ LayerGenericRep (structure Outer = Arg.Rep
+ structure Closed = MkClosedGenericRep (Thunk))
+ open Dummy.This
+
+ exception Dummy of Exn.t
+
+ fun dummy a = getT a () handle e => raise Dummy e
+ fun withDummy v = mapT (const (fn () => valOf v))
+
+ structure Layered = LayerGeneric
+ (structure Outer = Arg and Result = Dummy and Rep = Dummy.Closed
+
fun iso b (_, b2a) = b2a o b
fun a *` b = fn () => a () & b ()
@@ -63,25 +74,7 @@
fun C0 _ = unit
fun C1 _ = id
- val data = id
- end
+ val data = id)
- structure Dummy : OPENED_GENERIC = OpenGeneric (Dummy)
-in
- structure Dummy :> DUMMY_GENERIC = struct
- open Dummy
- structure Dummy = Rep
- exception Dummy of Exn.t
- val dummy : ('a, 'x) Dummy.t -> 'a =
- fn a => This.getT a () handle e => raise Dummy e
- fun withDummy v = This.mapT (const (fn () => valOf v))
- end
+ open Layered
end
-
-functor WithDummy (Arg : OPEN_GENERIC) : DUMMY_GENERIC = struct
- structure Joined = JoinGenerics (structure Outer = Arg and Inner = Dummy)
- open Dummy Joined
- structure Dummy = Rep
- val dummy = fn ? => dummy (Arg.Rep.getT ?)
- val withDummy = fn v => fn ? => Arg.Rep.mapT (withDummy v) ?
-end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-06-17 12:33:43 UTC (rev 5639)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-06-17 12:54:36 UTC (rev 5640)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-local
+functor WithEq (Arg : OPEN_GENERIC) : EQ_GENERIC = struct
(* <-- SML/NJ workaround *)
open TopLevel
infix 7 *`
@@ -12,9 +12,18 @@
infix 0 &
(* SML/NJ workaround --> *)
- structure Eq : CLOSED_GENERIC = struct
- structure Rep = MkClosedGenericRep (BinPr)
+ structure Eq =
+ LayerGenericRep (structure Outer = Arg.Rep
+ structure Closed = MkClosedGenericRep (BinPr))
+ open Eq.This
+
+ val eq = getT
+ fun notEq ? = negate (getT ?)
+
+ structure Layered = LayerGeneric
+ (structure Outer = Arg and Result = Eq and Rep = Eq.Closed
+
fun iso b (a2b, _) = b o Pair.map (Sq.mk a2b)
val op *` = Product.equal
@@ -71,24 +80,7 @@
fun C0 _ = unit
fun C1 _ = id
- val data = id
- end
+ val data = id)
- structure Eq : OPENED_GENERIC = OpenGeneric (Eq)
-in
- structure Eq :> EQ_GENERIC = struct
- open Eq
- structure Eq = Rep
- val eq : ('a, 'x) Eq.t -> 'a BinPr.t = This.getT
- fun notEq ? = negate (eq ?)
- end
+ open Layered
end
-
-functor WithEq (Arg : OPEN_GENERIC) : EQ_GENERIC = struct
- structure Joined = JoinGenerics (structure Outer = Arg and Inner = Eq)
- open Eq Joined
- structure Eq = Rep
- fun mk f = f o Arg.Rep.getT
- val eq = fn ? => mk eq ?
- val notEq = fn ? => mk notEq ?
-end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-06-17 12:33:43 UTC (rev 5639)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-06-17 12:54:36 UTC (rev 5640)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-local
+functor WithOrd (Arg : OPEN_GENERIC) : ORD_GENERIC = struct
(* <-- SML/NJ workaround *)
open TopLevel
infix 7 *`
@@ -12,9 +12,17 @@
infix 0 &
(* SML/NJ workaround --> *)
- structure Ord : CLOSED_GENERIC = struct
- structure Rep = MkClosedGenericRep (Cmp)
+ structure Ord =
+ LayerGenericRep (structure Outer = Arg.Rep
+ structure Closed = MkClosedGenericRep (Cmp))
+ open Ord.This
+
+ val compare = getT
+
+ structure Layered = LayerGeneric
+ (structure Outer = Arg and Result = Ord and Rep = Ord.Closed
+
fun inj b a2b = b o Pair.map (Sq.mk a2b)
fun iso b = inj b o Iso.to
@@ -25,10 +33,10 @@
fun op --> _ = failing "Compare.--> unsupported"
- (* XXX It is also possible to implement exn so that compare provides
- * a reasonable answer as long as at least one of the exception
- * variants (involved in a comparison) has been registered.
- *)
+ (* XXX It is also possible to implement exn so that compare provides
+ * a reasonable answer as long as at least one of the exception
+ * variants (involved in a comparison) has been registered.
+ *)
val exn : Exn.t Rep.t Ref.t = ref GenericsUtil.failExnSq
fun regExn t (_, prj) =
Ref.modify (fn exn =>
@@ -76,21 +84,7 @@
fun C0 _ = unit
fun C1 _ = id
- val data = id
- end
+ val data = id)
- structure Ord : OPENED_GENERIC = OpenGeneric (Ord)
-in
- structure Ord :> ORD_GENERIC = struct
- open Ord
- structure Ord = Rep
- val compare : ('a, 'x) Ord.t -> 'a Cmp.t = This.getT
- end
+ open Layered
end
-
-functor WithOrd (Arg : OPEN_GENERIC) : ORD_GENERIC = struct
- structure Joined = JoinGenerics (structure Outer = Arg and Inner = Ord)
- open Ord Joined
- structure Ord = Rep
- val compare = fn ? => compare (Arg.Rep.getT ?)
-end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-06-17 12:33:43 UTC (rev 5639)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2007-06-17 12:54:36 UTC (rev 5640)
@@ -9,7 +9,7 @@
(* XXX parameters for pretty printing? *)
(* XXX parameters for depth, length, etc... for showing only partial data *)
-local
+functor WithPretty (Arg : OPEN_GENERIC) : PRETTY_GENERIC = struct
(* <-- SML/NJ workaround *)
open TopLevel
infix 7 *`
@@ -24,39 +24,51 @@
infixr 0 -->
(* SML/NJ workaround --> *)
- structure Pretty : CLOSED_GENERIC = struct
- local
- open Prettier
- type u = Bool.t * t
- fun atomic doc = (true, doc)
- fun nonAtomic doc = (false, doc)
- val uop : t UnOp.t -> u UnOp.t = id <\ Pair.map
- val bop : t BinOp.t -> u BinOp.t =
- fn f => nonAtomic o f o Pair.map (Sq.mk Pair.snd)
- in
- type u = u
+ local
+ open Prettier
+ type u = Bool.t * t
+ fun atomic doc = (true, doc)
+ fun nonAtomic doc = (false, doc)
+ val uop : t UnOp.t -> u UnOp.t = id <\ Pair.map
+ val bop : t BinOp.t -> u BinOp.t =
+ fn f => nonAtomic o f o Pair.map (Sq.mk Pair.snd)
+ in
+ type u = u
- val parens = (1, (lparen, rparen))
- val hashParens = (2, (txt "#(", rparen))
- val braces = (1, (lbrace, rbrace))
- val brackets = (1, (lbracket, rbracket))
- val hashBrackets = (2, (txt "#[", rbracket))
+ val parens = (1, (lparen, rparen))
+ val hashParens = (2, (txt "#(", rparen))
+ val braces = (1, (lbrace, rbrace))
+ val brackets = (1, (lbracket, rbracket))
+ val hashBrackets = (2, (txt "#[", rbracket))
- val comma = atomic comma
- val equals = atomic equals
+ val comma = atomic comma
+ val equals = atomic equals
- val txt = atomic o txt
- fun surround (n, p) = atomic o group o nest n o enclose p o Pair.snd
- fun atomize (d as (a, _)) = if a then d else surround parens d
- val punctuate = fn (_, s) => punctuate s o List.map Pair.snd
- val fill = fn ? => nonAtomic (vsep ?)
- val group = uop group
- val nest = uop o nest
- val op <^> = fn ((al, dl), (ar, dr)) => (al andalso ar, dl <^> dr)
- val op <$> = bop op <$>
- val op </> = bop op </>
- end
+ val txt = atomic o txt
+ fun surround (n, p) = atomic o group o nest n o enclose p o Pair.snd
+ fun atomize (d as (a, _)) = if a then d else surround parens d
+ val punctuate = fn (_, s) => punctuate s o List.map Pair.snd
+ val fill = fn ? => nonAtomic (vsep ?)
+ val group = uop group
+ val nest = uop o nest
+ val op <^> = fn ((al, dl), (ar, dr)) => (al andalso ar, dl <^> dr)
+ val op <$> = bop op <$>
+ val op </> = bop op </>
+ end
+ structure Pretty =
+ LayerGenericRep
+ (structure Outer = Arg.Rep
+ structure Closed = MkClosedGenericRep (type 'a t = exn list * 'a -> u))
+
+ open Pretty.This
+
+ fun layout t = Pair.snd o [] <\ getT t
+ fun pretty m t = Prettier.pretty m o layout t
+
+ structure Layered = LayerGeneric
+ (structure Outer = Arg and Result = Pretty and Rep = Pretty.Closed
+
local
open Generics
in
@@ -65,8 +77,6 @@
val c2s = Con.toString
end
- structure Rep = MkClosedGenericRep (type 'a t = exn list * 'a -> u)
-
fun inj b a2b = b o Pair.map (id, a2b)
fun iso b = inj b o Iso.to
val isoProduct = iso
@@ -183,24 +193,7 @@
val word8 = mkWord Word8.toString
(* val word16 = mkWord Word16.toString (* Word16 not provided by SML/NJ *) *)
val word32 = mkWord Word32.toString
- val word64 = mkWord Word64.toString
- end
+ val word64 = mkWord Word64.toString)
- structure Pretty : OPENED_GENERIC = OpenGeneric (Pretty)
-in
- structure Pretty :> PRETTY_GENERIC = struct
- open Pretty
- structure Pretty = Rep
- val layout : ('a, 'x) Pretty.t -> 'a -> Prettier.t =
- fn t => Pair.snd o [] <\ This.getT t
- fun pretty m t = Prettier.pretty m o layout t
- end
+ open Layered
end
-
-functor WithPretty (Arg : OPEN_GENERIC) : PRETTY_GENERIC = struct
- structure Joined = JoinGenerics (structure Outer = Arg and Inner = Pretty)
- open Joined
- fun layout ? = Pretty.layout (Arg.Rep.getT ?)
- fun pretty m = Pretty.pretty m o Arg.Rep.getT
- structure Pretty = Rep
-end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-06-17 12:33:43 UTC (rev 5639)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-06-17 12:54:36 UTC (rev 5640)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-local
+functor WithTypeInfo (Arg : OPEN_GENERIC) : TYPE_INFO_GENERIC = struct
(* <-- SML/NJ workaround *)
open TopLevel
infix 7 *`
@@ -18,24 +18,6 @@
infixr 0 -->
(* SML/NJ workaround --> *)
- datatype t =
- INT of {base : Bool.t,
- exn : Bool.t,
- pure : Bool.t,
- recs : Int.t List.t}
-
- datatype s =
- INS of {alts : Int.t,
- base : Bool.t,
- exn : Bool.t,
- recs : Int.t List.t}
-
- datatype p =
- INP of {base : Bool.t,
- elems : Int.t,
- exn : Bool.t,
- recs : Int.t List.t}
-
fun revMerge (xs, ys) = let
fun lp ([], ys, zs) = (ys, zs)
| lp (xs, [], zs) = (xs, zs)
@@ -61,13 +43,52 @@
List.revAppend (lp ([], ys))
end
- structure TypeInfo : CLOSED_GENERIC = struct
- structure Rep = struct
- type 'a t = t
- type 'a s = s
- type ('a, 'k) p = p
- end
+ datatype t =
+ INT of {base : Bool.t,
+ exn : Bool.t,
+ pure : Bool.t,
+ recs : Int.t List.t}
+ datatype s =
+ INS of {alts : Int.t,
+ base : Bool.t,
+ exn : Bool.t,
+ recs : Int.t List.t}
+
+ datatype p =
+ INP of {base : Bool.t,
+ elems : Int.t,
+ exn : Bool.t,
+ recs : Int.t List.t}
+
+ structure TypeInfo =
+ LayerGenericRep
+ (structure Outer = Arg.Rep
+ structure Closed = struct
+ type 'a t = t
+ type 'a s = s
+ type ('a, 'k) p = p
+ end)
+
+ open TypeInfo.This
+
+ fun outT (INT r) = r
+ fun outS (INS r) = r
+ fun outP (INP r) = r
+
+ fun hasExn ? = (#exn o outT o getT) ?
+ fun hasRecData ? = (not o null o #recs o outT o getT) ?
+ fun isRefOrArray ? = (not o #pure o outT o getT) ?
+ fun canBeCyclic ? = (isRefOrArray andAlso (hasExn orElse hasRecData)) ?
+
+ fun hasBaseCase ? = (#base o outS o getS) ?
+ fun numAlts ? = (#alts o outS o getS) ?
+
+ fun numElems ? = (#elems o outP o getP) ?
+
+ structure Layered = LayerGeneric
+ (structure Outer = Arg and Result = TypeInfo and Rep = TypeInfo.Closed
+
val base = INT {base = true, exn = false, pure = true, recs = []}
fun pure (INT {exn, recs, ...}) =
INT {base = true, exn = exn, pure = true, recs = recs}
@@ -148,43 +169,7 @@
fun C1 _ (INT {base, exn, recs, ...}) =
INS {alts = 1, base = base, exn = exn, recs = recs}
fun data (INS {base, exn, recs, ...}) =
- INT {base = base, exn = exn, pure = true, recs = recs}
- end
+ INT {base = base, exn = exn, pure = true, recs = recs})
- structure TypeInfo : OPENED_GENERIC = OpenGeneric (TypeInfo)
-in
- structure TypeInfo :> TYPE_INFO_GENERIC = struct
- open TypeInfo
-
- structure TypeInfo = Rep
-
- fun out (INT r) = r
- fun hasExn ? = (#exn o out o This.getT) ?
- fun hasRecData ? = (not o null o #recs o out o This.getT) ?
- fun isRefOrArray ? = (not o #pure o out o This.getT) ?
- fun canBeCyclic ? = (isRefOrArray andAlso (hasExn orElse hasRecData)) ?
-
- fun out (INS r) = r
- fun hasBaseCase ? = (#base o out o This.getS) ?
- fun numAlts ? = (#alts o out o This.getS) ?
-
- fun out (INP r) = r
- fun numElems ? = (#elems o out o This.getP) ?
- end
+ open Layered
end
-
-functor WithTypeInfo (Arg : OPEN_GENERIC) : TYPE_INFO_GENERIC = struct
- structure Joined = JoinGenerics (structure Outer = Arg and Inner = TypeInfo)
- open TypeInfo Joined
- structure TypeInfo = Rep
- fun mk f = f o Arg.Rep.getT
- val canBeCyclic = fn ? => mk canBeCyclic ?
- val hasExn = fn ? => mk hasExn ?
- val hasRecData = fn ? => mk hasRecData ?
- val isRefOrArray = fn ? => mk isRefOrArray ?
- fun mk f = f o Arg.Rep.getS
- val hasBaseCase = fn ? => mk hasBaseCase ?
- val numAlts = fn ? => mk numAlts ?
- fun mk f = f o Arg.Rep.getP
- val numElems = fn ? => mk numElems ?
-end
More information about the MLton-commit
mailing list