From e5a842829ea153636dd0b234a35beda1ad291dee Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Tue, 24 Jun 2014 16:23:30 +0200
Subject: [PATCH] monadic combinators for lists and klists

---
 core/CCKList.ml  | 27 +++++++++++++++++++++++++++
 core/CCKList.mli | 15 +++++++++++++++
 core/CCList.ml   | 30 ++++++++++++++++++++++++++++++
 core/CCList.mli  | 25 +++++++++++++++++++++----
 4 files changed, 93 insertions(+), 4 deletions(-)

diff --git a/core/CCKList.ml b/core/CCKList.ml
index d9a1112e..9dd606e6 100644
--- a/core/CCKList.ml
+++ b/core/CCKList.ml
@@ -237,6 +237,33 @@ let to_gen l =
         l := l';
         Some x
 
+(** {2 Monadic Operations} *)
+module type MONAD = sig
+  type 'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Traverse(M : MONAD) = struct
+  open M
+
+  let map_m f l =
+    let rec aux acc l = match l () with
+      | `Nil -> return (of_list (List.rev acc))
+      | `Cons (x,l') ->
+          f x >>= fun x' ->
+          aux (x' :: acc) l'
+    in
+    aux [] l
+
+  let sequence_m l = map_m (fun x->x) l
+
+  let rec fold_m f acc l = match l() with
+    | `Nil -> return acc
+    | `Cons (x,l') ->
+        f acc x >>= fun acc' -> fold_m f acc' l'
+end
+
 (** {2 IO} *)
 
 let pp ?(sep=",") pp_item buf l =
diff --git a/core/CCKList.mli b/core/CCKList.mli
index ddb808bb..0997a7f2 100644
--- a/core/CCKList.mli
+++ b/core/CCKList.mli
@@ -106,6 +106,21 @@ val exists2 : ('a -> 'b -> bool) -> 'a t -> 'b t -> bool
 val merge : 'a ord -> 'a t -> 'a t -> 'a t
 (** Merge two sorted iterators into a sorted iterator *)
 
+(** {2 Monadic Operations} *)
+module type MONAD = sig
+  type 'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Traverse(M : MONAD) : sig
+  val sequence_m : 'a M.t t -> 'a t M.t
+
+  val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> 'a t -> 'b M.t
+
+  val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t
+end
+
 (** {2 Conversions} *)
 
 val of_list : 'a list -> 'a t
diff --git a/core/CCList.ml b/core/CCList.ml
index 4da93f76..7375f5d8 100644
--- a/core/CCList.ml
+++ b/core/CCList.ml
@@ -495,6 +495,34 @@ module Zipper = struct
     | _, [] -> raise Not_found
 end
 
+(** {2 Monadic Operations} *)
+module type MONAD = sig
+  type 'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Traverse(M : MONAD) = struct
+  open M
+
+  let map_m f l =
+    let rec aux f acc l = match l with
+      | [] -> return (List.rev acc)
+      | x::tail ->
+          f x >>= fun x' ->
+          aux f (x' :: acc) tail
+    in aux f [] l
+
+  let sequence_m l = map_m (fun x->x) l
+
+  let rec fold_m f acc l = match l with
+    | [] -> return acc
+    | x :: l' ->
+        f acc x
+        >>= fun acc' ->
+        fold_m f acc' l'
+end
+
 (** {2 Conversions} *)
 
 type 'a sequence = ('a -> unit) -> unit
@@ -527,6 +555,8 @@ let random_choose l = match l with
         let i = Random.State.int st len in
         List.nth l i
 
+let random_sequence l st = map (fun g -> g st) l
+
 let to_seq l k = List.iter k l
 let of_seq seq =
   let l = ref [] in
diff --git a/core/CCList.mli b/core/CCList.mli
index 051446fd..f835ef4c 100644
--- a/core/CCList.mli
+++ b/core/CCList.mli
@@ -220,6 +220,21 @@ module Zipper : sig
       @raise Not_found if the zipper is at an end *)
 end
 
+(** {2 Monadic Operations} *)
+module type MONAD = sig
+  type 'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+module Traverse(M : MONAD) : sig
+  val sequence_m : 'a M.t t -> 'a t M.t
+
+  val fold_m : ('b -> 'a -> 'b M.t) -> 'b -> 'a t -> 'b M.t
+
+  val map_m : ('a -> 'b M.t) -> 'a t -> 'b t M.t
+end
+
 (** {2 Conversions} *)
 
 type 'a sequence = ('a -> unit) -> unit
@@ -229,14 +244,16 @@ type 'a printer = Buffer.t -> 'a -> unit
 type 'a formatter = Format.formatter -> 'a -> unit
 type 'a random_gen = Random.State.t -> 'a
 
-val random : 'a random_gen -> 'a list random_gen
-val random_non_empty : 'a random_gen -> 'a list random_gen
-val random_len : int -> 'a random_gen -> 'a list random_gen
+val random : 'a random_gen -> 'a t random_gen
+val random_non_empty : 'a random_gen -> 'a t random_gen
+val random_len : int -> 'a random_gen -> 'a t random_gen
 
-val random_choose : 'a list -> 'a random_gen
+val random_choose : 'a t -> 'a random_gen
 (** Randomly choose an element in the list.
     @raise Not_found if the list is empty *)
 
+val random_sequence : 'a random_gen t -> 'a t random_gen
+
 val to_seq : 'a t -> 'a sequence
 val of_seq : 'a sequence -> 'a t