Monad sigs and functors for OCaml

monad.ml

(* I'm using the new syntax sugars on 4.08, which are (let+), (and+) and ( let* ) *)

module type FUNCTOR = sig
  type 'a t
  val map : ('a -> 'b) -> 'a t -> 'b t
  val (let+): 'a t -> ('a -> 'b) -> 'b t
end

module DefaultLetPlus(M: sig
    type 'a t
    val map : ('a -> 'b) -> 'a t -> 'b t
  end) = struct
  include M
  let (let+) a f = map f a
end

module type APPLICATIVE = sig
  include FUNCTOR
  val pure : 'a -> 'a t
  val (and+): 'a t -> 'b t -> ('a * 'b) t
end

module type MONAD = sig
  include APPLICATIVE
  val join: 'a t t -> 'a t
  val (let*): 'a t -> ('a -> 'b t) -> 'b t
end

(* Implements a default bind function from the map and join functions *)
module DefaultBind(M: sig
    include APPLICATIVE
    val join: 'a t t -> 'a t
  end) = struct
  include M
  let (let*) m f = join (map f m)
end

(* Implements a default join function from the bind function *)
module DefaultJoin(M: sig
    include APPLICATIVE
    val (let*): 'a t -> ('a -> 'b t) -> 'b t
  end) = struct
  include M
  let join m = let* x = m in x
end

module ListFunctor = DefaultLetPlus(struct
    type 'a t = 'a list
    let map = List.map
  end)

module ListApplicative = struct
    include ListFunctor
    let pure x = [x]
    let rec (and+) l1 l2 = match l1 with
      | [] -> []
      | l::ls -> map (fun x -> (l, x)) l2 @ (and+) ls l2
  end

module ListMonad = DefaultBind(struct
    include ListApplicative
    let join = List.flatten
  end)

module OptionFunctor = DefaultLetPlus(struct
    type 'a t = 'a option
    let map f = function
      | Some a -> Some (f a)
      | None  -> None
  end)

module OptionApplicative = struct
    include OptionFunctor
    let pure x = Some x
    let (and+) x1 x2 = match (x1, x2) with
      | (Some y1, Some y2) -> Some (y1, y2)
      | _ -> None
  end

module OptionMonad = DefaultJoin(struct
    include OptionApplicative
    let (let*) x f = match x with
      | Some y -> f y
      | None   -> None
  end)

(* Some functions that work with any applicative *)
module ApplicativeFunctions(A: APPLICATIVE) = struct
  open A
  let ( *> ) m m' = let+ _ = m
    and+ x' = m' in
    x'
  let ( <* ) m m' = let+ x' = m
    and+ _ = m' in
    x'
  let sequence ms =
    let k m m' =
      let+ x = m
      and+ xs = m' in
      (x::xs) in
    List.fold_right k ms (pure [])
  let sequence_ ms = List.fold_right ( *> ) ms (pure ())
  let mapA f ms = sequence (List.map f ms)
  let mapA_ f ms = sequence_ (List.map f ms)
  let rec filterA f = function
    | [] -> pure []
    | x::xs -> let+ flg = f x
               and+ ys = filterA f xs in
      if flg then (x::ys) else ys
end

(* Some functions that work with any monad *)
module MonadFunctions(M: MONAD) = struct
  open M
  let foldM f initial ms =
    let c x k z  = let* m' = f z x in k m' in
    List.fold_right c ms pure initial

  let foldM_ f initial ms = let open ApplicativeFunctions(M) in
                            foldM f initial ms *> pure ()
end