[MLton-commit] r5603
Vesa Karvonen
vesak at mlton.org
Sat Jun 9 08:44:58 PDT 2007
Type-indices for convenience.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/default.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/with-convenience.fun
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/generic-with-convenience.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/default.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/default.sml 2007-06-08 16:11:10 UTC (rev 5602)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/default.sml 2007-06-09 15:44:57 UTC (rev 5603)
@@ -5,11 +5,9 @@
*)
structure Generic : sig
- include GENERICS
-
structure Ext : EXT_GENERIC
- include GENERIC
+ include GENERIC_WITH_CONVENIENCE
where type 'a Index.t = ('a, Unit.t) Ext.Index.t
where type 'a Index.s = ('a, Unit.t) Ext.Index.s
where type ('a, 'k) Index.p = ('a, 'k, Unit.t) Ext.Index.p
@@ -21,8 +19,6 @@
include SHOW sharing Ext.Index = Show
include TYPE_INFO sharing Ext.Index = TypeInfo
end = struct
- open Generics
-
structure Ext = ExtGeneric
structure Ext = WithShow (Ext) open Ext
@@ -49,5 +45,5 @@
structure Show = Ext.Index
structure TypeInfo = Ext.Index
- structure Grounded = GroundGeneric (Ext) open Grounded
+ structure Grounded = WithConvenience (GroundGeneric (Ext)) open Grounded
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-08 16:11:10 UTC (rev 5602)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-06-09 15:44:57 UTC (rev 5603)
@@ -11,6 +11,7 @@
../../../public/ext-generic-index.sig
../../../public/ext-generic.sig
../../../public/generic-index.sig
+ ../../../public/generic-with-convenience.sig
../../../public/generic.sig
../../../public/generics-util.sig
../../../public/generics.sig
@@ -34,3 +35,4 @@
../../value/ord.sml
../../value/show.sml
../../value/type-info.sml
+ ../../with-convenience.fun
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/with-convenience.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/with-convenience.fun 2007-06-08 16:11:10 UTC (rev 5602)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/with-convenience.fun 2007-06-09 15:44:57 UTC (rev 5603)
@@ -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 WithConvenience (Arg : GENERIC) : GENERIC_WITH_CONVENIENCE = struct
+ (* <-- SML/NJ workaround *)
+ open Basic Fn Product Sum UnPr
+ 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
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/with-convenience.fun
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-06-08 16:11:10 UTC (rev 5602)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-06-09 15:44:57 UTC (rev 5603)
@@ -28,6 +28,9 @@
public/generic-index.sig
public/generic.sig
+ public/generic-with-convenience.sig
+ detail/with-convenience.fun
+
public/ext-generic-index.sig
public/ext-generic.sig
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-06-08 16:11:10 UTC (rev 5602)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-06-09 15:44:57 UTC (rev 5603)
@@ -13,6 +13,8 @@
signature GENERIC = GENERIC
signature GENERIC_INDEX = GENERIC_INDEX
+signature GENERIC_WITH_CONVENIENCE = GENERIC_WITH_CONVENIENCE
+
signature EXT_GENERIC = EXT_GENERIC
signature EXT_GENERIC_INDEX = EXT_GENERIC_INDEX
@@ -78,6 +80,15 @@
* with the type-indices of the {Outer} generic.
*)
+functor WithConvenience (Arg : GENERIC) : GENERIC_WITH_CONVENIENCE =
+ WithConvenience (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.
+ *)
+
(** === Value Functors === *)
signature WITH_ARBITRARY_DOM = WITH_ARBITRARY_DOM
Added: mltonlib/trunk/com/ssh/generic/unstable/public/generic-with-convenience.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/generic-with-convenience.sig 2007-06-08 16:11:10 UTC (rev 5602)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/generic-with-convenience.sig 2007-06-09 15:44:57 UTC (rev 5603)
@@ -0,0 +1,58 @@
+(* 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_WITH_CONVENIENCE = 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 Index.s
+ val C1' : String.t -> 'a Index.t -> 'a Index.s
+
+ val R' : String.t -> 'a Index.t -> ('a, Generics.Record.t) Index.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 Index.t Effect.t
+
+ (** == Tuples == *)
+
+ val tuple2 : 'a Index.t * 'b Index.t
+ -> ('a * 'b) Index.t
+ val tuple3 : 'a Index.t * 'b Index.t * 'c Index.t
+ -> ('a * 'b * 'c) Index.t
+ val tuple4 : 'a Index.t * 'b Index.t * 'c Index.t * 'd Index.t
+ -> ('a * 'b * 'c * 'd) Index.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 Index.t
+ val int64 : Int64.t Index.t
+
+ (** == Some Standard Datatypes == *)
+
+ val option : 'a Index.t -> 'a Option.t Index.t
+ val order : order Index.t
+
+ (** == Sums and Products == *)
+
+ val &` : 'a Index.t * 'b Index.t -> ('a,'b) Product.t Index.t
+ val |` : 'a Index.t * 'b Index.t -> ('a,'b) Sum.t Index.t
+
+ (** == Abbreviations for Common Types == *)
+
+ val sq : 'a Index.t -> ('a * 'a) Index.t
+ val uop : 'a Index.t -> ('a -> 'a) Index.t
+ val bop : 'a Index.t -> ('a * 'a -> 'a) Index.t
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/generic-with-convenience.sig
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list