[MLton-commit] r5332

[Vesa Karvonen]

Using the (preliminary) Monad framework.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/with.sml
U   mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
U   mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use
U   mltonlib/trunk/com/ssh/extended-basis/unstable/public/with.sig

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

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/with.sml
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/with.sml	2007-02-26 09:03:24 UTC (rev 5331)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/with.sml	2007-02-26 09:42:38 UTC (rev 5332)
@@ -7,15 +7,18 @@
 structure With :> WITH = struct
    open With
 
-   infix >>= >>&
+   infix >>=
 
-   val return = Fn.pass
-   fun (wA >>= a2wB) f = wA (fn a => a2wB a f)
+   structure Monad =
+      MkMonad' (type ('a, 'r) monad = ('a, 'r) t
+                val return = Fn.pass
+                fun (wA >>= a2wB) f = wA (fn a => a2wB a f))
 
+   open Monad
+
    fun alloc g a f = f (g a)
    fun free ef x f = (f x handle e => (ef x ; raise e)) before ef x
 
-   fun (wA >>& wB) f = wA (fn a => wB (fn b => f (Product.& (a, b))))
    fun around new del = alloc new () >>= free del
    fun entry ef = alloc ef ()
    fun exit ef = free ef ()

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb	2007-02-26 09:03:24 UTC (rev 5331)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.mlb	2007-02-26 09:42:38 UTC (rev 5332)
@@ -106,9 +106,14 @@
                detail/product.sml
             end
          end
-         basis With = let
+         basis MkMonad = let
             open Fn Products
          in
+            bas detail/mk-monad.fun end
+         end
+         basis With = let
+            open Fn MkMonad Products
+         in
             bas public/with.sig detail/with.sml end
          end
          basis Sum = let
@@ -160,11 +165,6 @@
          in
             bas public/sequence/buffer.sig detail/buffer.sml end
          end
-         basis MkMonad = let
-            open Fn Products
-         in
-            bas detail/mk-monad.fun end
-         end
          basis Reader = let
             open Fn MkMonad Products Univ
          in

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use	2007-02-26 09:03:24 UTC (rev 5331)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/extensions.use	2007-02-26 09:42:38 UTC (rev 5332)
@@ -43,6 +43,7 @@
         "detail/pair.sml",
         "public/data/product.sig",
         "detail/product.sml",
+        "detail/mk-monad.fun",
         "public/with.sig", "detail/with.sml",
         "public/data/sum.sig", "detail/sum.sml",
         "public/data/exn.sig", "detail/exn.sml",
@@ -61,7 +62,6 @@
         "public/data/option.sig", "detail/option.sml",
         "public/sequence/list.sig", "detail/list.sml",
         "public/sequence/buffer.sig", "detail/buffer.sml",
-        "detail/mk-monad.fun",
         "public/reader.sig", "detail/reader.sml",
         "public/writer.sig", "detail/writer.sml",
         "public/exit.sig", "detail/exit.sml",

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/with.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/with.sig	2007-02-26 09:03:24 UTC (rev 5331)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/with.sig	2007-02-26 09:42:38 UTC (rev 5332)
@@ -17,15 +17,8 @@
 
    (** == Monad Interface == *)
 
-   val return : 'a -> ('a, 'r) t
-   (** Calls the block with the specified value.  Also see {alloc}. *)
+   include MONAD' where type ('a, 'r) monad = ('a, 'r) t
 
-   val >>= : ('a, 'r) t * ('a -> ('b, 'r) t) -> ('b, 'r) t
-   (**
-    * Composes two with -procedures, passing any value produced by the
-    * first as an argument to the second.
-    *)
-
    (** == Primitives == *)
 
    val alloc : ('a -> 'b) -> 'a -> ('b, 'r) t
@@ -47,9 +40,6 @@
 
    (** == Useful Combinations == *)
 
-   val >>& : ('a, 'r) t * ('b, 'r) t -> (('a, 'b) Product.t, 'r) t
-   (** Product combinator. *)
-
    val around : 'a Thunk.t -> 'a Effect.t -> ('a, 'r) t
    (**
     * Allocate resources with given thunk before entry to the block and