[MLton-commit] r5469

[geoffw at mlton.org]

Extensions to MONAD_EX and MONADP_EX as described 
in my proposed patch, except the "choose" function
which I think really needs more work/thought first.


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

U   mltonlib/trunk/com/ssh/extended-basis/unstable/detail/concept/mk-monad.fun
U   mltonlib/trunk/com/ssh/extended-basis/unstable/public/concept/monad.sig

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

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/concept/mk-monad.fun
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/concept/mk-monad.fun	2007-03-26 13:56:59 UTC (rev 5468)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/concept/mk-monad.fun	2007-03-26 14:00:21 UTC (rev 5469)
@@ -5,7 +5,7 @@
  *)
 
 functor MkMonad (Core : MONAD_CORE) : MONAD = struct
-   infix >> >>& >>* >>= >>@
+   infix >> >>& >>* >>= >>@ oo
    open Core
    type 'a func = 'a monad
    fun map f aM = aM >>= return o f
@@ -14,19 +14,52 @@
    fun fM >>@ aM = map Fn.\> (fM >>* aM)
    fun aM >>& bM = map Product.& (aM >>* bM)
    fun aM >> bM = map #2 (aM >>* bM)
+
+   fun pure f = return o f
+   fun thunk thk = return () >>= pure thk
+
+   fun ignore m = m >> return ()
+   fun y2zM oo x2yM = (fn x => x2yM x >>= y2zM)
+
    local
-      fun mk fin comb x2yM ac =
-       fn [] => return (fin ac)
-        | x::xs => x2yM x >>= (fn y => mk fin comb x2yM (comb (y, ac)) xs)
+      fun mkFold fM b fin =
+       fn [] => return (fin b)
+        | x::xs => fM (x, b) >>= (fn b' => mkFold fM b' fin xs)
    in
-      fun seqWith x2yM = mk rev op :: x2yM []
-      fun appWith x2yM = mk ignore ignore x2yM ()
+      fun foldl fM b = mkFold fM b Fn.id
+      fun foldr fM b = (foldl fM b) o List.rev
+
+      fun seqWith x2yM = mkFold (fn (x, xs') => x2yM x >>= (fn x' => return (x'::xs'))) [] List.rev
+      fun appWith x2yM = foldl (ignore o x2yM o Pair.fst) ()
+
       fun seq xMs = seqWith Fn.id xMs
       fun app xMs = appWith Fn.id xMs
+
+      fun seqWithPartial x2yM = 
+       mkFold (fn (x, xs') => x2yM x >>= (fn SOME x' => return (x'::xs') | NONE => return xs')) [] List.rev
    end
-   fun ignore m = m >> return ()
+
    fun when b m = if b then m else return ()
    fun unless b m = if b then return () else m
+
+   local 
+     fun tabulateTail f n m ac =
+       if n = m then 
+         return (List.rev ac)
+       else 
+         f m >>= (fn x => tabulateTail f n (m + 1) (x::ac))
+   in
+     fun tabulate n f = tabulateTail f n 0 [] 
+   end
+
+   local
+     fun pairFst x y = (y, x)
+     fun pairSnd x y = (x, y) 
+   in
+     fun mapFst x2yM (x, z) = x2yM x >>= (pure o pairFst) z 
+     fun mapSnd x2yM (z, x) = x2yM x >>= (pure o pairSnd) z
+   end
+
 end
 
 functor MkMonadP (Core : MONADP_CORE) : MONADP = struct
@@ -34,5 +67,12 @@
    structure Monad = MkMonad (Core)
    open Monad Core
    type 'a monadp_ex = 'a monad
-   fun sum [] = zero | sum [x] = x | sum (x::xs) = x <|> sum xs
+
+   fun sumWith x2yM = 
+       fn [] => zero 
+        | [x] => x2yM x
+        | x::xs => x2yM x <|> sumWith x2yM xs
+
+   fun sum ms = sumWith Fn.id ms 
+
 end

Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/concept/monad.sig
===================================================================
--- mltonlib/trunk/com/ssh/extended-basis/unstable/public/concept/monad.sig	2007-03-26 13:56:59 UTC (rev 5468)
+++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/concept/monad.sig	2007-03-26 14:00:21 UTC (rev 5469)
@@ -39,12 +39,24 @@
    val >>* : 'a monad_ex * 'b monad_ex -> ('a * 'b) monad_ex
    val >>@ : ('a -> 'b) monad_ex * 'a monad_ex -> 'b monad_ex
 
+   val pure : ('a -> 'b) -> 'a -> 'b monad_ex
+   (** {pure f == return o f} *)
+
+   val thunk : 'a Thunk.t -> 'a monad_ex 
+   (** {thunk thk == return () >>= pure thunk} *)
+
    val seq : 'a monad_ex List.t -> 'a List.t monad_ex
    val seqWith : ('a -> 'b monad_ex) -> 'a List.t -> 'b List.t monad_ex
+   val seqWithPartial : ('a -> 'b Option.t monad_ex) -> 'a List.t -> 
+                        'b List.t monad_ex
 
    val app : 'a monad_ex List.t -> unit monad_ex
    val appWith : ('a -> 'b monad_ex) -> 'a List.t -> unit monad_ex
 
+   val oo : ('b -> 'c monad_ex) * ('a -> 'b monad_ex) -> 'a -> 
+            'c monad_ex
+   (** {f2 oo f1 == (fn x => f1 x >>= f2) } *)
+
    val ignore : 'a monad_ex -> unit monad_ex
    (** {ignore m == (m >> return ())} *)
 
@@ -53,6 +65,26 @@
 
    val unless : bool -> unit monad_ex -> unit monad_ex
    (** {unless b m == if b then (return ()) else m} *)
+
+   val tabulate : int -> (int -> 'a monad_ex) -> 'a List.t monad_ex
+   (**
+     * Tabulate is a version of List.tabulate that can use
+     * functions that produce computations.  
+     *
+     * {tabulate n f == 
+     *   (f 0) >>= (fn x0 => (f 1) >>= ... 
+     *                (fn xn >>= return [x1, ..., xn]))} 
+     *
+     * The actual implementation is tail recursive. *) 
+
+  val foldl : ('a * 'b -> 'b monad_ex) -> 'b -> 'a list -> 'b monad_ex 
+  val foldr : ('a * 'b -> 'b monad_ex) -> 'b -> 'a list -> 'b monad_ex 
+
+  val mapFst : ('a -> 'c monad_ex) -> ('a, 'b) Pair.t -> 
+               ('c, 'b) Pair.t monad_ex
+  val mapSnd : ('b -> 'c monad_ex) -> ('a, 'b) Pair.t -> 
+               ('a, 'c) Pair.t monad_ex
+
 end
 
 signature MONAD = sig
@@ -71,6 +103,7 @@
 signature MONADP_EX = sig
    type 'a monadp_ex
    val sum : 'a monadp_ex List.t -> 'a monadp_ex
+   val sumWith : ('a -> 'b monadp_ex) -> 'a List.t -> 'b monadp_ex
 end
 
 signature MONADP = sig