[MLton-commit] r5610
Vesa Karvonen
vesak at mlton.org
Sun Jun 10 05:39:41 PDT 2007
Introduced the concept of a GENERIC.
----------------------------------------------------------------------
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/with-convenience.fun
A mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
D mltonlib/trunk/com/ssh/generic/unstable/public/closed-generic-with-convenience.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig
A mltonlib/trunk/com/ssh/generic/unstable/public/generic.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-06-10 12:11:38 UTC (rev 5609)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/generic.sml 2007-06-10 12:39:40 UTC (rev 5610)
@@ -5,13 +5,7 @@
*)
structure Generic : sig
- structure Open : OPEN_GENERIC
-
- include CLOSED_GENERIC_WITH_CONVENIENCE
- where type 'a Rep.t = ('a, Unit.t) Open.Rep.t
- where type 'a Rep.s = ('a, Unit.t) Open.Rep.s
- where type ('a, 'k) Rep.p = ('a, 'k, Unit.t) Open.Rep.p
-
+ include GENERIC_EXTRA
include ARBITRARY sharing Open.Rep = Arbitrary
include DUMMY sharing Open.Rep = Dummy
include EQ sharing Open.Rep = Eq
@@ -42,5 +36,11 @@
structure Show = Open.Rep
structure TypeInfo = Open.Rep
- structure Closed = WithConvenience (CloseGeneric (Open)) open Closed
+ structure Generic = struct
+ structure Open = Open
+ structure Closed = CloseGeneric (Open)
+ open Closed
+ end
+
+ structure Extra = WithExtra (Generic) open Extra
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-06-10 12:11:38 UTC (rev 5609)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-06-10 12:39:40 UTC (rev 5610)
@@ -9,8 +9,9 @@
../../../../../prettier/unstable/lib.cm
../../../../../random/unstable/lib.cm
../../../public/closed-generic-rep.sig
- ../../../public/closed-generic-with-convenience.sig
../../../public/closed-generic.sig
+ ../../../public/generic-extra.sig
+ ../../../public/generic.sig
../../../public/generics-util.sig
../../../public/generics.sig
../../../public/join-generics-fun.sig
@@ -35,4 +36,4 @@
../../value/ord.sml
../../value/show.sml
../../value/type-info.sml
- ../../with-convenience.fun
+ ../../with-extra.fun
Deleted: mltonlib/trunk/com/ssh/generic/unstable/detail/with-convenience.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/with-convenience.fun 2007-06-10 12:11:38 UTC (rev 5609)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/with-convenience.fun 2007-06-10 12:39:40 UTC (rev 5610)
@@ -1,114 +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 WithConvenience (Arg : CLOSED_GENERIC) : CLOSED_GENERIC_WITH_CONVENIENCE = struct
- (* <-- SML/NJ workaround *)
- open TopLevel
- infix 7 *`
- infix 6 +` |`
- infix 0 & &`
- infixr 0 -->
- (* SML/NJ workaround --> *)
-
- open Generics Arg
-
- fun C0' n = C0 (C n)
- fun C1' n = C1 (C n)
- fun R' n = R (L n)
-
- fun regExn0 e p n = regExn (C0' n) (const e, p)
- fun regExn1 e p n t = regExn (C1' n t) (e, p)
-
- local
- fun mk t = iso (tuple t)
- in
- fun tuple2 (a, b) = mk (T a *` T b) Product.isoTuple2
- fun tuple3 (a, b, c) = mk (T a *` T b *` T c) Product.isoTuple3
- fun tuple4 (a, b, c, d) = mk (T a *` T b *` T c *` T d) Product.isoTuple4
- end
-
- local
- fun mk precision int' large' =
- if isSome Int.precision andalso
- valOf precision <= valOf Int.precision then
- iso int int'
- else
- iso largeInt large'
- in
- (* val int8 = mk Int8.precision Int8.isoInt Int8.isoLarge
- (* Int8 not provided by SML/NJ *) *)
- (* val int16 = mk Int16.precision Int16.isoInt Int16.isoLarge
- (* Int16 not provided by SML/NJ *) *)
- val int32 = mk Int32.precision Int32.isoInt Int32.isoLarge
- val int64 = mk Int64.precision Int64.isoInt Int64.isoLarge
- end
-
- local
- val none = C "NONE"
- val some = C "SOME"
- in
- fun option a =
- iso (data (C0 none +` C1 some a))
- (fn NONE => INL () | SOME a => INR a,
- fn INL () => NONE | INR a => SOME a)
- end
-
- val order =
- iso (data (C0' "LESS" +` C0' "EQUAL" +` C0' "GREATER"))
- (fn LESS => INL (INL ())
- | EQUAL => INL (INR ())
- | GREATER => INR (),
- fn INL (INL ()) => LESS
- | INL (INR ()) => EQUAL
- | INR () => GREATER)
-
- local
- val et = C "&"
- in
- fun a &` b = data (C1 et (tuple (T a *` T b)))
- end
-
- local
- val inl = C "INL"
- val inr = C "INR"
- in
- fun a |` b = data (C1 inl a +` C1 inr b)
- end
-
- fun sq a = tuple2 (Sq.mk a)
- fun uop a = a --> a
- fun bop a = sq a --> a
-
- val () = let
- open IEEEReal OS OS.IO OS.Path Time
- val s = SOME
- val n = NONE
- val su = SOME ()
- in
- (* Handlers for most standard exceptions: *)
- regExn0 Bind (fn Bind => su | _ => n) "Bind"
- ; regExn0 Chr (fn Chr => su | _ => n) "Chr"
- ; regExn0 Date.Date (fn Date.Date => su | _ => n) "Date.Date"
- ; regExn0 Div (fn Div => su | _ => n) "Div"
- ; regExn0 Domain (fn Domain => su | _ => n) "Domain"
- ; regExn0 Empty (fn Empty => su | _ => n) "Empty"
- ; regExn0 InvalidArc (fn InvalidArc => su | _ => n) "OS.Path.InvalidArc"
- ; regExn0 Match (fn Match => su | _ => n) "Match"
- ; regExn0 Option (fn Option => su | _ => n) "Option"
- ; regExn0 Overflow (fn Overflow => su | _ => n) "Overflow"
- ; regExn0 Path (fn Path => su | _ => n) "OS.Path.Path"
- ; regExn0 Poll (fn Poll => su | _ => n) "OS.IO.Poll"
- ; regExn0 Size (fn Size => su | _ => n) "Size"
- ; regExn0 Span (fn Span => su | _ => n) "Span"
- ; regExn0 Subscript (fn Subscript => su | _ => n) "Subscript"
- ; regExn0 Time (fn Time => su | _ => n) "Time.Time"
- ; regExn0 Unordered (fn Unordered => su | _ => n) "IEEEReal.Unordered"
- ; regExn1 Fail (fn Fail ? => s? | _ => n) "Fail" string
- (* Handlers for some extended-basis exceptions: *)
- ; regExn0 Sum.Sum (fn Sum.Sum => su | _ => n) "Sum"
- ; regExn0 Fix.Fix (fn Fix.Fix => su | _ => n) "Fix"
- end
-end
Copied: mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun (from rev 5608, mltonlib/trunk/com/ssh/generic/unstable/detail/with-convenience.fun)
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/with-convenience.fun 2007-06-10 11:54:24 UTC (rev 5608)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun 2007-06-10 12:39:40 UTC (rev 5610)
@@ -0,0 +1,114 @@
+(* 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 WithExtra (Arg : GENERIC) : GENERIC_EXTRA = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix 7 *`
+ infix 6 +` |`
+ infix 0 & &`
+ infixr 0 -->
+ (* SML/NJ workaround --> *)
+
+ open Generics Arg
+
+ fun C0' n = C0 (C n)
+ fun C1' n = C1 (C n)
+ fun R' n = R (L n)
+
+ fun regExn0 e p n = regExn (C0' n) (const e, p)
+ fun regExn1 e p n t = regExn (C1' n t) (e, p)
+
+ local
+ fun mk t = iso (tuple t)
+ in
+ fun tuple2 (a, b) = mk (T a *` T b) Product.isoTuple2
+ fun tuple3 (a, b, c) = mk (T a *` T b *` T c) Product.isoTuple3
+ fun tuple4 (a, b, c, d) = mk (T a *` T b *` T c *` T d) Product.isoTuple4
+ end
+
+ local
+ fun mk precision int' large' =
+ if isSome Int.precision andalso
+ valOf precision <= valOf Int.precision then
+ iso int int'
+ else
+ iso largeInt large'
+ in
+ (* val int8 = mk Int8.precision Int8.isoInt Int8.isoLarge
+ (* Int8 not provided by SML/NJ *) *)
+ (* val int16 = mk Int16.precision Int16.isoInt Int16.isoLarge
+ (* Int16 not provided by SML/NJ *) *)
+ val int32 = mk Int32.precision Int32.isoInt Int32.isoLarge
+ val int64 = mk Int64.precision Int64.isoInt Int64.isoLarge
+ end
+
+ local
+ val none = C "NONE"
+ val some = C "SOME"
+ in
+ fun option a =
+ iso (data (C0 none +` C1 some a))
+ (fn NONE => INL () | SOME a => INR a,
+ fn INL () => NONE | INR a => SOME a)
+ end
+
+ val order =
+ iso (data (C0' "LESS" +` C0' "EQUAL" +` C0' "GREATER"))
+ (fn LESS => INL (INL ())
+ | EQUAL => INL (INR ())
+ | GREATER => INR (),
+ fn INL (INL ()) => LESS
+ | INL (INR ()) => EQUAL
+ | INR () => GREATER)
+
+ local
+ val et = C "&"
+ in
+ fun a &` b = data (C1 et (tuple (T a *` T b)))
+ end
+
+ local
+ val inl = C "INL"
+ val inr = C "INR"
+ in
+ fun a |` b = data (C1 inl a +` C1 inr b)
+ end
+
+ fun sq a = tuple2 (Sq.mk a)
+ fun uop a = a --> a
+ fun bop a = sq a --> a
+
+ val () = let
+ open IEEEReal OS OS.IO OS.Path Time
+ val s = SOME
+ val n = NONE
+ val su = SOME ()
+ in
+ (* Handlers for most standard exceptions: *)
+ regExn0 Bind (fn Bind => su | _ => n) "Bind"
+ ; regExn0 Chr (fn Chr => su | _ => n) "Chr"
+ ; regExn0 Date.Date (fn Date.Date => su | _ => n) "Date.Date"
+ ; regExn0 Div (fn Div => su | _ => n) "Div"
+ ; regExn0 Domain (fn Domain => su | _ => n) "Domain"
+ ; regExn0 Empty (fn Empty => su | _ => n) "Empty"
+ ; regExn0 InvalidArc (fn InvalidArc => su | _ => n) "OS.Path.InvalidArc"
+ ; regExn0 Match (fn Match => su | _ => n) "Match"
+ ; regExn0 Option (fn Option => su | _ => n) "Option"
+ ; regExn0 Overflow (fn Overflow => su | _ => n) "Overflow"
+ ; regExn0 Path (fn Path => su | _ => n) "OS.Path.Path"
+ ; regExn0 Poll (fn Poll => su | _ => n) "OS.IO.Poll"
+ ; regExn0 Size (fn Size => su | _ => n) "Size"
+ ; regExn0 Span (fn Span => su | _ => n) "Span"
+ ; regExn0 Subscript (fn Subscript => su | _ => n) "Subscript"
+ ; regExn0 Time (fn Time => su | _ => n) "Time.Time"
+ ; regExn0 Unordered (fn Unordered => su | _ => n) "IEEEReal.Unordered"
+ ; regExn1 Fail (fn Fail ? => s? | _ => n) "Fail" string
+ (* Handlers for some extended-basis exceptions: *)
+ ; regExn0 Sum.Sum (fn Sum.Sum => su | _ => n) "Sum"
+ ; regExn0 Fix.Fix (fn Fix.Fix => su | _ => n) "Fix"
+ end
+end
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-06-10 12:11:38 UTC (rev 5609)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-06-10 12:39:40 UTC (rev 5610)
@@ -15,6 +15,8 @@
"warnUnused true"
in
local
+ (* Support *)
+
public/generics.sig
local
detail/sml-syntax.sml
@@ -25,15 +27,21 @@
public/generics-util.sig
detail/generics-util.sml
+ (* Concepts *)
+
public/closed-generic-rep.sig
public/closed-generic.sig
- public/closed-generic-with-convenience.sig
- detail/with-convenience.fun
-
public/open-generic-rep.sig
public/open-generic.sig
+ public/generic.sig
+ public/generic-extra.sig
+
+ (* Framework *)
+
+ detail/with-extra.fun
+
detail/root-generic.sml
detail/close-generic.fun
@@ -42,6 +50,8 @@
public/join-generics-fun.sig
detail/join-generics.fun
+ (* Values *)
+
public/value/type-info.sig
detail/value/type-info.sml
Deleted: mltonlib/trunk/com/ssh/generic/unstable/public/closed-generic-with-convenience.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/closed-generic-with-convenience.sig 2007-06-10 12:11:38 UTC (rev 5609)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/closed-generic-with-convenience.sig 2007-06-10 12:39:40 UTC (rev 5610)
@@ -1,58 +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.
- *)
-
-signature CLOSED_GENERIC_WITH_CONVENIENCE = sig
- include GENERICS CLOSED_GENERIC
-
- (** == Shorthands for Types with Labels or Constructors ==
- *
- * These should only be used for defining monomorphic type-indices.
- *)
-
- val C0' : String.t -> Unit.t Rep.s
- val C1' : String.t -> 'a Rep.t -> 'a Rep.s
-
- val R' : String.t -> 'a Rep.t -> ('a, Generics.Record.t) Rep.p
-
- val regExn0 : Exn.t -> (Exn.t -> Unit.t Option.t) -> String.t Effect.t
- val regExn1 : ('a -> Exn.t) -> (Exn.t -> 'a Option.t) -> String.t -> 'a Rep.t Effect.t
-
- (** == Tuples == *)
-
- val tuple2 : 'a Rep.t * 'b Rep.t
- -> ('a * 'b) Rep.t
- val tuple3 : 'a Rep.t * 'b Rep.t * 'c Rep.t
- -> ('a * 'b * 'c) Rep.t
- val tuple4 : 'a Rep.t * 'b Rep.t * 'c Rep.t * 'd Rep.t
- -> ('a * 'b * 'c * 'd) Rep.t
-
- (** == Integer Types ==
- *
- * WARNING: The encodings of sized integer types are not optimal for
- * serialization. (They do work, however.) For serialization, one
- * should encode sized integer types in terms of the corresponding
- * sized word types.
- *)
-
- val int32 : Int32.t Rep.t
- val int64 : Int64.t Rep.t
-
- (** == Some Standard Datatypes == *)
-
- val option : 'a Rep.t -> 'a Option.t Rep.t
- val order : order Rep.t
-
- (** == Sums and Products == *)
-
- val &` : 'a Rep.t * 'b Rep.t -> ('a,'b) Product.t Rep.t
- val |` : 'a Rep.t * 'b Rep.t -> ('a,'b) Sum.t Rep.t
-
- (** == Abbreviations for Common Types == *)
-
- val sq : 'a Rep.t -> ('a * 'a) Rep.t
- val uop : 'a Rep.t -> ('a -> 'a) Rep.t
- val bop : 'a Rep.t -> ('a * 'a -> 'a) Rep.t
-end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-06-10 12:11:38 UTC (rev 5609)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-06-10 12:39:40 UTC (rev 5610)
@@ -16,7 +16,8 @@
signature OPEN_GENERIC = OPEN_GENERIC
signature OPEN_GENERIC_REP = OPEN_GENERIC_REP
-signature CLOSED_GENERIC_WITH_CONVENIENCE = CLOSED_GENERIC_WITH_CONVENIENCE
+signature GENERIC = GENERIC
+signature GENERIC_EXTRA = GENERIC_EXTRA
(** === Value Signatures === *)
@@ -80,13 +81,12 @@
* with the type-indices of the {Outer} generic.
*)
-functor WithConvenience (Arg : CLOSED_GENERIC) :
- CLOSED_GENERIC_WITH_CONVENIENCE = WithConvenience (Arg)
+functor WithExtra (Arg : GENERIC) : GENERIC_EXTRA = WithExtra (Arg)
(**
* Implements a number of frequently used type-indices for convenience.
* As a side-effect, this functor also registers handlers for most
- * standard exceptions. The exact set of additional type-indices is
- * likely to grow over time.
+ * standard exceptions. The exact set of extra type-indices is likely to
+ * grow over time.
*)
(** === Value Functors === *)
Copied: mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig (from rev 5608, mltonlib/trunk/com/ssh/generic/unstable/public/closed-generic-with-convenience.sig)
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/closed-generic-with-convenience.sig 2007-06-10 11:54:24 UTC (rev 5608)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig 2007-06-10 12:39:40 UTC (rev 5610)
@@ -0,0 +1,59 @@
+(* 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 GENERIC_EXTRA = sig
+ include GENERICS GENERIC
+
+ (** == Shorthands for Types with Labels or Constructors ==
+ *
+ * These should only be used for defining monomorphic type-indices.
+ *)
+
+ val C0' : String.t -> Unit.t Rep.s
+ val C1' : String.t -> 'a Rep.t -> 'a Rep.s
+
+ val R' : String.t -> 'a Rep.t -> ('a, Generics.Record.t) Rep.p
+
+ val regExn0 : Exn.t -> (Exn.t -> Unit.t Option.t) -> String.t Effect.t
+ val regExn1 : ('a -> Exn.t) -> (Exn.t -> 'a Option.t) -> String.t
+ -> 'a Rep.t Effect.t
+
+ (** == Tuples == *)
+
+ val tuple2 : 'a Rep.t * 'b Rep.t
+ -> ('a * 'b) Rep.t
+ val tuple3 : 'a Rep.t * 'b Rep.t * 'c Rep.t
+ -> ('a * 'b * 'c) Rep.t
+ val tuple4 : 'a Rep.t * 'b Rep.t * 'c Rep.t * 'd Rep.t
+ -> ('a * 'b * 'c * 'd) Rep.t
+
+ (** == Integer Types ==
+ *
+ * WARNING: The encodings of sized integer types are not optimal for
+ * serialization. (They do work, however.) For serialization, one
+ * should encode sized integer types in terms of the corresponding
+ * sized word types.
+ *)
+
+ val int32 : Int32.t Rep.t
+ val int64 : Int64.t Rep.t
+
+ (** == Some Standard Datatypes == *)
+
+ val option : 'a Rep.t -> 'a Option.t Rep.t
+ val order : order Rep.t
+
+ (** == Sums and Products == *)
+
+ val &` : 'a Rep.t * 'b Rep.t -> ('a,'b) Product.t Rep.t
+ val |` : 'a Rep.t * 'b Rep.t -> ('a,'b) Sum.t Rep.t
+
+ (** == Abbreviations for Common Types == *)
+
+ val sq : 'a Rep.t -> ('a * 'a) Rep.t
+ val uop : 'a Rep.t -> ('a -> 'a) Rep.t
+ val bop : 'a Rep.t -> ('a * 'a -> 'a) Rep.t
+end
Added: mltonlib/trunk/com/ssh/generic/unstable/public/generic.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/generic.sig 2007-06-10 12:11:38 UTC (rev 5609)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/generic.sig 2007-06-10 12:39:40 UTC (rev 5610)
@@ -0,0 +1,14 @@
+(* 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 GENERIC = sig
+ structure Open : OPEN_GENERIC
+
+ include CLOSED_GENERIC
+ where type 'a Rep.t = ('a, Unit.t) Open.Rep.t
+ where type 'a Rep.s = ('a, Unit.t) Open.Rep.s
+ where type ('a, 'k) Rep.p = ('a, 'k, Unit.t) Open.Rep.p
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/generic.sig
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list