[MLton-commit] r6077
Vesa Karvonen
vesak at mlton.org
Sun Oct 21 06:03:13 PDT 2007
Sealed the implementation opaquely.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml 2007-10-21 12:32:07 UTC (rev 6076)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml 2007-10-21 13:03:12 UTC (rev 6077)
@@ -4,103 +4,113 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-functor WithDynamic (Arg : WITH_DYNAMIC_DOM) : DYNAMIC_CASES = struct
- (* <-- SML/NJ workaround *)
- open TopLevel
- infix <-->
- (* SML/NJ workaround --> *)
+functor WithDynamic (Arg : WITH_DYNAMIC_DOM) = let
+ structure Result = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix <-->
+ (* SML/NJ workaround --> *)
- structure Dynamic = struct
- datatype t =
- PRODUCT of (t, t) Product.t
- | SUM of (t, t) Sum.t
- | UNIT
- | ARROW of t UnOp.t
- | EXN of Exn.t
- | LIST of t List.t
- | VECTOR of t Vector.t
- | FIXED_INT of FixedInt.t
- | LARGE_INT of LargeInt.t
- | LARGE_WORD of LargeWord.t
- | LARGE_REAL of LargeReal.t
- | BOOL of Bool.t
- | CHAR of Char.t
- | INT of Int.t
- | REAL of Real.t
- | STRING of String.t
- | WORD of Word.t
- | WORD8 of Word8.t
- | WORD32 of Word32.t
- | WORD64 of Word64.t
- exception Dynamic
- end
+ structure Dynamic = struct
+ datatype t =
+ PRODUCT of (t, t) Product.t
+ | SUM of (t, t) Sum.t
+ | UNIT
+ | ARROW of t UnOp.t
+ | EXN of Exn.t
+ | LIST of t List.t
+ | VECTOR of t Vector.t
+ | FIXED_INT of FixedInt.t
+ | LARGE_INT of LargeInt.t
+ | LARGE_WORD of LargeWord.t
+ | LARGE_REAL of LargeReal.t
+ | BOOL of Bool.t
+ | CHAR of Char.t
+ | INT of Int.t
+ | REAL of Real.t
+ | STRING of String.t
+ | WORD of Word.t
+ | WORD8 of Word8.t
+ | WORD32 of Word32.t
+ | WORD64 of Word64.t
+ exception Dynamic
+ end
- open Dynamic
+ open Dynamic
- val op <--> = Iso.<-->
+ val op <--> = Iso.<-->
- fun isoUnsupported text = (failing text, failing text)
+ fun isoUnsupported text = (failing text, failing text)
- structure DynamicRep = LayerRep
- (open Arg
- structure Rep = MkClosedRep (type 'a t = ('a, t) Iso.t))
+ structure DynamicRep = LayerRep
+ (open Arg
+ structure Rep = MkClosedRep (type 'a t = ('a, t) Iso.t))
- open DynamicRep.This
+ open DynamicRep.This
- fun toDynamic t = Iso.to (getT t)
- fun fromDynamic t d =
- SOME (Iso.from (getT t) d) handle Dynamic.Dynamic => NONE
+ fun toDynamic t = Iso.to (getT t)
+ fun fromDynamic t d =
+ SOME (Iso.from (getT t) d) handle Dynamic.Dynamic => NONE
- structure Open = LayerCases
- (fun iso bId aIb = bId <--> aIb
- val isoProduct = iso
- val isoSum = iso
+ structure Open = LayerCases
+ (fun iso bId aIb = bId <--> aIb
+ val isoProduct = iso
+ val isoSum = iso
- fun op *` is =
- (PRODUCT, fn PRODUCT ? => ? | _ => raise Dynamic) <--> Product.iso is
- val T = id
- fun R _ = id
- val tuple = id
- val record = id
+ fun op *` is =
+ (PRODUCT, fn PRODUCT ? => ? | _ => raise Dynamic)
+ <--> Product.iso is
+ val T = id
+ fun R _ = id
+ val tuple = id
+ val record = id
- fun op +` is = (SUM, fn SUM ? => ? | _ => raise Dynamic) <--> Sum.iso is
- val unit = (fn () => UNIT, fn UNIT => () | _ => raise Dynamic)
- fun C0 _ = unit
- fun C1 _ = id
- val data = id
+ fun op +` is =
+ (SUM, fn SUM ? => ? | _ => raise Dynamic) <--> Sum.iso is
+ val unit = (fn () => UNIT, fn UNIT => () | _ => raise Dynamic)
+ fun C0 _ = unit
+ fun C1 _ = id
+ val data = id
- fun Y ? = let open Tie in tuple2 (function, function) end ?
+ fun Y ? = let open Tie in tuple2 (function, function) end ?
- fun op --> is =
- (ARROW, fn ARROW ? => ? | _ => raise Dynamic) <--> Fn.iso is
+ fun op --> is =
+ (ARROW, fn ARROW ? => ? | _ => raise Dynamic) <--> Fn.iso is
- val exn = (EXN, fn EXN ? => ? | _ => raise Dynamic)
- fun regExn0 _ _ = ()
- fun regExn1 _ _ _ = ()
+ val exn = (EXN, fn EXN ? => ? | _ => raise Dynamic)
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
- fun list i = (LIST, fn LIST ? => ? | _ => raise Dynamic) <--> List.iso i
- fun vector i =
- (VECTOR, fn VECTOR ? => ? | _ => raise Dynamic) <--> Vector.iso i
+ fun list i =
+ (LIST, fn LIST ? => ? | _ => raise Dynamic) <--> List.iso i
+ fun vector i =
+ (VECTOR, fn VECTOR ? => ? | _ => raise Dynamic) <--> Vector.iso i
- fun array _ = isoUnsupported "Dynamic.array unsupported"
- fun refc _ = isoUnsupported "Dynamic.refc unsupported"
+ fun array _ = isoUnsupported "Dynamic.array unsupported"
+ fun refc _ = isoUnsupported "Dynamic.refc unsupported"
- val fixedInt = (FIXED_INT, fn FIXED_INT ? => ? | _ => raise Dynamic)
- val largeInt = (LARGE_INT, fn LARGE_INT ? => ? | _ => raise Dynamic)
+ val fixedInt = (FIXED_INT, fn FIXED_INT ? => ? | _ => raise Dynamic)
+ val largeInt = (LARGE_INT, fn LARGE_INT ? => ? | _ => raise Dynamic)
- val largeWord = (LARGE_WORD, fn LARGE_WORD ? => ? | _ => raise Dynamic)
- val largeReal = (LARGE_REAL, fn LARGE_REAL ? => ? | _ => raise Dynamic)
+ val largeWord = (LARGE_WORD, fn LARGE_WORD ? => ? | _ => raise Dynamic)
+ val largeReal = (LARGE_REAL, fn LARGE_REAL ? => ? | _ => raise Dynamic)
- val bool = (BOOL, fn BOOL ? => ? | _ => raise Dynamic)
- val char = (CHAR, fn CHAR ? => ? | _ => raise Dynamic)
- val int = (INT, fn INT ? => ? | _ => raise Dynamic)
- val real = (REAL, fn REAL ? => ? | _ => raise Dynamic)
- val string = (STRING, fn STRING ? => ? | _ => raise Dynamic)
- val word = (WORD, fn WORD ? => ? | _ => raise Dynamic)
+ val bool = (BOOL, fn BOOL ? => ? | _ => raise Dynamic)
+ val char = (CHAR, fn CHAR ? => ? | _ => raise Dynamic)
+ val int = (INT, fn INT ? => ? | _ => raise Dynamic)
+ val real = (REAL, fn REAL ? => ? | _ => raise Dynamic)
+ val string = (STRING, fn STRING ? => ? | _ => raise Dynamic)
+ val word = (WORD, fn WORD ? => ? | _ => raise Dynamic)
- val word8 = (WORD8, fn WORD8 ? => ? | _ => raise Dynamic)
- val word32 = (WORD32, fn WORD32 ? => ? | _ => raise Dynamic)
- val word64 = (WORD64, fn WORD64 ? => ? | _ => raise Dynamic)
+ val word8 = (WORD8, fn WORD8 ? => ? | _ => raise Dynamic)
+ val word32 = (WORD32, fn WORD32 ? => ? | _ => raise Dynamic)
+ val word64 = (WORD64, fn WORD64 ? => ? | _ => raise Dynamic)
- open Arg DynamicRep)
+ open Arg DynamicRep)
+ end
+in
+ Result :> DYNAMIC_CASES
+ where type ('a, 'x) Open.Rep.t = ('a, 'x) Result.Open.Rep.t
+ where type ('a, 'x) Open.Rep.s = ('a, 'x) Result.Open.Rep.s
+ where type ('a, 'k, 'x) Open.Rep.p = ('a, 'k, 'x) Result.Open.Rep.p
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml 2007-10-21 12:32:07 UTC (rev 6076)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml 2007-10-21 13:03:12 UTC (rev 6077)
@@ -4,83 +4,90 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-functor WithTypeExp (Arg : WITH_TYPE_EXP_DOM) : TYPE_EXP_CASES = struct
- (* <-- SML/NJ workaround *)
- open TopLevel
- (* SML/NJ workaround --> *)
+functor WithTypeExp (Arg : WITH_TYPE_EXP_DOM) = let
+ structure Result = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ (* SML/NJ workaround --> *)
- open Generics Ty open Product Sum Con0 Con1 Con2
+ open Generics Ty open Product Sum Con0 Con1 Con2
- structure TypeVar = struct
- type t = Unit.t Ref.t
- val new = ref
- end
+ structure TypeVar = struct
+ type t = Unit.t Ref.t
+ val new = ref
+ end
- fun mapElem f =
- fn TIMES (a, b) => TIMES (mapElem f a, mapElem f b)
- | ISO_PRODUCT b => ISO_PRODUCT (mapElem f b)
- | ELEM e => ELEM (f e)
+ fun mapElem f =
+ fn TIMES (a, b) => TIMES (mapElem f a, mapElem f b)
+ | ISO_PRODUCT b => ISO_PRODUCT (mapElem f b)
+ | ELEM e => ELEM (f e)
- structure TypeExpRep = LayerRep
- (open Arg
- structure Rep = struct
- type 'a t = TypeVar.t Ty.t
- and 'a s = TypeVar.t Ty.t Sum.t
- and ('a, 'k) p = (Label.t Option.t * TypeVar.t Ty.t) Product.t
- end)
+ structure TypeExpRep = LayerRep
+ (open Arg
+ structure Rep = struct
+ type 'a t = TypeVar.t Ty.t
+ and 'a s = TypeVar.t Ty.t Sum.t
+ and ('a, 'k) p = (Label.t Option.t * TypeVar.t Ty.t) Product.t
+ end)
- val ty = TypeExpRep.This.getT
+ val ty = TypeExpRep.This.getT
- structure Open = LayerCases
- (fun iso bT _ = ISO bT
- fun isoProduct bP _ = ISO_PRODUCT bP
- fun isoSum bS _ = ISO_SUM bS
+ structure Open = LayerCases
+ (fun iso bT _ = ISO bT
+ fun isoProduct bP _ = ISO_PRODUCT bP
+ fun isoSum bS _ = ISO_SUM bS
- val op *` = TIMES
- fun T aT = ELEM (NONE, aT)
- fun R l aT = ELEM (SOME l, aT)
- fun tuple aP = TUPLE (mapElem Pair.snd aP)
- fun record aP = RECORD (mapElem (Pair.map (valOf, id)) aP)
+ val op *` = TIMES
+ fun T aT = ELEM (NONE, aT)
+ fun R l aT = ELEM (SOME l, aT)
+ fun tuple aP = TUPLE (mapElem Pair.snd aP)
+ fun record aP = RECORD (mapElem (Pair.map (valOf, id)) aP)
- val op +` = PLUS
- val unit = CON0 UNIT
- fun C0 c = Sum.C0 c
- fun C1 c aT = Sum.C1 (c, aT)
- val data = DATA
+ val op +` = PLUS
+ val unit = CON0 UNIT
+ fun C0 c = Sum.C0 c
+ fun C1 c aT = Sum.C1 (c, aT)
+ val data = DATA
- val Y = Tie.pure (fn () => let
- val v = TypeVar.new ()
- in
- (VAR v, fn e => FIX (v, e))
- end)
+ val Y = Tie.pure (fn () => let
+ val v = TypeVar.new ()
+ in
+ (VAR v, fn e => FIX (v, e))
+ end)
- fun op --> aTbT = CON2 (ARROW, aTbT)
+ fun op --> aTbT = CON2 (ARROW, aTbT)
- val exn = CON0 EXN
- fun regExn0 _ _ = ()
- fun regExn1 _ _ _ = ()
+ val exn = CON0 EXN
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
- fun list aT = CON1 (LIST, aT)
- fun vector aT = CON1 (VECTOR, aT)
- fun array aT = CON1 (ARRAY, aT)
- fun refc aT = CON1 (REF, aT)
+ fun list aT = CON1 (LIST, aT)
+ fun vector aT = CON1 (VECTOR, aT)
+ fun array aT = CON1 (ARRAY, aT)
+ fun refc aT = CON1 (REF, aT)
- val fixedInt = CON0 FIXED_INT
- val largeInt = CON0 LARGE_INT
+ val fixedInt = CON0 FIXED_INT
+ val largeInt = CON0 LARGE_INT
- val largeReal = CON0 LARGE_REAL
- val largeWord = CON0 LARGE_WORD
+ val largeReal = CON0 LARGE_REAL
+ val largeWord = CON0 LARGE_WORD
- val bool = CON0 BOOL
- val char = CON0 CHAR
- val int = CON0 INT
- val real = CON0 REAL
- val string = CON0 STRING
- val word = CON0 WORD
+ val bool = CON0 BOOL
+ val char = CON0 CHAR
+ val int = CON0 INT
+ val real = CON0 REAL
+ val string = CON0 STRING
+ val word = CON0 WORD
- val word8 = CON0 WORD8
- val word32 = CON0 WORD32
- val word64 = CON0 WORD64
+ val word8 = CON0 WORD8
+ val word32 = CON0 WORD32
+ val word64 = CON0 WORD64
- open Arg TypeExpRep)
+ open Arg TypeExpRep)
+ end
+in
+ Result :> TYPE_EXP_CASES
+ where type ('a, 'x) Open.Rep.t = ('a, 'x) Result.Open.Rep.t
+ where type ('a, 'x) Open.Rep.s = ('a, 'x) Result.Open.Rep.s
+ where type ('a, 'k, 'x) Open.Rep.p = ('a, 'k, 'x) Result.Open.Rep.p
end
More information about the MLton-commit
mailing list