[MLton-commit] r5808

Vesa Karvonen vesak at mlton.org
Sun Jul 29 23:40:04 PDT 2007


Introduced substructures Univ.Iso and Univ.Emb as well as type
abbreviations Univ.Iso.t and Univ.Emb.t.

----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/data/univ-exn.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/data/univ-ref.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/io/reader.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/io/writer.sml
A   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/univ.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/unsealed.cm
U   mltonlib/trunk/com/ssh/extended-basis/unstable/public/data/univ.sig
U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
U   mltonlib/trunk/com/ssh/misc-util/unstable/arbitrary.sml
U   mltonlib/trunk/org/mlton/vesak/tech/generics/lgd.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml	2007-07-30 03:17:57 UTC (rev 5807)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml	2007-07-30 06:40:01 UTC (rev 5808)
@@ -60,4 +60,3 @@
 structure ShiftOp = struct type 'a t = 'a * Word.t -> 'a end
 structure BinFn = struct type ('a, 'b) t = 'a Sq.t -> 'b end
 structure IEEEReal = BasisIEEEReal
-structure Univ = struct exception Univ end

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/data/univ-exn.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/data/univ-exn.sml	2007-07-30 03:17:57 UTC (rev 5807)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/data/univ-exn.sml	2007-07-30 06:40:01 UTC (rev 5808)
@@ -1,25 +1,29 @@
-(* Copyright (C) 2006 SSH Communications Security, Helsinki, Finland
+(* Copyright (C) 2006-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 UnivExn :> UNIV = struct
-   open Univ
+   exception Univ
 
    type t = Exn.t
 
-   fun newIso () = let
-      exception U of 'a
-   in
-      (U, fn U ? => ? | _ => raise Univ)
+   structure Iso = struct
+      type 'a t = ('a, t) Iso.t
+      fun new () = let
+         exception U of 'a
+      in
+         (U, fn U ? => ? | _ => raise Univ)
+      end
    end
 
-   fun newEmb () = let
-      exception U of 'a
-   in
-      (U, fn U ? => SOME ? | _ => NONE)
+   structure Emb = struct
+      type 'a t = ('a, t) Emb.t
+      fun new () = let
+         exception U of 'a
+      in
+         (U, fn U ? => SOME ? | _ => NONE)
+      end
    end
 end
-
-structure Univ :> UNIV = UnivExn

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/data/univ-ref.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/data/univ-ref.sml	2007-07-30 03:17:57 UTC (rev 5807)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/data/univ-ref.sml	2007-07-30 06:40:01 UTC (rev 5808)
@@ -1,30 +1,33 @@
-(* Copyright (C) 2006 SSH Communications Security, Helsinki, Finland
+(* Copyright (C) 2006-2007 SSH Communications Security, Helsinki, Finland
  *
  * MLton is released under a BSD-style license.
  * See the file MLton-LICENSE for details.
  *)
 
 structure UnivRef :> UNIV = struct
-   open Univ
+   exception Univ
 
    datatype t =
       IN of {clear : Unit.t Effect.t,
              store : Unit.t Effect.t}
 
-   local
-      fun mk deref = let
-         val r = ref NONE
-      in
-         (fn a =>
-             IN {clear = fn () => r := NONE,
-                 store = fn () => r := SOME a},
-          fn IN {clear, store} =>
-             deref ((store () ; !r) before clear ()))
-      end
+   fun mk deref = let
+      val r = ref NONE
    in
-      fun newIso () = mk (fn SOME ? => ? | NONE => raise Univ)
-      fun newEmb () = mk Fn.id
+      (fn a =>
+          IN {clear = fn () => r := NONE,
+              store = fn () => r := SOME a},
+       fn IN {clear, store} =>
+          deref ((store () ; !r) before clear ()))
    end
+
+   structure Iso = struct
+      type 'a t = ('a, t) Iso.t
+      fun new () = mk (fn SOME ? => ? | NONE => raise Univ)
+   end
+
+   structure Emb = struct
+      type 'a t = ('a, t) Emb.t
+      fun new () = mk Fn.id
+   end
 end
-
-structure Univ :> UNIV = UnivRef

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/io/reader.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/io/reader.sml	2007-07-30 03:17:57 UTC (rev 5807)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/io/reader.sml	2007-07-30 06:40:01 UTC (rev 5808)
@@ -22,7 +22,7 @@
    open Monad
 
    fun polymorphically aM2bM = let
-      val (to, from) = Univ.newIso ()
+      val (to, from) = Univ.Iso.new ()
       fun map f = Option.map (Pair.map (Fn.id, f))
    in
       Fn.map (to, map from) o aM2bM o Fn.map (from, map to)

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/io/writer.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/io/writer.sml	2007-07-30 03:17:57 UTC (rev 5807)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/io/writer.sml	2007-07-30 06:40:01 UTC (rev 5808)
@@ -12,7 +12,7 @@
    fun map b2a wA = wA o Pair.map (b2a, Fn.id)
 
    fun polymorphically uA2uB = let
-      val (to, from) = Univ.newIso ()
+      val (to, from) = Univ.Iso.new ()
       fun map f = Pair.map (Fn.id, f)
    in
       Fn.map (map to, from) o uA2uB o Fn.map (map from, to)

Copied: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/univ.sml (from rev 5753, mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/mlton/univ.sml)
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/mlton/univ.sml	2007-07-10 07:39:05 UTC (rev 5753)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/univ.sml	2007-07-30 06:40:01 UTC (rev 5808)
@@ -0,0 +1,7 @@
+(* Copyright (C) 2006-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 Univ :> UNIV = UnivExn

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/unsealed.cm	2007-07-30 03:17:57 UTC (rev 5807)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/ml/smlnj/unsealed.cm	2007-07-30 06:40:01 UTC (rev 5808)
@@ -78,3 +78,4 @@
    ../../../public/lazy/lazy.sig
    ext.sml
    sigs.cm
+   univ.sml

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/data/univ.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/data/univ.sig	2007-07-30 03:17:57 UTC (rev 5807)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/data/univ.sig	2007-07-30 06:40:01 UTC (rev 5808)
@@ -10,14 +10,18 @@
  * It is important to understand that the universal type is not
  * structural.  Consider the following code:
  *
- *> val a : (Int.t, Univ.t) Emb.t = Univ.newEmb ()
- *> val b : (Int.t, Univ.t) Emb.t = Univ.newEmb ()
- *
+ *> local
+ *>    open Univ.Emb
+ *> in
+ *>    val a : Int.t t = new ()
+ *>    val b : Int.t t = new ()
+ *> end
+ *>
  *> val x : Univ.t = Emb.to a 5
  *
  * Now {Emb.from a x} is {SOME 5}, but {Emb.from b x} is {NONE}.  The
- * embeddings {a} and {b} have different identity.  Each time {newEmb} or
- * {newIso} is called, a new identity is created.
+ * embeddings {a} and {b} have different identity.  Each time {Emb.new} or
+ * {Iso.new} is called, a new identity is created.
  *
  * See also: [http://mlton.org/UniversalType]
  *)
@@ -26,19 +30,27 @@
    (** The universal type. *)
 
    exception Univ
-   (** Raised in case of a mismatched projection. *)
+   (** Raised in case of a mismatched, non-optional, projection. *)
 
-   val newIso : ('a, t) Iso.t Thunk.t
-   (**
-    * Creates a new embedding of an arbitrary type {'a} to the universal
-    * type {t} and returns it as an isomorphism whose projection function
-    * is partial.  The projection function raises {Univ} in case of a
-    * mismatch.
-    *)
+   structure Iso : sig
+      type 'a t = ('a, t) Iso.t
 
-   val newEmb : ('a, t) Emb.t Thunk.t
-   (**
-    * Creates a new embedding of an arbitrary type {'a} to the universal
-    * type {t}.
-    *)
+      val new : 'a t Thunk.t
+      (**
+       * Creates a new embedding of an arbitrary type {'a} to the
+       * universal type {t} and returns it as an isomorphism whose
+       * projection function is partial.  The projection function raises
+       * {Univ} in case of a mismatch.
+       *)
+   end
+
+   structure Emb : sig
+      type 'a t = ('a, t) Emb.t
+
+      val new : 'a t Thunk.t
+      (**
+       * Creates a new embedding of an arbitrary type {'a} to the
+       * universal type {t}.
+       *)
+   end
 end

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml	2007-07-30 03:17:57 UTC (rev 5807)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml	2007-07-30 06:40:01 UTC (rev 5808)
@@ -22,7 +22,7 @@
 
    structure G = RandomGen and I = Int and R = Real and W = Word
 
-   fun universally ? = G.mapUnOp (Univ.newIso ()) ?
+   fun universally ? = G.mapUnOp (Univ.Iso.new ()) ?
    val map = G.Monad.map
    val op >>= = G.>>=
 

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/arbitrary.sml	2007-07-30 03:17:57 UTC (rev 5807)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/arbitrary.sml	2007-07-30 06:40:01 UTC (rev 5808)
@@ -45,7 +45,7 @@
               typ : 'a Typ.t}
    type 'a arbitrary_t = 'a t
 
-   fun universally ? = G.mapUnOp (Univ.newIso ()) ?
+   fun universally ? = G.mapUnOp (Univ.Iso.new ()) ?
 
    val map = G.Monad.map
    val op >>= = G.>>=

Modified: mltonlib/trunk/org/mlton/vesak/tech/generics/lgd.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/generics/lgd.sml	2007-07-30 03:17:57 UTC (rev 5807)
+++ mltonlib/trunk/org/mlton/vesak/tech/generics/lgd.sml	2007-07-30 06:40:01 UTC (rev 5808)
@@ -43,14 +43,11 @@
  *)
 
 
-(* First a couple of shorthands. *)
+(* First a shorthand. *)
 
 val op <--> = Iso.<-->
 
-type u = Univ.t
-type 'a e = ('a, u) Iso.t
 
-
 (* Signature for "structural cases". *)
 
 signature CASES = sig
@@ -112,12 +109,16 @@
 
 structure Type (* : CASES -- Sealed later! *) = struct
    open Type
-   datatype 'a t = T of Type.t * 'a e
+   datatype 'a t = T of Type.t * 'a Univ.Iso.t
 
-   val isoUnit : Unit.t e                   = Univ.newIso ()
-   val isoInt  : Int.t e                    = Univ.newIso ()
-   val isoSum  : (u, u) Sum.t Thunk.t e     = Univ.newIso ()
-   val isoProd : (u, u) Product.t Thunk.t e = Univ.newIso ()
+   local
+      open Univ.Iso
+   in
+      val isoUnit : Unit.t t                             = new ()
+      val isoInt  : Int.t t                              = new ()
+      val isoSum  : (Univ.t, Univ.t) Sum.t Thunk.t t     = new ()
+      val isoProd : (Univ.t, Univ.t) Product.t Thunk.t t = new ()
+   end
 
    val unit = T (UNIT, isoUnit)
    val int = T (INT, isoInt)
@@ -144,9 +145,9 @@
 end
 
 (*
- * The universal type {u} and isomorphism {e} above implement the "poor
- * man's existentials" mentioned at the beginning.  See [1] for the
- * (trivial) Haskell version using existentials.
+ * The universal type and isomorphisms above implement the "poor man's
+ * existentials" mentioned at the beginning.  See [1] for the (trivial)
+ * Haskell version using existentials.
  *
  * Note the thunks in the sum and product cases.  The idea is to perform
  * coercions lazily.  For example, if you evaluate




More information about the MLton-commit mailing list