[MLton-commit] r5937
Vesa Karvonen
vesak at mlton.org
Fri Aug 24 05:42:50 PDT 2007
Moved the registration of standard exceptions from WithExtra to a separate
functor RegBasisExns.
----------------------------------------------------------------------
A mltonlib/trunk/com/ssh/generic/unstable/detail/reg-basis-exns.fun
U mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
U mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml
----------------------------------------------------------------------
Copied: mltonlib/trunk/com/ssh/generic/unstable/detail/reg-basis-exns.fun (from rev 5934, mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun)
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun 2007-08-23 09:46:45 UTC (rev 5934)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/reg-basis-exns.fun 2007-08-24 12:42:48 UTC (rev 5937)
@@ -0,0 +1,42 @@
+(* 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 RegBasisExns (Arg : CLOSED_CASES) = struct
+ val () = let
+ open Arg Generics IEEEReal OS OS.IO OS.Path Time
+
+ local
+ fun lift f a = SOME (f a) handle Match => NONE
+ in
+ fun regExn0' n e p = regExn0 (C n) (e, lift p)
+ fun regExn1' n t e p = regExn1 (C n) t (e, lift p)
+ end
+ in
+ (* Handlers for most standard exceptions: *)
+ regExn0' "Bind" Bind (fn Bind => ())
+ ; regExn0' "Chr" Chr (fn Chr => ())
+ ; regExn0' "Date.Date" Date.Date (fn Date.Date => ())
+ ; regExn0' "Div" Div (fn Div => ())
+ ; regExn0' "Domain" Domain (fn Domain => ())
+ ; regExn0' "Empty" Empty (fn Empty => ())
+ ; regExn0' "OS.Path.InvalidArc" InvalidArc (fn InvalidArc => ())
+ ; regExn0' "Match" Match (fn Match => ())
+ ; regExn0' "Option" Option (fn Option => ())
+ ; regExn0' "Overflow" Overflow (fn Overflow => ())
+ ; regExn0' "OS.Path.Path" Path (fn Path => ())
+ ; regExn0' "OS.IO.Poll" Poll (fn Poll => ())
+ ; regExn0' "Size" Size (fn Size => ())
+ ; regExn0' "Span" Span (fn Span => ())
+ ; regExn0' "Subscript" Subscript (fn Subscript => ())
+ ; regExn0' "Time.Time" Time (fn Time => ())
+ ; regExn0' "IEEEReal.Unordered" Unordered (fn Unordered => ())
+ ; regExn1' "Fail" string Fail (fn Fail ? => ?)
+ (* Handlers for some extended-basis exceptions: *)
+ ; regExn0' "IOSMonad.EOS" IOSMonad.EOS (fn IOSMonad.EOS => ())
+ ; regExn0' "Sum.Sum" Sum.Sum (fn Sum.Sum => ())
+ ; regExn0' "Fix.Fix" Fix.Fix (fn Fix.Fix => ())
+ end
+end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun 2007-08-24 12:18:02 UTC (rev 5936)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun 2007-08-24 12:42:48 UTC (rev 5937)
@@ -83,32 +83,4 @@
fun sq a = tuple2 (Sq.mk a)
fun unOp a = a --> a
fun binOp a = sq a --> a
-
- val () = let
- open IEEEReal OS OS.IO OS.Path Time
- in
- (* Handlers for most standard exceptions: *)
- regExn0' "Bind" Bind (fn Bind => ())
- ; regExn0' "Chr" Chr (fn Chr => ())
- ; regExn0' "Date.Date" Date.Date (fn Date.Date => ())
- ; regExn0' "Div" Div (fn Div => ())
- ; regExn0' "Domain" Domain (fn Domain => ())
- ; regExn0' "Empty" Empty (fn Empty => ())
- ; regExn0' "OS.Path.InvalidArc" InvalidArc (fn InvalidArc => ())
- ; regExn0' "Match" Match (fn Match => ())
- ; regExn0' "Option" Option (fn Option => ())
- ; regExn0' "Overflow" Overflow (fn Overflow => ())
- ; regExn0' "OS.Path.Path" Path (fn Path => ())
- ; regExn0' "OS.IO.Poll" Poll (fn Poll => ())
- ; regExn0' "Size" Size (fn Size => ())
- ; regExn0' "Span" Span (fn Span => ())
- ; regExn0' "Subscript" Subscript (fn Subscript => ())
- ; regExn0' "Time.Time" Time (fn Time => ())
- ; regExn0' "IEEEReal.Unordered" Unordered (fn Unordered => ())
- ; regExn1' "Fail" string Fail (fn Fail ? => ?)
- (* Handlers for some extended-basis exceptions: *)
- ; regExn0' "IOSMonad.EOS" IOSMonad.EOS (fn IOSMonad.EOS => ())
- ; regExn0' "Sum.Sum" Sum.Sum (fn Sum.Sum => ())
- ; regExn0' "Fix.Fix" Fix.Fix (fn Fix.Fix => ())
- end
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-08-24 12:18:02 UTC (rev 5936)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-08-24 12:42:48 UTC (rev 5937)
@@ -45,8 +45,9 @@
(* Framework *)
+ detail/with-extra.fun
ann "nonexhaustiveExnMatch ignore" in
- detail/with-extra.fun
+ detail/reg-basis-exns.fun
end
detail/root-generic.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-08-24 12:18:02 UTC (rev 5936)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-08-24 12:42:48 UTC (rev 5937)
@@ -78,11 +78,13 @@
functor WithExtra (Arg : GENERIC) : GENERIC_EXTRA = WithExtra (Arg)
(**
* Implements a number of frequently used type representations for
- * convenience. As a side-effect, this functor also registers handlers
- * for most standard exceptions. The exact set of extra representations
- * is likely to grow over time.
+ * convenience. The exact set of extra representations is likely to grow
+ * over time.
*)
+functor RegBasisExns (Arg : CLOSED_CASES) = RegBasisExns (Arg)
+(** Registers handlers for most standard exceptions as a side-effect. *)
+
(** == Auxiliary Generics == *)
signature DATA_REC_INFO = DATA_REC_INFO
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml 2007-08-24 12:18:02 UTC (rev 5936)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/utils.sml 2007-08-24 12:42:48 UTC (rev 5937)
@@ -8,6 +8,9 @@
functor CloseWithExtra (Open : OPEN_CASES) =
WithExtra (structure Open = Open and Closed = CloseCases (Open) open Closed)
+(* Register basis library exceptions for the default generics. *)
+local structure ? = RegBasisExns (Generic) in end
+
(* A simplistic graph for testing with cyclic data. *)
functor MkGraph (Generic : GENERIC_EXTRA) :> sig
type 'a t
More information about the MLton-commit
mailing list