Source file monad.ml

open Base

include Monad_intf

module Make2(M : S2) = struct
  include M

  let fmap f t = bind t & fun x -> return (f x)
  let liftM = fmap

  let fmap2 f t u = bind t & fun t -> bind u & fun u -> return & f t u
  let liftM2 = fmap2

  let void a = bind a & fun _ -> return ()

  let rec seq = function
    | [] -> return []
    | x::xs ->
        bind x & fun x ->
        bind (seq xs) & fun xs ->
        return (x::xs)

  let rec seq_ = function
    | [] -> return ()
    | x::xs -> bind x & fun () -> seq_ xs

  let rec mapM f = function
    | [] -> return []
    | x::xs ->
        bind (f x) & fun y ->
          bind (mapM f xs) & fun ys ->
            return (y::ys)

  let rec mapM_ f = function
    | [] -> return ()
    | x::xs -> bind (f x) & fun () -> mapM_ f xs

  let iteri f ls =
    let rec loop f i = function
      | [] -> return ()
      | x::xs ->
          bind (f i x) & fun () ->
            bind (loop f (i+1) xs) & fun () ->
              return ()
    in
    loop f 0 ls

  let rec for_ i to_ f =
    if i > to_ then return ()
    else bind (f i) & fun () -> for_ (i+1) to_ f

  let join tt = bind tt & fun at -> at

  let prod at bt =
    bind at (fun a ->
        fmap (fun b -> (a, b)) bt)

  module Infix = struct
    let (>>=) = M.bind

    let (>>|) t f = fmap f t

    let (>|=) = (>>|)

    (* Applicative style *)
    let ( ^<$> ) f t = fmap f t

    let ( /<*> ) = fun f a ->
      f >>= fun f ->
      a >>= fun a ->
      return (f a)
  end

  module Syntax = struct
    let (let*) = Infix.(>>=)
    let (let+) = Infix.(>>|)
    let (and*) = prod
    let (and+) = prod
  end
end

module Make1(M : S1) = struct
  type 'a t = 'a M.t
  type ('a, 'dummy) m = 'a t
  module M2 = struct
    type nonrec ('a, _) t = 'a t
    include (M : S1 with type 'a t := 'a M.t) (* hiding 'a t *)
  end
  include (Make2(M2) : sig
             include T2 with type ('a, 'dummy) t := ('a, 'dummy) m
             module Infix : Infix2 with type ('a, 'dummy) t := ('a, 'dummy) m
             module Syntax : Syntax2 with type ('a, 'dummy) t := ('a, 'dummy) m
           end)
end

module Make = Make1