[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