[MLton-commit] r6019
Vesa Karvonen
vesak at mlton.org
Thu Sep 13 06:04:57 PDT 2007
Added a datatype corresponding to type representation expressions and a
generic for building them. This is unlikely to be useful in applications,
but might be useful in communicating the semantics of some generic
algorithms.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/ty.sml
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/ty.sig
A mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-09-13 08:53:37 UTC (rev 6018)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-09-13 13:04:55 UTC (rev 6019)
@@ -20,6 +20,7 @@
../../../public/layered-rep.sig
../../../public/open-cases.sig
../../../public/open-rep.sig
+ ../../../public/ty.sig
../../../public/value/arbitrary.sig
../../../public/value/data-rec-info.sig
../../../public/value/dynamic.sig
@@ -32,6 +33,7 @@
../../../public/value/seq.sig
../../../public/value/some.sig
../../../public/value/transform.sig
+ ../../../public/value/type-exp.sig
../../../public/value/type-hash.sig
../../../public/value/type-info.sig
../../close-generic.fun
@@ -44,6 +46,7 @@
../../reg-basis-exns.fun
../../root-generic.sml
../../sml-syntax.sml
+ ../../ty.sml
../../value/arbitrary.sml
../../value/data-rec-info.sml
../../value/debug.sml
@@ -57,6 +60,7 @@
../../value/seq.sml
../../value/some.sml
../../value/transform.sml
+ ../../value/type-exp.sml
../../value/type-hash.sml
../../value/type-info.sml
../../with-extra.fun
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/ty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ty.sml 2007-09-13 08:53:37 UTC (rev 6018)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ty.sml 2007-09-13 13:04:55 UTC (rev 6019)
@@ -0,0 +1,50 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+structure Ty :> TY = struct
+ structure Product = struct
+ datatype 'elem t = *` of 'elem t Sq.t
+ | ELEM of 'elem
+ | ISO of 'elem t
+ end
+
+ structure Sum = struct
+ datatype 'ty t = +` of 'ty t Sq.t
+ | C0 of Generics.Con.t
+ | C1 of Generics.Con.t * 'ty
+ | ISO of 'ty t
+ end
+
+ structure Var = struct
+ type t = Unit.t Ref.t
+ fun new () = ref ()
+ end
+
+ structure Con0 = struct
+ datatype t = BOOL | CHAR | EXN | FIXED_INT | INT | LARGE_INT
+ | LARGE_REAL | LARGE_WORD | REAL | STRING | UNIT | WORD
+ | WORD32 | WORD64 | WORD8
+ end
+
+ structure Con1 = struct
+ datatype t = ARRAY | LIST | REF | VECTOR
+ end
+
+ structure Con2 = struct
+ datatype t = ARROW
+ end
+
+ datatype 'var t =
+ DATA of 'var t Sum.t
+ | CON0 of Con0.t
+ | CON1 of Con1.t * 'var t
+ | CON2 of Con2.t * 'var t Sq.t
+ | FIX of 'var * 'var t
+ | ISO of 'var t
+ | RECORD of (Generics.Label.t * 'var t) Product.t
+ | TUPLE of 'var t Product.t
+ | VAR of 'var
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/ty.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml 2007-09-13 08:53:37 UTC (rev 6018)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml 2007-09-13 13:04:55 UTC (rev 6019)
@@ -0,0 +1,84 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+functor WithTypeExp (Arg : OPEN_CASES) : TYPE_EXP_CASES = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ (* SML/NJ workaround --> *)
+
+ open Ty Ty.Con0 Ty.Con1 Ty.Con2
+
+ fun mapElem f =
+ fn Product.*` (a, b) => Product.*` (mapElem f a, mapElem f b)
+ | Product.ISO b => Product.ISO (mapElem f b)
+ | Product.ELEM e => Product.ELEM (f e)
+
+ structure TypeExp = LayerRep
+ (structure Outer = Arg.Rep
+ structure Closed = struct
+ type 'a t = Var.t Ty.t
+ type 'a s = Var.t Ty.t Ty.Sum.t
+ type ('a, 'k) p = (Generics.Label.t Option.t * Var.t Ty.t) Ty.Product.t
+ end)
+
+ val ty = TypeExp.This.getT
+
+ structure Layered = LayerCases
+ (structure Outer = Arg and Result = TypeExp and Rep = TypeExp.Closed
+
+ fun iso bT _ = ISO bT
+ fun isoProduct bP _ = Product.ISO bP
+ fun isoSum bS _ = Sum.ISO bS
+
+ fun op *` (aT, bT) = Product.*` (aT, bT)
+ fun T aT = Product.ELEM (NONE, aT)
+ fun R l aT = Product.ELEM (SOME l, aT)
+ fun tuple aP = TUPLE (mapElem Pair.snd aP)
+ fun record aP = RECORD (mapElem (Pair.map (valOf, id)) aP)
+
+ fun op +` (aT, bT) = Sum.+` (aT, bT)
+ val unit = CON0 UNIT
+ fun C0 c = Sum.C0 c
+ fun C1 c aT = Sum.C1 (c, aT)
+ val data = DATA
+
+ fun Y ? =
+ Tie.pure (fn () => let
+ val v = Var.new ()
+ in
+ (VAR v, fn e => FIX (v, e))
+ end) ?
+
+ fun op --> aTbT = CON2 (ARROW, aTbT)
+
+ 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)
+
+ val fixedInt = CON0 FIXED_INT
+ val largeInt = CON0 LARGE_INT
+
+ 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 word8 = CON0 WORD8
+ val word32 = CON0 WORD32
+ val word64 = CON0 WORD64)
+
+ open Layered
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-13 08:53:37 UTC (rev 6018)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-13 13:04:55 UTC (rev 6019)
@@ -27,6 +27,9 @@
detail/generics.sml
end
+ public/ty.sig
+ detail/ty.sml
+
(* Concepts *)
public/closed-rep.sig
@@ -118,6 +121,9 @@
public/value/transform.sig
detail/value/transform.sml
+
+ public/value/type-exp.sig
+ detail/value/type-exp.sml
in
public/export.sml
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-13 08:53:37 UTC (rev 6018)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-13 13:04:55 UTC (rev 6019)
@@ -24,6 +24,9 @@
signature GENERICS_UTIL = GENERICS_UTIL
structure GenericsUtil : GENERICS_UTIL = GenericsUtil
+signature TY = TY
+structure Ty : TY = Ty
+
structure RootGeneric : OPEN_CASES = RootGeneric
(** == Framework Functors == *)
@@ -103,6 +106,9 @@
* - exception constructors are globally unique.
*)
+signature TYPE_EXP = TYPE_EXP and TYPE_EXP_CASES = TYPE_EXP_CASES
+functor WithTypeExp (Arg : OPEN_CASES) : TYPE_EXP_CASES = WithTypeExp (Arg)
+
signature TYPE_INFO = TYPE_INFO and TYPE_INFO_CASES = TYPE_INFO_CASES
functor WithTypeInfo (Arg : OPEN_CASES) : TYPE_INFO_CASES = WithTypeInfo (Arg)
Added: mltonlib/trunk/com/ssh/generic/unstable/public/ty.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/ty.sig 2007-09-13 08:53:37 UTC (rev 6018)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/ty.sig 2007-09-13 13:04:55 UTC (rev 6019)
@@ -0,0 +1,54 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * Signature for the {Ty} module that defines a datatype corresponding to
+ * type representation expressions.
+ *)
+signature TY = sig
+ structure Product : sig
+ datatype 'elem t = *` of 'elem t Sq.t
+ | ELEM of 'elem
+ | ISO of 'elem t
+ end
+
+ structure Sum : sig
+ datatype 'ty t = +` of 'ty t Sq.t
+ | C0 of Generics.Con.t
+ | C1 of Generics.Con.t * 'ty
+ | ISO of 'ty t
+ end
+
+ structure Var : sig
+ eqtype t
+ val new : t Thunk.t
+ end
+
+ structure Con0 : sig
+ datatype t = BOOL | CHAR | EXN | FIXED_INT | INT | LARGE_INT
+ | LARGE_REAL | LARGE_WORD | REAL | STRING | UNIT | WORD
+ | WORD32 | WORD64 | WORD8
+ end
+
+ structure Con1 : sig
+ datatype t = ARRAY | LIST | REF | VECTOR
+ end
+
+ structure Con2 : sig
+ datatype t = ARROW
+ end
+
+ datatype 'var t =
+ DATA of 'var t Sum.t
+ | CON0 of Con0.t
+ | CON1 of Con1.t * 'var t
+ | CON2 of Con2.t * 'var t Sq.t
+ | FIX of 'var * 'var t
+ | ISO of 'var t
+ | RECORD of (Generics.Label.t * 'var t) Product.t
+ | TUPLE of 'var t Product.t
+ | VAR of 'var
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/ty.sig
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig 2007-09-13 08:53:37 UTC (rev 6018)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig 2007-09-13 13:04:55 UTC (rev 6019)
@@ -0,0 +1,20 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * Signature for generic type representation expression.
+ *)
+signature TYPE_EXP = sig
+ structure TypeExp : OPEN_REP
+
+ val ty : ('a, 'x) TypeExp.t -> Ty.Var.t Ty.t
+ (** Returns the type expression given a type representation. *)
+end
+
+signature TYPE_EXP_CASES = sig
+ include OPEN_CASES TYPE_EXP
+ sharing Rep = TypeExp
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list