[MLton-commit] r5804
Vesa Karvonen
vesak at mlton.org
Sat Jul 28 21:46:34 PDT 2007
A generic, structural, dynamic type.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.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/value/dynamic.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-07-28 22:52:59 UTC (rev 5803)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-07-29 04:46:33 UTC (rev 5804)
@@ -22,6 +22,7 @@
../../../public/open-generic-rep.sig
../../../public/open-generic.sig
../../../public/value/arbitrary.sig
+ ../../../public/value/dynamic.sig
../../../public/value/eq.sig
../../../public/value/hash.sig
../../../public/value/ord.sig
@@ -37,6 +38,7 @@
../../root-generic.sml
../../sml-syntax.sml
../../value/arbitrary.sml
+ ../../value/dynamic.sml
../../value/eq.sml
../../value/hash.sml
../../value/ord.sml
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml 2007-07-28 22:52:59 UTC (rev 5803)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml 2007-07-29 04:46:33 UTC (rev 5804)
@@ -0,0 +1,111 @@
+(* 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 WithDynamic (Arg : OPEN_GENERIC) : DYNAMIC_GENERIC = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix <-->
+ (* SML/NJ workaround --> *)
+
+ structure Dyn = 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
+ | 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 Dyn
+ end
+
+ open Dyn
+
+ val op <--> = Iso.<-->
+
+ fun isoUnsupported text = (failing text, failing text)
+
+ structure Dynamic =
+ LayerGenericRep
+ (structure Outer = Arg.Rep
+ structure Closed = MkClosedGenericRep (type 'a t = ('a, t) Iso.t))
+
+ open Dynamic.This
+
+ fun toDyn t = Iso.to (getT t)
+ fun fromDyn t d = SOME (Iso.from (getT t) d) handle Dyn.Dyn => NONE
+
+ structure Layered = LayerGeneric
+ (structure Outer = Arg and Result = Dynamic and Rep = Dynamic.Closed
+
+ fun iso bId aIb = Iso.<--> (bId, aIb)
+ val isoProduct = iso
+ val isoSum = iso
+
+ fun op *` ((l2d, d2l), (r2d, d2r)) =
+ (PRODUCT, fn PRODUCT ? => ? | _ => raise Dyn) <-->
+ (Product.map (l2d, r2d), Product.map (d2l, d2r))
+ val T = id
+ fun R _ = id
+ val tuple = id
+ val record = id
+
+ fun op +` ((l2d, d2l), (r2d, d2r)) =
+ (SUM, fn SUM ? => ? | _ => raise Dyn) <-->
+ (Sum.map (l2d, r2d), Sum.map (d2l, d2r))
+ val unit = (fn () => UNIT, fn UNIT => () | _ => raise Dyn)
+ fun C0 _ = unit
+ fun C1 _ = id
+ val data = id
+
+ fun Y ? = let open Tie in tuple2 (function, function) end ?
+
+ fun op --> ((a2d, d2a), (b2d, d2b)) =
+ (ARROW, fn ARROW ? => ? | _ => raise Dyn) <-->
+ (Fn.map (d2a, b2d), Fn.map (a2d, d2b))
+
+ val exn = (EXN, fn EXN ? => ? | _ => raise Dyn)
+ fun regExn _ _ = ()
+
+ fun list (x2d, d2x) =
+ (LIST, fn LIST ? => ? | _ => raise Dyn) <-->
+ (List.map x2d, List.map d2x)
+ fun vector (x2d, d2x) =
+ (VECTOR, fn VECTOR ? => ? | _ => raise Dyn) <-->
+ (Vector.map x2d, Vector.map d2x)
+
+ fun array _ = isoUnsupported "Dyn.array unsupported"
+ fun refc _ = isoUnsupported "Dyn.refc unsupported"
+
+ val largeInt = (LARGE_INT, fn LARGE_INT ? => ? | _ => raise Dyn)
+ val largeWord = (LARGE_WORD, fn LARGE_WORD ? => ? | _ => raise Dyn)
+ val largeReal = (LARGE_REAL, fn LARGE_REAL ? => ? | _ => raise Dyn)
+
+ val bool = (BOOL, fn BOOL ? => ? | _ => raise Dyn)
+ val char = (CHAR, fn CHAR ? => ? | _ => raise Dyn)
+ val int = (INT, fn INT ? => ? | _ => raise Dyn)
+ val real = (REAL, fn REAL ? => ? | _ => raise Dyn)
+ val string = (STRING, fn STRING ? => ? | _ => raise Dyn)
+ val word = (WORD, fn WORD ? => ? | _ => raise Dyn)
+
+ val word8 = (WORD8, fn WORD8 ? => ? | _ => raise Dyn)
+ val word32 = (WORD32, fn WORD32 ? => ? | _ => raise Dyn)
+ val word64 = (WORD64, fn WORD64 ? => ? | _ => raise Dyn))
+
+ open Layered
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/dynamic.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-07-28 22:52:59 UTC (rev 5803)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-07-29 04:46:33 UTC (rev 5804)
@@ -71,6 +71,9 @@
public/value/arbitrary.sig
detail/value/arbitrary.sml
+ public/value/dynamic.sig
+ detail/value/dynamic.sml
+
public/value/eq.sig
detail/value/eq.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-07-28 22:52:59 UTC (rev 5803)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-07-29 04:46:33 UTC (rev 5804)
@@ -26,6 +26,9 @@
signature ARBITRARY = ARBITRARY
signature ARBITRARY_GENERIC = ARBITRARY_GENERIC
+signature DYNAMIC = DYNAMIC
+signature DYNAMIC_GENERIC = DYNAMIC_GENERIC
+
signature EQ = EQ
signature EQ_GENERIC = EQ_GENERIC
@@ -134,6 +137,8 @@
functor WithArbitrary (Arg : WITH_ARBITRARY_DOM) : ARBITRARY_GENERIC =
WithArbitrary (Arg)
+functor WithDynamic (Arg : OPEN_GENERIC) : DYNAMIC_GENERIC = WithDynamic (Arg)
+
functor WithEq (Arg : OPEN_GENERIC) : EQ_GENERIC = WithEq (Arg)
signature WITH_HASH_DOM = WITH_HASH_DOM
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/dynamic.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/dynamic.sig 2007-07-28 22:52:59 UTC (rev 5803)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/dynamic.sig 2007-07-29 04:46:33 UTC (rev 5804)
@@ -0,0 +1,66 @@
+(* 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 a generic, structural, dynamic type.
+ *
+ * The coercion functions {toDyn} and {fromDyn} take time relative to the
+ * size of the structural encoding of the values. Mutable types, {ref}s
+ * and {array}s, are not supported---encoding would not preserve the
+ * identity of mutable values. Arrow types are supported, but coercing a
+ * function to a dynamic value and then back returns a function wrapped
+ * with coercions.
+ *
+ * In contrast to the universal type provided by the {Univ} structure, the
+ * provided dynamic type is structural. Consider the following code:
+ *
+ *> val x = toDyn (list int) [5]
+ *> val SOME [5] = fromDyn (list int) x
+ *
+ * Even though the generic representation {list int} is computed twice,
+ * the above code evaluates without raising a {Bind} exception.
+ *
+ * However, it is possible to have multiple different structural encodings
+ * of a type. Coercions between values of different structural encodings
+ * may (or may not) fail.
+ *
+ * It is also possible to have multiple different types that have the same
+ * structural encoding. Such types can not be told apart and coercions
+ * between values of such types do not fail (by default).
+ *
+ * This design is experimental. An interesting design alternative would
+ * be to allow more coercions to occur in {fromDyn}. For example,
+ * coercions between different scalar sizes and types could be performed
+ * implicitly. It would also be possible to coerce between vectors and
+ * lists of different element type. One could even implicitly read values
+ * from strings. It would also be possible to maximize structural sharing
+ * during coercions. Mutable types could be supported up to structural
+ * isomorphism of the values. It might also make sense to provide a
+ * read-only view of the encoding. That would allow clients to implement
+ * various functions outside the dynamic module. Alternatively, many
+ * interesting primitives could be added, e.g. {apply : t -> t -> t}.
+ * Feedback on the design is welcome!
+ *
+ * A dynamic type could also be implemented through pickling. However,
+ * functions can not be pickled in SML and pickling of exceptions requires
+ * registering exception constructors.
+ *)
+signature DYNAMIC = sig
+ structure Dynamic : OPEN_GENERIC_REP
+
+ structure Dyn : sig
+ type t
+ exception Dyn
+ end
+
+ val toDyn : ('a, 'x) Dynamic.t -> 'a -> Dyn.t
+ val fromDyn : ('a, 'x) Dynamic.t -> Dyn.t -> 'a Option.t
+end
+
+signature DYNAMIC_GENERIC = sig
+ include OPEN_GENERIC DYNAMIC
+ sharing Rep = Dynamic
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/dynamic.sig
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list