Miscellaneous additions

lib/control.ml

@@ -44,12 +44,13 @@ let sequence {M : Monad} (ms : 'a M.t list) =
     ms
     (return [])
 
-(* Create a monad using default functor and idiom implementation *)
+(* Create a monad using default functor and applicative implementation *)
 module Monad(M : sig
                    type 'a t
                    val return : 'a -> 'a t
                    val bind : 'a t -> ('a -> 'b t) -> 'b t
-                 end) = struct
+                 end): Monad = struct
+  type 'a t = 'a M.t
   (* Functor *)
   let fmap f m = M.bind m (fun x -> M.return (f x))
   (* Applicative *)
@@ -62,30 +63,9 @@ module Monad(M : sig
   let bind = M.bind
 end;;
 
-(* Monad for option *)
-implicit module MonadOption = Monad(struct
-  type 'a t = 'a option
-  let return x = Some x
-  let bind x f = match x with
-    | None -> None
-    | Some x -> f x
-end);;
-
-(* Monad for list *)
-implicit module MonadList = Monad(struct
-  type 'a t = 'a list
-  let return x = [x]
-  let bind x f =
-    let rec aux acc = function
-      | x :: xs -> aux (x @ acc) xs
-      | [] -> acc
-    in
-      aux [] (List.rev_map f x)
-end);;
-
 module type Monad_plus = sig
   include Monad
-  val mzero : unit -> 'a t
+  val mzero : 'a t
   val mplus : 'a t -> 'a t -> 'a t
 end
 
@@ -97,7 +77,7 @@ module Monad_plus = struct
     if b then
       M.return ()
     else
-      M.mzero ()
+      M.mzero
 end
 
 module type Foldable = sig
@@ -128,13 +108,12 @@ implicit module Option = struct
     | Some a -> Some (f a)
 
   (* Applicative *)
-  let pure x = Some x
+  let return x = Some x
   let apply f x = match f, x with
     | Some f, Some x -> Some (f x)
     | _, _ -> None
 
   (* Monad *)
-  let return x = Some x
   let bind x f = match x with
     | None -> None
     | Some x -> f x
@@ -150,6 +129,7 @@ implicit module Option = struct
     | None -> acc
     | Some x -> f x acc
 
+  (* Traversable *)
   let traverse (type a) (type b) {F : Applicative} (f : a -> b F.t)  : a option -> b t F.t = function
     | None -> F.return None
     | Some x -> F.fmap (fun x -> Some x) (f x)
@@ -161,18 +141,18 @@ implicit module List = struct
   (* Functor *)
   let fmap = List.map
 
-  (* Monad *)
+  (* Applicative *)
   let return x = [x]
+  let apply fs xs =
+    List.concat (List.map (fun f -> List.map (fun x -> f x) xs) fs)
+
+  (* Monad *)
   let bind x f =
     let rec aux acc = function
       | x :: xs -> aux (x @ acc) xs
       | [] -> acc in
     aux [] (List.rev_map f x)
 
-  (* Applicative *)
-  let pure x = [x]
-  let apply fs xs = bind fs (bind xs)
-
   (* Monad_plus *)
   let mzero = []
   let mplus = (@)

lib/data.ml

@@ -262,6 +262,14 @@ implicit module String = struct
   let append = (^)
 end
 
+module List (A : Any) = struct
+  type t = A.t list
+
+  (* Monoid *)
+  let empty = []
+  let append = (@)
+end
+
 implicit module Int32 = struct
   type t = int32
 
@@ -369,3 +377,11 @@ implicit module Nativeint = struct
   let empty = 0L
   let append = Nativeint.add
 end
+
+implicit module Unit = struct
+  type t = unit
+
+  (* Monoid *)
+  let empty = ()
+  let append () () = ()
+end

tests/test.ml

@@ -1,4 +1,3 @@
-
 let () =
   let open Imp.Num.Num in
   let open implicit Imp.Num in
@@ -33,3 +32,21 @@ let () =
 
     assert (show (4.5, ([9; 10; 11], "hello")) =  "(4.5, ([9; 10; 11], \"hello\"))");
   end
+
+let () =
+  let open Imp.Data in
+  let e : unit = Monoid.empty () in
+  assert (Monoid.append e e = ())
+
+let () =
+  let open Imp.Data in
+  let e : string = Monoid.empty () in
+  assert (e = "");
+  assert (Monoid.append "abc" "def" = "abcdef")
+
+let () =
+  let open Imp.Data in
+  let implicit module IntList = List(struct type t = int end) in
+  let e : int list = Monoid.empty () in
+  assert (e = []);
+  assert (Monoid.append [1; 2] [3] = [1; 2; 3])