[MLton-commit] r5783

Vesa Karvonen vesak at mlton.org
Thu Jul 19 19:32:13 PDT 2007


Renamed generic Dummy -> Some, fixed it to work properly on recursive
datatypes, and tweaked the signature of SOME.

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

U   mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
U   mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
D   mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml
A   mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml
U   mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U   mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
D   mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sig
U   mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig
A   mltonlib/trunk/com/ssh/generic/unstable/public/value/some.sig

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

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml	2007-07-20 00:29:22 UTC (rev 5782)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml	2007-07-20 02:32:11 UTC (rev 5783)
@@ -7,24 +7,31 @@
 structure Generic :> sig
    include GENERIC_EXTRA
    include ARBITRARY sharing Open.Rep = Arbitrary
-   include DUMMY     sharing Open.Rep = Dummy
    include EQ        sharing Open.Rep = Eq
    include HASH      sharing Open.Rep = Hash
    include ORD       sharing Open.Rep = Ord
    include PRETTY    sharing Open.Rep = Pretty
+   include SOME      sharing Open.Rep = Some
    include TYPE_INFO sharing Open.Rep = TypeInfo
 end = struct
    structure Open = RootGeneric
 
+   structure Open = WithTypeInfo  (Open) open Open structure TypeInfo = Open
+
    structure Open = WithPretty    (Open) open Open
-   structure Open = WithTypeInfo  (Open) open Open structure TypeInfo = Open
    structure Open = WithEq        (Open) open Open
    structure Open = WithOrd       (Open) open Open
-   structure Open = WithDummy     (Open) open Open
 
    structure Open = struct
       open TypeInfo Open
       structure TypeInfo = Rep
+   end
+
+   structure Open = WithSome      (Open) open Open
+
+   structure Open = struct
+      open TypeInfo Open
+      structure TypeInfo = Rep
       structure RandomGen = RanQD1Gen
    end
 
@@ -37,13 +44,13 @@
 
    structure Open = WithHash      (Open) open Open
 
-   structure Arbitrary = Open.Rep
-   structure Dummy     = Open.Rep
-   structure Eq        = Open.Rep
-   structure Hash      = Open.Rep
-   structure Ord       = Open.Rep
-   structure Pretty    = Open.Rep
-   structure TypeInfo  = Open.Rep
+   structure Arbitrary = Rep
+   structure Some      = Rep
+   structure Eq        = Rep
+   structure Hash      = Rep
+   structure Ord       = Rep
+   structure Pretty    = Rep
+   structure TypeInfo  = Rep
 
    structure Generic = struct
       structure Open = Open

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-20 00:29:22 UTC (rev 5782)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm	2007-07-20 02:32:11 UTC (rev 5783)
@@ -22,12 +22,12 @@
    ../../../public/open-generic-rep.sig
    ../../../public/open-generic.sig
    ../../../public/value/arbitrary.sig
-   ../../../public/value/dummy.sig
    ../../../public/value/eq.sig
    ../../../public/value/hash.sig
    ../../../public/value/ord.sig
    ../../../public/value/pickle.sig
    ../../../public/value/pretty.sig
+   ../../../public/value/some.sig
    ../../../public/value/type-info.sig
    ../../close-generic.fun
    ../../generics-util.sml
@@ -37,12 +37,12 @@
    ../../root-generic.sml
    ../../sml-syntax.sml
    ../../value/arbitrary.sml
-   ../../value/dummy.sml
    ../../value/eq.sml
    ../../value/hash.sml
    ../../value/ord.sml
    ../../value/pickle.sml
    ../../value/pretty.sml
+   ../../value/some.sml
    ../../value/type-info.sml
    ../../with-extra.fun
    extensions.cm

Deleted: mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml	2007-07-20 00:29:22 UTC (rev 5782)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml	2007-07-20 02:32:11 UTC (rev 5783)
@@ -1,71 +0,0 @@
-(* 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 WithDummy (Arg : OPEN_GENERIC) : DUMMY_GENERIC = struct
-   (* <-- SML/NJ workaround *)
-   open TopLevel
-   (* SML/NJ workaround --> *)
-
-   structure Dummy =
-      LayerGenericRep (structure Outer = Arg.Rep
-                       structure Closed = MkClosedGenericRep (Thunk))
-
-   open Dummy.This
-
-   exception Dummy of Exn.t
-
-   fun dummy a = getT a () handle e => raise Dummy e
-   fun withDummy v = mapT (const (fn () => valOf v))
-
-   structure Layered = LayerGeneric
-     (structure Outer = Arg and Result = Dummy and Rep = Dummy.Closed
-
-      fun iso b (_, b2a) = b2a o b
-      val isoProduct = iso
-      val isoSum     = iso
-
-      val op *`  = Product.thunk
-      val T      = id
-      fun R _    = id
-      val tuple  = id
-      val record = id
-
-      fun op +` (a, b) = fn () => INL (a ()) handle _ => INR (b ())
-      val unit = fn () => ()
-      fun C0 _ = unit
-      fun C1 _ = id
-      val data = id
-
-      val Y = Tie.function
-
-      fun op --> _ = fn () => failing "Dummy.-->"
-
-      val exn = fn () => Empty
-      fun regExn _ _ = ()
-
-      fun array  _ = Array.empty
-      fun vector _ = Vector.empty
-      fun list   _ = fn () => []
-
-      fun refc a = ref o a
-
-      val largeInt  = fn () => 0   : LargeInt.t
-      val largeReal = fn () => 0.0 : LargeReal.t
-      val largeWord = fn () => 0w0 : LargeWord.t
-
-      val bool   = fn () => false
-      val char   = fn () => #"\000"
-      val int    = fn () => 0
-      val real   = fn () => 0.0
-      val string = fn () => ""
-      val word   = fn () => 0w0
-
-      val word8  = fn () => 0w0 : Word8.t
-      val word32 = fn () => 0w0 : Word32.t
-      val word64 = fn () => 0w0 : Word64.t)
-
-   open Layered
-end

Copied: mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml (from rev 5782, mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml)
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/dummy.sml	2007-07-20 00:29:22 UTC (rev 5782)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml	2007-07-20 02:32:11 UTC (rev 5783)
@@ -0,0 +1,89 @@
+(* 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 WithSome (Arg : WITH_SOME_DOM) : SOME_GENERIC = struct
+   (* <-- SML/NJ workaround *)
+   open TopLevel
+   (* SML/NJ workaround --> *)
+
+   structure Some =
+      LayerGenericRep (structure Outer = Arg.Rep
+                       structure Closed = MkClosedGenericRep (Thunk))
+
+   open Some.This
+
+   exception Nothing of Exn.t
+
+   fun some a = getT a () handle e => raise Nothing e
+   fun withNone ? = mapT (const (raising Option)) ?
+   fun withSome v = mapT (const (const v))
+
+   structure Layered = LayerDepGeneric
+     (structure Outer = Arg and Result = Some
+
+      fun iso' b (_, b2a) = b2a o b
+      fun iso        ? = iso' (getT ?)
+      fun isoProduct ? = iso' (getP ?)
+      fun isoSum     ? = iso' (getS ?)
+
+      fun op *` (a, b) = Product.thunk (getP a, getP b)
+      val T      = getT
+      fun R _    = getT
+      val tuple  = getP
+      val record = getP
+
+      fun op +` (aS, bS) = let
+         val a = getS aS
+         val b = getS bS
+      in
+         (* We are careful here to avoid diverging. *)
+         case (Arg.hasBaseCase aS, Arg.hasBaseCase bS) of
+            (true, false) => INL o a
+          | (false, true) => INR o b
+          | _             => fn () => INL (a ()) handle _ => INR (b ())
+      end
+      val unit = fn () => ()
+      fun C0 _ = unit
+      fun C1 _ = getT
+      val data = getS
+
+      val Y = Tie.function
+
+      fun op --> _ = fn () => failing "Some.-->"
+      (* An alternative implementation would be
+       *
+       *> fun op --> (_, b) = fn () => getT b o ignore
+       *
+       * but it could mask defects where a dummy function is used by
+       * mistake.
+       *)
+
+      val exn = fn () => Empty
+      fun regExn _ _ = ()
+
+      fun array  _ = Array.empty
+      fun vector _ = Vector.empty
+      fun list   _ = fn () => []
+
+      fun refc a = ref o getT a
+
+      val largeInt  = fn () => 0   : LargeInt.t
+      val largeReal = fn () => 0.0 : LargeReal.t
+      val largeWord = fn () => 0w0 : LargeWord.t
+
+      val bool   = fn () => false
+      val char   = fn () => #"\000"
+      val int    = fn () => 0
+      val real   = fn () => 0.0
+      val string = fn () => ""
+      val word   = fn () => 0w0
+
+      val word8  = fn () => 0w0 : Word8.t
+      val word32 = fn () => 0w0 : Word32.t
+      val word64 = fn () => 0w0 : Word64.t)
+
+   open Layered
+end

Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb	2007-07-20 00:29:22 UTC (rev 5782)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb	2007-07-20 02:32:11 UTC (rev 5783)
@@ -65,12 +65,12 @@
          public/value/type-info.sig
          detail/value/type-info.sml
 
+         public/value/some.sig
+         detail/value/some.sml
+
          public/value/arbitrary.sig
          detail/value/arbitrary.sml
 
-         public/value/dummy.sig
-         detail/value/dummy.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-20 00:29:22 UTC (rev 5782)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml	2007-07-20 02:32:11 UTC (rev 5783)
@@ -26,9 +26,6 @@
 signature ARBITRARY = ARBITRARY
 signature ARBITRARY_GENERIC = ARBITRARY_GENERIC
 
-signature DUMMY = DUMMY
-signature DUMMY_GENERIC = DUMMY_GENERIC
-
 signature EQ = EQ
 signature EQ_GENERIC = EQ_GENERIC
 
@@ -44,6 +41,9 @@
 signature PRETTY = PRETTY
 signature PRETTY_GENERIC = PRETTY_GENERIC
 
+signature SOME = SOME
+signature SOME_GENERIC = SOME_GENERIC
+
 signature TYPE_INFO = TYPE_INFO
 signature TYPE_INFO_GENERIC = TYPE_INFO_GENERIC
 
@@ -134,8 +134,6 @@
 functor WithArbitrary (Arg : WITH_ARBITRARY_DOM) : ARBITRARY_GENERIC =
    WithArbitrary (Arg)
 
-functor WithDummy (Arg : OPEN_GENERIC) : DUMMY_GENERIC = WithDummy (Arg)
-
 functor WithEq (Arg : OPEN_GENERIC) : EQ_GENERIC = WithEq (Arg)
 
 signature WITH_HASH_DOM = WITH_HASH_DOM
@@ -148,5 +146,8 @@
 
 functor WithPretty (Arg : OPEN_GENERIC) : PRETTY_GENERIC = WithPretty (Arg)
 
+signature WITH_SOME_DOM = WITH_SOME_DOM
+functor WithSome (Arg : WITH_SOME_DOM) : SOME_GENERIC = WithSome (Arg)
+
 functor WithTypeInfo (Arg : OPEN_GENERIC) : TYPE_INFO_GENERIC =
    WithTypeInfo (Arg)

Deleted: mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sig	2007-07-20 00:29:22 UTC (rev 5782)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sig	2007-07-20 02:32:11 UTC (rev 5783)
@@ -1,39 +0,0 @@
-(* 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.
- *)
-
-(**
- * A signature for a generic dummy value.  In SML, dummy values are needed
- * for things such as computing fixpoints and building cyclic values.
- *
- * This generic is unlikely to be directly useful in application programs
- * and is more likely to be used internally in the implementation of some
- * other generics (e.g. pickling).
- *)
-signature DUMMY = sig
-   structure Dummy : OPEN_GENERIC_REP
-
-   exception Dummy of Exn.t
-   (**
-    * This is raised when trying to extract the dummy value in case of
-    * unfounded recursion or an abstract type that has not been given a
-    * dummy value.
-    *)
-
-   val dummy : ('a, 'x) Dummy.t -> 'a
-   (** Extracts the dummy value or raises {Dummy}. *)
-
-   val withDummy : 'a Option.t -> ('a, 'x) Dummy.t UnOp.t
-   (**
-    * {withDummy NONE t} removes the dummy value from the given
-    * representation {t} and {withDummy (SOME v) t} sets the dummy value
-    * to {v} in the given representation {t}.
-    *)
-end
-
-signature DUMMY_GENERIC = sig
-   include OPEN_GENERIC DUMMY
-   sharing Rep = Dummy
-end

Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig	2007-07-20 00:29:22 UTC (rev 5782)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/pickle.sig	2007-07-20 02:32:11 UTC (rev 5783)
@@ -23,6 +23,6 @@
 end
 
 signature WITH_PICKLE_DOM = sig
-   include OPEN_GENERIC EQ DUMMY HASH TYPE_INFO
-   sharing Rep = Eq = Dummy = Hash = TypeInfo
+   include OPEN_GENERIC EQ HASH SOME TYPE_INFO
+   sharing Rep = Eq = Hash = Some = TypeInfo
 end

Copied: mltonlib/trunk/com/ssh/generic/unstable/public/value/some.sig (from rev 5753, mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sig)
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/dummy.sig	2007-07-10 07:39:05 UTC (rev 5753)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/some.sig	2007-07-20 02:32:11 UTC (rev 5783)
@@ -0,0 +1,36 @@
+(* 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.
+ *)
+
+(**
+ * A signature for a generic dummy value.  In SML, dummy values are needed
+ * for things such as computing fixpoints and building cyclic values.
+ *
+ * This generic is unlikely to be directly useful in application programs
+ * and is more likely to be used internally in the implementation of some
+ * other generics (e.g. pickling).
+ *)
+signature SOME = sig
+   structure Some : OPEN_GENERIC_REP
+
+   exception Nothing of Exn.t
+   (** Raised when trying to extract some value when there is none. *)
+
+   val some : ('a, 'x) Some.t -> 'a
+   (** Returns some value of type {'a} or raises {Nothing}. *)
+
+   val withNone : ('a, 'x) Some.t UnOp.t
+   (** Removes any value from the given representation. *)
+
+   val withSome : 'a -> ('a, 'x) Some.t UnOp.t
+   (** Sets the value of the given representation. *)
+end
+
+signature SOME_GENERIC = sig
+   include OPEN_GENERIC SOME
+   sharing Rep = Some
+end
+
+signature WITH_SOME_DOM = TYPE_INFO_GENERIC




More information about the MLton-commit mailing list