[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