[MLton-commit] r5625
Vesa Karvonen
vesak at mlton.org
Sat Jun 16 02:10:52 PDT 2007
Minor tweaks.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
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/show.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-06-16 07:54:52 UTC (rev 5624)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2007-06-16 09:10:51 UTC (rev 5625)
@@ -119,11 +119,9 @@
cog = fn f => fn g =>
aGen >>= (fn a => universally (bCog (f a)) g)}) ?
- fun exn ? = let
- val e = Fail "Arbitrary.exn not supported yet"
- in
- nullary Arg.exn (IN {gen = G.return Empty, cog = raising e})
- end ?
+ fun exn ? =
+ nullary Arg.exn (IN {gen = G.return Empty,
+ cog = failing "Arbitrary.exn unsupported"}) ?
fun regExn ef = Arg.regExn (ef o Pair.snd)
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml 2007-06-16 07:54:52 UTC (rev 5624)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml 2007-06-16 09:10:51 UTC (rev 5625)
@@ -4,17 +4,16 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-structure Dummy :> DUMMY_GENERIC = struct
+local
(* <-- SML/NJ workaround *)
open TopLevel
infix 7 *`
infix 6 +`
infix 0 &
- infixr 0 -->
(* SML/NJ workaround --> *)
- structure Opened = OpenGeneric
- (structure Rep = struct
+ structure Dummy : CLOSED_GENERIC = struct
+ structure Rep = struct
type 'a t = 'a Option.t
type 'a s = 'a t
type ('a, 'k) p = 'a t
@@ -32,11 +31,7 @@
fun Y ? = Tie.pure (const (NONE, id)) ?
- local
- val e = Fail "Dummy.-->"
- in
- fun _ --> _ = SOME (raising e)
- end
+ fun op --> _ = SOME (failing "Dummy.-->")
val exn = SOME Empty
fun regExn _ _ = ()
@@ -77,25 +72,29 @@
fun C0 _ = unit
fun C1 _ = id
- val data = id)
+ val data = id
+ end
- open Opened
+ structure Dummy : OPEN_GENERIC = OpenGeneric (Dummy)
+in
+ structure Dummy :> DUMMY_GENERIC = struct
+ open Dummy
- structure Dummy = Rep
- exception Dummy
+ structure Dummy = Rep
+ exception Dummy
- fun dummy (vo, _) =
- case vo of
- SOME v => v
- | NONE => raise Dummy
+ val dummy : ('a, 'x) Dummy.t -> 'a =
+ fn (SOME v, _) => v
+ | (NONE, _) => raise Dummy
- fun noDummy (_, x) = (NONE, x)
+ fun noDummy (_, x) = (NONE, x)
+ end
end
-functor WithDummy (Outer : OPEN_GENERIC) : DUMMY_GENERIC = struct
- structure Joined = JoinGenerics (structure Outer = Outer and Inner = Dummy)
+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 (Outer.Rep.getT ?)
- val noDummy = fn ? => Outer.Rep.mapT noDummy ?
+ val dummy = fn ? => dummy (Arg.Rep.getT ?)
+ val noDummy = fn ? => Arg.Rep.mapT noDummy ?
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-06-16 07:54:52 UTC (rev 5624)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/eq.sml 2007-06-16 09:10:51 UTC (rev 5625)
@@ -4,17 +4,16 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-structure Eq :> EQ_GENERIC = struct
+local
(* <-- SML/NJ workaround *)
open TopLevel
infix 7 *`
infix 6 +`
infix 0 &
- infixr 0 -->
(* SML/NJ workaround --> *)
- structure Opened = OpenGeneric
- (structure Rep = struct
+ structure Eq : CLOSED_GENERIC = struct
+ structure Rep = struct
type 'a t = 'a BinPr.t
type 'a s = 'a t
type ('a, 'k) p = 'a t
@@ -27,11 +26,7 @@
val Y = Tie.function
- local
- val e = Fail "Eq.--> not supported"
- in
- fun _ --> _ = raising e
- end
+ fun op --> _ = failing "Eq.--> unsupported"
val exn : Exn.t Rep.t Ref.t = ref GenericsUtil.failExnSq
fun regExn t (_, prj) =
@@ -80,21 +75,24 @@
fun C0 _ = unit
fun C1 _ = id
- val data = id)
+ val data = id
+ end
- open Opened
-
- structure Eq = Rep
-
- val eq = Pair.fst
- fun notEq (eq, _) = negate eq
+ structure Eq : OPEN_GENERIC = OpenGeneric (Eq)
+in
+ structure Eq :> EQ_GENERIC = struct
+ open Eq
+ structure Eq = Rep
+ val eq : ('a, 'x) Eq.t -> 'a BinPr.t = Pair.fst
+ fun notEq (eq, _) = negate eq
+ end
end
-functor WithEq (Outer : OPEN_GENERIC) : EQ_GENERIC = struct
- structure Joined = JoinGenerics (structure Outer = Outer and Inner = Eq)
+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 Outer.Rep.getT
+ 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-16 07:54:52 UTC (rev 5624)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-06-16 09:10:51 UTC (rev 5625)
@@ -4,17 +4,16 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-structure Ord :> ORD_GENERIC = struct
+local
(* <-- SML/NJ workaround *)
open TopLevel
infix 7 *`
infix 6 +`
infix 0 &
- infixr 0 -->
(* SML/NJ workaround --> *)
- structure Opened = OpenGeneric
- (structure Rep = struct
+ structure Ord : CLOSED_GENERIC = struct
+ structure Rep = struct
type 'a t = 'a Cmp.t
type 'a s = 'a t
type ('a, 'k) p = 'a t
@@ -28,11 +27,7 @@
val Y = Tie.function
- local
- val e = Fail "Compare.--> not supported"
- in
- fun _ --> _ = raising e
- end
+ 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
@@ -85,18 +80,21 @@
fun C0 _ = unit
fun C1 _ = id
- val data = id)
+ val data = id
+ end
- open Opened
-
- structure Ord = Rep
-
- val compare = Pair.fst
+ structure Ord : OPEN_GENERIC = OpenGeneric (Ord)
+in
+ structure Ord :> ORD_GENERIC = struct
+ open Ord
+ structure Ord = Rep
+ val compare : ('a, 'x) Ord.t -> 'a Cmp.t = Pair.fst
+ end
end
-functor WithOrd (Outer : OPEN_GENERIC) : ORD_GENERIC = struct
- structure Joined = JoinGenerics (structure Outer = Outer and Inner = Ord)
+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 (Outer.Rep.getT ?)
+ val compare = fn ? => compare (Arg.Rep.getT ?)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml 2007-06-16 07:54:52 UTC (rev 5624)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/show.sml 2007-06-16 09:10:51 UTC (rev 5625)
@@ -9,7 +9,7 @@
(* XXX parameters for pretty printing? *)
(* XXX parameters for depth, length, etc... for showing only partial data *)
-structure Show :> SHOW_GENERIC = struct
+local
(* <-- SML/NJ workaround *)
open TopLevel
infix 7 *`
@@ -24,8 +24,8 @@
infixr 0 -->
(* SML/NJ workaround --> *)
- structure Opened = OpenGeneric
- (local
+ structure Show : CLOSED_GENERIC = struct
+ local
open Prettier
type u = Bool.t * t
fun atomic doc = (true, doc)
@@ -187,20 +187,24 @@
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)
+ val word64 = mkWord Word64.toString
+ end
- open Opened
-
- structure Show = Rep
-
- fun layout (t, _) x = Pair.snd (t ([], x))
- fun show m t = Prettier.pretty m o layout t
+ structure Show : OPEN_GENERIC = OpenGeneric (Show)
+in
+ structure Show :> SHOW_GENERIC = struct
+ open Show
+ structure Show = Rep
+ val layout : ('a, 'x) Show.t -> 'a -> Prettier.t =
+ fn (t, _) => Pair.snd o [] <\ t
+ fun show m t = Prettier.pretty m o layout t
+ end
end
-functor WithShow (Outer : OPEN_GENERIC) : SHOW_GENERIC = struct
- structure Joined = JoinGenerics (structure Outer = Outer and Inner = Show)
+functor WithShow (Arg : OPEN_GENERIC) : SHOW_GENERIC = struct
+ structure Joined = JoinGenerics (structure Outer = Arg and Inner = Show)
open Joined
- fun layout ? = Show.layout (Outer.Rep.getT ?)
- fun show m = Show.show m o Outer.Rep.getT
+ fun layout ? = Show.layout (Arg.Rep.getT ?)
+ fun show m = Show.show m o Arg.Rep.getT
structure Show = 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-16 07:54:52 UTC (rev 5624)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-06-16 09:10:51 UTC (rev 5625)
@@ -4,7 +4,7 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-structure TypeInfo :> TYPE_INFO_GENERIC = struct
+local
(* <-- SML/NJ workaround *)
open TopLevel
infix 7 *`
@@ -61,8 +61,8 @@
List.revAppend (lp ([], ys))
end
- structure Opened = OpenGeneric
- (structure Rep = struct
+ structure TypeInfo : CLOSED_GENERIC = struct
+ structure Rep = struct
type 'a t = t
type 'a s = s
type ('a, 'k) p = p
@@ -148,39 +148,43 @@
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})
+ INT {base = base, exn = exn, pure = true, recs = recs}
+ end
- open Opened
+ structure TypeInfo : OPEN_GENERIC = OpenGeneric (TypeInfo)
+in
+ structure TypeInfo :> TYPE_INFO_GENERIC = struct
+ open TypeInfo
- structure TypeInfo = Rep
+ structure TypeInfo = Rep
- fun out (INT r, _) = r
+ fun out (INT r, _) = r
+ fun hasExn ? = (#exn o out) ?
+ fun hasRecData ? = (not o null o #recs o out) ?
+ fun isRefOrArray ? = (not o #pure o out) ?
+ fun canBeCyclic ? = (isRefOrArray andAlso (hasExn orElse hasRecData)) ?
- fun hasExn ? = (#exn o out) ?
- fun hasRecData ? = (not o null o #recs o out) ?
- fun isRefOrArray ? = (not o #pure o out) ?
- fun canBeCyclic ? = (isRefOrArray andAlso (hasExn orElse hasRecData)) ?
+ fun out (INS r, _) = r
+ fun hasBaseCase ? = (#base o out) ?
+ fun numAlts ? = (#alts o out) ?
- fun out (INS r, _) = r
- fun numAlts ? = (#alts o out) ?
- fun hasBaseCase ? = (#base o out) ?
-
- fun out (INP r, _) = r
- fun numElems ? = (#elems o out) ?
+ fun out (INP r, _) = r
+ fun numElems ? = (#elems o out) ?
+ end
end
-functor WithTypeInfo (Outer : OPEN_GENERIC) : TYPE_INFO_GENERIC = struct
- structure Joined = JoinGenerics (structure Outer = Outer and Inner = TypeInfo)
+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 Outer.Rep.getT
+ 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 Outer.Rep.getS
+ fun mk f = f o Arg.Rep.getS
val hasBaseCase = fn ? => mk hasBaseCase ?
val numAlts = fn ? => mk numAlts ?
- fun mk f = f o Outer.Rep.getP
+ fun mk f = f o Arg.Rep.getP
val numElems = fn ? => mk numElems ?
end
More information about the MLton-commit
mailing list