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

module type Applicative = sig
  type 'a t
  val pure : 'a -> 'a t
  val apply : ('a -> 'b) t -> 'a t -> 'b t
end

module type Monad = sig
  type 'a t
  val return : 'a -> 'a t
  val bind : ('a -> 'b t) -> 'a t -> 'b t
end

module ApplicativeOfMonad (M : Monad) : Applicative with type 'a t = 'a M.t = struct
  type 'a t = 'a M.t
  let pure = M.return
  let apply f x = M.(bind (fun y -> bind (fun g -> return (g y)) f) x)
end

module FunctorOfApplicative (A : Applicative) : Functor with type 'a t = 'a A.t = struct
  type 'a t = 'a A.t
  let map f x = A.(apply (pure f) x)
end

module FunctorOfMonad (M : Monad) : Functor with type 'a t = 'a M.t = struct
  include FunctorOfApplicative(ApplicativeOfMonad(M))
end

module MonadDerive (M : Monad) = struct
  include M
  include ApplicativeOfMonad(M)
  include FunctorOfMonad(M)
  let (>>=) x f = bind f x
  let (<$>) x f = map x f
  let (<*>) x f = apply x f
end

module ListMonad = struct
  type 'a t = 'a list
  let return x = [x]
  let rec bind (f : 'a -> 'b list) : 'a list -> 'b list = function
    | [] -> []
    | x :: xs -> f x @ bind f xs
end

module Dlm = MonadDerive(ListMonad)

let pair x y = x, y
let cart_prod xs ys = Dlm.(pair <$> xs <*> ys)

let () = cart_prod [1;2;3;4] ["7"; "hello there"; "forthwith!"]
    |> List.iter (fun (x, y) -> print_endline @@ "(" ^ string_of_int x ^ ", " ^ y ^ ")")



(* ============================================================================================= *)

module StateMonad (S : sig type t end) = struct
  type 'a t = S.t -> S.t * 'a
  let return x s = (s, x)
  let bind f x s = let s', a = x s in f a s'
end

module IntStateMonad = StateMonad(struct type t = int end)