[MLton-user] Extended Basis Library: proposed patches to MONAD_EX, MONADP_EX, and MkMonad

[Geoffrey Alan Washburn]

More additions to MONAD_EX and MONADP_EX

# I decided to name the function I had been calling »lift«, »pure«.
   There is already a function named »lift« in the WHEN signature,
   though I think that function may be more commonly called »join«.
   »hoist« was longer and more obscure.  I took the idea of »pure«
   from Haskell Arrows.  It kind of emphasizes that it is taking a
   function that is »pure«, at least with respect to the given monad,
   and making it »effectful«.

# Added »thunk« and »ignore« functions

# Added composition, »oo«, for computations.  One idea I had was to
   name this »O« (capital "o" if your font doesn't clearly distinguish
   between 0 and O) but I'm not sure how popular that would be.

# Replaced »mk« with »mkFold« which acts a little more like a fold,
   and used it to implement »foldl« and »foldr«.

# Added »seqWithPartial« to correspond with »mapPartial«.

# Added the »tabulate« function.  I think the implementation could
   be better, but I think the thing to do is to add some more general
   unfolding functions in the near future.

# Defined »mapFst« and »mapSnd« because they seem to come up fairly
   often.  I'm open to suggestions for better names.  I defined them
   using two helpers »pairFst« and »pairSnd« which seem like they
   would be good combinators to include in PRODUCT_TYPE, though again
   probably with better names.

# Generalized »sum« in MONADP_EX to »sumWith«.

# Defined a »non-deterministic« choice operator »choose« for
   MONADP_EX.  However the current design isn't particularly »fair«.
   Specifically, I anticipate for the constraint solver I'm working
   on, it will lead to loops as it will always choose between
   assumptions in the same order.  Simple solution would be to
   permute and then build the sum.  I would be interested to hear
   other proposals.


Index: ext-basis/detail/concept/mk-monad.fun
===================================================================
--- ext-basis/detail/concept/mk-monad.fun	(revision 5463)
+++ ext-basis/detail/concept/mk-monad.fun	(working copy)
@@ -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)
+     fun mapSnd x2yM (z, x) = x2yM x >>= (pure o pairSnd)
+   end
+
  end

  functor MkMonadP (Core : MONADP_CORE) : MONADP = struct
@@ -34,5 +67,13 @@
     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
+   fun choose xs = sumWith return xs
+
  end
Index: ext-basis/public/export/common.sml
===================================================================
--- ext-basis/public/export/common.sml	(revision 5463)
+++ ext-basis/public/export/common.sml	(working copy)
@@ -26,6 +26,7 @@
  signature MONADP_CORE = MONADP_CORE
  signature MONAD_CORE = MONAD_CORE
  signature MONAD_EX = MONAD_EX
+signature MONADP_EX = MONADP_EX
  signature MONAD_WS = MONAD_WS
  signature MONAD_STATE = MONAD_STATE
  signature MONADP_STATE = MONADP_STATE
Index: ext-basis/public/concept/monad.sig
===================================================================
--- ext-basis/public/concept/monad.sig	(revision 5463)
+++ ext-basis/public/concept/monad.sig	(working copy)
@@ -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,8 @@
  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
+   val choose : 'a List.t -> 'a monadp_ex
  end

  signature MONADP = sig