[MLton-commit] r5916

[Vesa Karvonen]

Added more convenient, but warning prone, exception registration functions
regExn0' and regExn1'.  Renamed uop -> unOp and bop -> binOp to better
reflect the type names.

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

U   mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun
U   mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig
U   mltonlib/trunk/com/ssh/unit-test/unstable/example/qc-test.sml

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

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun	2007-08-21 14:02:30 UTC (rev 5915)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/with-extra.fun	2007-08-21 15:42:18 UTC (rev 5916)
@@ -23,6 +23,13 @@
    fun regExn1 e p n t = regExn (C1' n t) (e, p)
 
    local
+      fun mk f e p = f e (fn e => SOME (p e) handle Match => NONE)
+   in
+      fun regExn0' ? = mk regExn0 ?
+      fun regExn1' ? = mk regExn1 ?
+   end
+
+   local
       fun mk t = iso (tuple t)
    in
       fun tuple2 (a, b) = mk (T a *` T b) Product.isoTuple2
@@ -77,8 +84,8 @@
    end
 
    fun sq a = tuple2 (Sq.mk a)
-   fun uop a = a --> a
-   fun bop a = sq a --> a
+   fun unOp a = a --> a
+   fun binOp a = sq a --> a
 
    val () = let
       open IEEEReal OS OS.IO OS.Path Time

Modified: mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig	2007-08-21 14:02:30 UTC (rev 5915)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/generic-extra.sig	2007-08-21 15:42:18 UTC (rev 5916)
@@ -26,17 +26,19 @@
    val R' : String.t -> 'a Rep.t -> ('a, 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
+   val regExn1 :
+       ('a -> Exn.t) -> (Exn.t -> 'a Option.t) -> String.t -> 'a Rep.t Effect.t
 
+   val regExn0' : Exn.t -> (Exn.t -> Unit.t) -> String.t Effect.t
+   val regExn1' :
+       ('a -> Exn.t) -> (Exn.t -> 'a) -> 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
+   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 == *)
 
@@ -48,16 +50,16 @@
    (** == Some Standard Datatypes == *)
 
    val option : 'a Rep.t -> 'a Option.t Rep.t
-   val order : order Rep.t
+   val order : Order.t 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
+   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
+   val sq : 'a Rep.t -> 'a Sq.t Rep.t
+   val unOp : 'a Rep.t -> 'a UnOp.t Rep.t
+   val binOp : 'a Rep.t -> 'a BinOp.t Rep.t
 end

Modified: mltonlib/trunk/com/ssh/unit-test/unstable/example/qc-test.sml
===================================================================
--- mltonlib/trunk/com/ssh/unit-test/unstable/example/qc-test.sml	2007-08-21 14:02:30 UTC (rev 5915)
+++ mltonlib/trunk/com/ssh/unit-test/unstable/example/qc-test.sml	2007-08-21 15:42:18 UTC (rev 5916)
@@ -69,7 +69,7 @@
          fun (f === g) x = that (f x = g x)
          (* An approximation of extensional equality for functions. *)
       in
-         chk (all (uop int &` uop int &` uop int)
+         chk (all (case unOp int of t => t &` t &` t)
                   (fn f & g & h =>
                       all int
                           (f o (g o h) === (f o g) o h)))