[MLton-commit] r6065
Vesa Karvonen
vesak at mlton.org
Tue Oct 9 05:15:18 PDT 2007
More general typing for cases in the GENERIC and GENERIC_EXTRA signatures.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun
U mltonlib/trunk/com/ssh/generic/unstable/detail/close-pretty-with-extra.fun
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/generic.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun 2007-10-07 09:25:13 UTC (rev 6064)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/close-generic.fun 2007-10-09 12:15:16 UTC (rev 6065)
@@ -15,53 +15,54 @@
type ('a, 'k) p = ('a, 'k, Unit.t) p
end
-functor CloseCases (Arg : OPEN_CASES) :>
- CLOSED_CASES
- where type 'a Rep.t = ('a, Unit.t) Arg.Rep.t
- where type 'a Rep.s = ('a, Unit.t) Arg.Rep.s
- where type ('a, 'k) Rep.p = ('a, 'k, Unit.t) Arg.Rep.p =
+functor CloseCases (Arg : CASES) :>
+ GENERIC
+ where type ('a, 'x) Open.Rep.t = ('a, 'x) Arg.Open.Rep.t
+ where type ('a, 'x) Open.Rep.s = ('a, 'x) Arg.Open.Rep.s
+ where type ('a, 'k, 'x) Open.Rep.p = ('a, 'k, 'x) Arg.Open.Rep.p =
struct
(* <-- SML/NJ workaround *)
open TopLevel
(* SML/NJ workaround --> *)
- structure Rep = CloseRep (Arg.Rep)
+ open Arg
+ structure Rep = CloseRep (Open.Rep)
fun morph m = m (const ignore)
- fun iso ? = morph Arg.iso ?
- fun isoProduct ? = morph Arg.isoProduct ?
- fun isoSum ? = morph Arg.isoSum ?
- fun op *` ? = Arg.*` ignore ?
- fun T ? = Arg.T ignore ?
- fun R ? = Arg.R (const ignore) ?
- fun tuple ? = Arg.tuple ignore ?
- fun record ? = Arg.record ignore ?
- fun op +` ? = Arg.+` ignore ?
- fun C0 ? = Arg.C0 (const ()) ?
- fun C1 ? = Arg.C1 (const ignore) ?
- fun data ? = Arg.data ignore ?
- val unit = Arg.unit ()
- fun Y ? = Arg.Y (Tie.id ()) ?
- fun op --> ? = Arg.--> ignore ?
- val exn = Arg.exn ()
- fun regExn0 ? = Arg.regExn0 (const ignore) ?
- fun regExn1 ? = Arg.regExn1 (const (const ignore)) ?
- fun array ? = Arg.array ignore ?
- fun refc ? = Arg.refc ignore ?
- fun vector ? = Arg.vector ignore ?
- val fixedInt = Arg.fixedInt ()
- val largeInt = Arg.largeInt ()
- val largeReal = Arg.largeReal ()
- val largeWord = Arg.largeWord ()
- val word8 = Arg.word8 ()
- val word32 = Arg.word32 ()
- val word64 = Arg.word64 ()
- fun list ? = Arg.list ignore ?
- val bool = Arg.bool ()
- val char = Arg.char ()
- val int = Arg.int ()
- val real = Arg.real ()
- val string = Arg.string ()
- val word = Arg.word ()
+ fun iso ? = morph Open.iso ?
+ fun isoProduct ? = morph Open.isoProduct ?
+ fun isoSum ? = morph Open.isoSum ?
+ fun op *` ? = Open.*` ignore ?
+ fun T ? = Open.T ignore ?
+ fun R ? = Open.R (const ignore) ?
+ fun tuple ? = Open.tuple ignore ?
+ fun record ? = Open.record ignore ?
+ fun op +` ? = Open.+` ignore ?
+ fun C0 ? = Open.C0 (const ()) ?
+ fun C1 ? = Open.C1 (const ignore) ?
+ fun data ? = Open.data ignore ?
+ val unit = Open.unit ()
+ fun Y ? = Open.Y (Tie.id ()) ?
+ fun op --> ? = Open.--> ignore ?
+ val exn = Open.exn ()
+ fun regExn0 ? = Open.regExn0 (const ignore) ?
+ fun regExn1 ? = Open.regExn1 (const (const ignore)) ?
+ fun array ? = Open.array ignore ?
+ fun refc ? = Open.refc ignore ?
+ fun vector ? = Open.vector ignore ?
+ val fixedInt = Open.fixedInt ()
+ val largeInt = Open.largeInt ()
+ val largeReal = Open.largeReal ()
+ val largeWord = Open.largeWord ()
+ val word8 = Open.word8 ()
+ val word32 = Open.word32 ()
+ val word64 = Open.word64 ()
+ fun list ? = Open.list ignore ?
+ val bool = Open.bool ()
+ val char = Open.char ()
+ val int = Open.int ()
+ val real = Open.real ()
+ val string = Open.string ()
+ val word = Open.word ()
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/close-pretty-with-extra.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/close-pretty-with-extra.fun 2007-10-07 09:25:13 UTC (rev 6064)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/close-pretty-with-extra.fun 2007-10-09 12:15:16 UTC (rev 6065)
@@ -5,7 +5,7 @@
*)
functor ClosePrettyWithExtra (Arg : PRETTY_CASES) : GENERIC_EXTRA = struct
- structure Rep = CloseCases (Arg.Open)
+ structure Rep = CloseCases (Arg)
structure Rep = WithExtra (open Arg Rep)
open Arg Rep
local
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-10-07 09:25:13 UTC (rev 6064)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-10-09 12:15:16 UTC (rev 6065)
@@ -76,11 +76,11 @@
(** === Closing Generics === *)
-functor CloseCases (Arg : OPEN_CASES) :>
- CLOSED_CASES
- where type 'a Rep.t = ('a, Unit.t) Arg.Rep.t
- where type 'a Rep.s = ('a, Unit.t) Arg.Rep.s
- where type ('a, 'k) Rep.p = ('a, 'k, Unit.t) Arg.Rep.p =
+functor CloseCases (Arg : CASES) :>
+ GENERIC
+ where type ('a, 'x) Open.Rep.t = ('a, 'x) Arg.Open.Rep.t
+ where type ('a, 'x) Open.Rep.s = ('a, 'x) Arg.Open.Rep.s
+ where type ('a, 'k, 'x) Open.Rep.p = ('a, 'k, 'x) Arg.Open.Rep.p =
CloseCases (Arg)
(** Closes open structural cases. *)
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig 2007-10-07 09:25:13 UTC (rev 6064)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig 2007-10-09 12:15:16 UTC (rev 6065)
@@ -21,12 +21,13 @@
*)
val C0' : String.t -> Unit.t Rep.s
- val C1' : String.t -> 'a Rep.t -> 'a Rep.s
+ val C1' : String.t -> ('a, 'x) Open.Rep.t -> 'a Rep.s
- val R' : String.t -> 'a Rep.t -> ('a, Record.t) Rep.p
+ val R' : String.t -> ('a, 'x) Open.Rep.t -> ('a, Record.t) Rep.p
val regExn0' : String.t -> Exn.t -> (Exn.t -> Unit.t) Effect.t
- val regExn1' : String.t -> 'a Rep.t -> ('a -> Exn.t) -> (Exn.t -> 'a) Effect.t
+ val regExn1' : String.t -> ('a, 'x) Open.Rep.t
+ -> ('a -> Exn.t) -> (Exn.t -> 'a) Effect.t
(** == Tuples ==
*
@@ -40,10 +41,15 @@
*> fn v1 & ... & vN => (v1, ..., vN))
*)
- val tuple2 : 'a Rep.t * 'b Rep.t -> ('a * 'b) Rep.t
- val tuple3 : 'a Rep.t * 'b Rep.t * 'c Rep.t -> ('a * 'b * 'c) Rep.t
- val tuple4 :
- 'a Rep.t * 'b Rep.t * 'c Rep.t * 'd Rep.t -> ('a * 'b * 'c * 'd) Rep.t
+ val tuple2 : ('a, 's) Open.Rep.t *
+ ('b, 't) Open.Rep.t -> ('a * 'b) Rep.t
+ val tuple3 : ('a, 's) Open.Rep.t *
+ ('b, 't) Open.Rep.t *
+ ('c, 'u) Open.Rep.t -> ('a * 'b * 'c) Rep.t
+ val tuple4 : ('a, 's) Open.Rep.t *
+ ('b, 't) Open.Rep.t *
+ ('c, 'u) Open.Rep.t *
+ ('d, 'v) Open.Rep.t -> ('a * 'b * 'c * 'd) Rep.t
(** == Integer Types == *)
@@ -54,7 +60,7 @@
(** == Some Standard Datatypes == *)
- val option : 'a Rep.t -> 'a Option.t Rep.t
+ val option : ('a, 'x) Open.Rep.t -> 'a Option.t Rep.t
val order : Order.t Rep.t
(** == Binary Sums and Products ==
@@ -65,12 +71,14 @@
* and sum types provided by the Extended Basis library.
*)
- val &` : 'a Rep.t * 'b Rep.t -> ('a, 'b) Product.t Rep.t
- val |` : 'a Rep.t * 'b Rep.t -> ('a, 'b) Sum.t Rep.t
+ val &` : ('a, 'x) Open.Rep.t *
+ ('b, 'y) Open.Rep.t -> ('a, 'b) Product.t Rep.t
+ val |` : ('a, 'x) Open.Rep.t *
+ ('b, 'y) Open.Rep.t -> ('a, 'b) Sum.t Rep.t
(** == Abbreviations for Common Types == *)
- val sq : 'a Rep.t -> 'a Sq.t Rep.t
- val unOp : 'a Rep.t -> 'a UnOp.t Rep.t
- val binOp : 'a Rep.t -> 'a BinOp.t Rep.t
+ val sq : ('a, 'x) Open.Rep.t -> 'a Sq.t Rep.t
+ val unOp : ('a, 'x) Open.Rep.t -> 'a UnOp.t Rep.t
+ val binOp : ('a, 'x) Open.Rep.t -> 'a BinOp.t Rep.t
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/generic.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/generic.sig 2007-10-07 09:25:13 UTC (rev 6064)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/generic.sig 2007-10-09 12:15:16 UTC (rev 6065)
@@ -9,8 +9,43 @@
*)
signature GENERIC = sig
include CASES
- include CLOSED_CASES
- where type 'a Rep.t = ('a, Unit.t) Open.Rep.t
- where type 'a Rep.s = ('a, Unit.t) Open.Rep.s
- where type ('a, 'k) Rep.p = ('a, 'k, Unit.t) Open.Rep.p
+ structure Rep : CLOSED_REP
+ where type 'a t = ('a, Unit.t) Open.Rep.t
+ where type 'a s = ('a, Unit.t) Open.Rep.s
+ where type ('a, 'k) p = ('a, 'k, Unit.t) Open.Rep.p
+ val iso : ('b, 'y) Open.Rep.t -> ('a, 'b) Iso.t -> 'a Rep.t
+ val isoProduct : ('b, 'k, 'y) Open.Rep.p -> ('a, 'b) Iso.t -> ('a, 'k) Rep.p
+ val isoSum : ('b, 'y) Open.Rep.s -> ('a, 'b) Iso.t -> 'a Rep.s
+ val *` : ('a, 'k, 'x) Open.Rep.p * ('b, 'k, 'y) Open.Rep.p -> (('a, 'b) Product.t, 'k) Rep.p
+ val T : ('a, 'x) Open.Rep.t -> ('a, Generics.Tuple.t) Rep.p
+ val R : Generics.Label.t -> ('a, 'x) Open.Rep.t -> ('a, Generics.Record.t) Rep.p
+ val tuple : ('a, Generics.Tuple.t, 'x) Open.Rep.p -> 'a Rep.t
+ val record : ('a, Generics.Record.t, 'x) Open.Rep.p -> 'a Rep.t
+ val +` : ('a, 'x) Open.Rep.s * ('b, 'y) Open.Rep.s -> ('a, 'b) Sum.t Rep.s
+ val C0 : Generics.Con.t -> Unit.t Rep.s
+ val C1 : Generics.Con.t -> ('a, 'x) Open.Rep.t -> 'a Rep.s
+ val data : ('a, 'x) Open.Rep.s -> 'a Rep.t
+ val unit : Unit.t Rep.t
+ val Y : 'a Rep.t Tie.t
+ val --> : ('a, 'x) Open.Rep.t * ('b, 'y) Open.Rep.t -> ('a -> 'b) Rep.t
+ val exn : Exn.t Rep.t
+ val regExn0 : Generics.Con.t -> (Exn.t * (Exn.t -> Unit.t Option.t)) Effect.t
+ val regExn1 : Generics.Con.t -> ('a, 'x) Open.Rep.t -> ('a, Exn.t) Emb.t Effect.t
+ val array : ('a, 'x) Open.Rep.t -> 'a Array.t Rep.t
+ val refc : ('a, 'x) Open.Rep.t -> 'a Ref.t Rep.t
+ val vector : ('a, 'x) Open.Rep.t -> 'a Vector.t Rep.t
+ val fixedInt : FixedInt.t Rep.t
+ val largeInt : LargeInt.t Rep.t
+ val largeReal : LargeReal.t Rep.t
+ val largeWord : LargeWord.t Rep.t
+ val word8 : Word8.t Rep.t
+ val word32 : Word32.t Rep.t
+ val word64 : Word64.t Rep.t
+ val list : ('a, 'x) Open.Rep.t -> 'a List.t Rep.t
+ val bool : Bool.t Rep.t
+ val char : Char.t Rep.t
+ val int : Int.t Rep.t
+ val real : Real.t Rep.t
+ val string : String.t Rep.t
+ val word : Word.t Rep.t
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig 2007-10-07 09:25:13 UTC (rev 6064)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/layer-dep-cases-fun.sig 2007-10-09 12:15:16 UTC (rev 6065)
@@ -18,7 +18,7 @@
val R : Generics.Label.t -> ('a, 'x) t -> ('a, Generics.Record.t) This.p
val tuple : ('a, Generics.Tuple.t, 'x) p -> 'a This.t
val record : ('a, Generics.Record.t, 'x) p -> 'a This.t
- val +` : ('a, 'x) s * ('b, 'y) s -> (('a, 'b) Sum.t) This.s
+ val +` : ('a, 'x) s * ('b, 'y) s -> ('a, 'b) Sum.t This.s
val C0 : Generics.Con.t -> Unit.t This.s
val C1 : Generics.Con.t -> ('a, 'x) t -> 'a This.s
val data : ('a, 'x) s -> 'a This.t
More information about the MLton-commit
mailing list