[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