Question

Excuse me the lengthy example:

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

module MonadOps (Monad : MONAD) = struct
  include Monad
  type ('r, 'a) monad = ('r, 'a) t
  let run x = x
  let return = Monad.return
  let bind = Monad.bind
  let (>>=) a b = bind a b
  let rec foldM f a = function
    | [] -> return a
    | x::xs -> f a x >>= fun a' -> foldM f a' xs
  let whenM p s = if p then s else return ()
  let lift f m = perform x <-- m; return (f x)
  let join m = perform x <-- m; x
  let (>=>) f g = fun x -> f x >>= g
end

module Monad = (MonadOps : functor (M : MONAD) -> sig
  type ('a, 'b) monad
  val run : ('a, 'b) monad -> ('a, 'b) M.t
  val return : 'a -> ('b, 'a) monad
  val bind : ('a, 'b) monad -> ('b -> ('a, 'c) monad) -> ('a, 'c) monad
  val ( >>= ) :
    ('a, 'b) monad -> ('b -> ('a, 'c) monad) -> ('a, 'c) monad
  val foldM :
    ('a -> 'b -> ('c, 'a) monad) -> 'a -> 'b list -> ('c, 'a) monad
  val whenM : bool -> ('a, unit) monad -> ('a, unit) monad
  val lift : ('a -> 'b) -> ('c, 'a) monad -> ('c, 'b) monad
  val join : ('a, ('a, 'b) monad) monad -> ('a, 'b) monad
  val ( >=> ) :
    ('a -> ('b, 'c) monad) ->
    ('c -> ('b, 'd) monad) -> 'a -> ('b, 'd) monad
end)

module type MONAD_PLUS = sig
  include MONAD
  val mzero : ('r, 'a) t
  val mplus : ('r, 'a) t -> ('r, 'a) t -> ('r, 'a) t
end

module MonadPlusOps (MonadPlus : MONAD_PLUS) = struct
  include MonadOps (MonadPlus)
  let mzero = MonadPlus.mzero
  let mplus = MonadPlus.mplus
  let fail = mzero
  let (++) a b = mplus a b
  let guard p = if p then return () else fail
end

Is there a way to have MonadPlus analogous to Monad without excessive signature code duplication? Along the lines of (wrong solution):

module MonadPlus = (MonadPlusOps : functor (M : MONAD_PLUS) -> sig
  include module type of MonadPlusOps (M)
    with type ('a, 'b) t := ('a, 'b) MonadPlusOps (M).monad
end)

or (does not type-check):

module MonadPlus = (MonadPlusOps : functor (M : MONAD_PLUS) -> sig
  include module type of Monad(M)
  val mzero : ('a, 'b) monad
  (* ... *)
end)

Edit: updated — better final solution

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

module type MONAD_OPS = sig
  type ('s, 'a) monad
  include MONAD with type ('s, 'a) t := ('s, 'a) monad
  val ( >>= ) :
    ('s, 'a) monad -> ('a -> ('s, 'b) monad) -> ('s, 'b) monad
  val foldM :
    ('a -> 'b -> ('s, 'a) monad) -> 'a -> 'b list -> ('s, 'a) monad
  val whenM : bool -> ('s, unit) monad -> ('s, unit) monad
  val lift : ('a -> 'b) -> ('s, 'a) monad -> ('s, 'b) monad
  val join : ('s, ('s, 'a) monad) monad -> ('s, 'a) monad
  val ( >=> ) :
    ('a -> ('s, 'b) monad) ->
    ('b -> ('s, 'c) monad) -> 'a -> ('s, 'c) monad
end

module MonadOps (M : MONAD) = struct
  open M
  type ('s, 'a) monad = ('s, 'a) t
  let run x = x
  let (>>=) a b = bind a b
  let rec foldM f a = function
    | [] -> return a
    | x::xs -> f a x >>= fun a' -> foldM f a' xs
  let whenM p s = if p then s else return ()
  let lift f m = perform x <-- m; return (f x)
  let join m = perform x <-- m; x
  let (>=>) f g = fun x -> f x >>= g
end

module Monad (M : MONAD) =
sig
  include MONAD_OPS
  val run : ('s, 'a) monad -> ('s, 'a) M.t
end = struct
  include M
  include MonadOps(M)
end

module type MONAD_PLUS = sig
  include MONAD
  val mzero : ('s, 'a) t
  val mplus : ('s, 'a) t -> ('s, 'a) t -> ('s, 'a) t
end

module type MONAD_PLUS_OPS = sig
  include MONAD_OPS
  val mzero : ('s, 'a) monad
  val mplus : ('s, 'a) monad -> ('s, 'a) monad -> ('s, 'a) monad
  val fail : ('s, 'a) monad
  val (++) : ('s, 'a) monad -> ('s, 'a) monad -> ('s, 'a) monad
  val guard : bool -> ('s, unit) monad
end

module MonadPlus (M : MONAD_PLUS) :
sig
  include MONAD_PLUS_OPS
  val run : ('s, 'a) monad -> ('s, 'a) M.t
end = struct
  include M
  include MonadOps(M)
  let fail = mzero
  let (++) a b = mplus a b
  let guard p = if p then return () else fail
end

Answer 1

I’m not entirely sure what you are trying to achieve, but I would perhaps try to factor it as follows:

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

module type MONAD_OPS =
sig
  type ('a, 'b) monad
  val run : ('a, 'b) monad -> ('a, 'b) monad
  val (>>=) : ('a, 'b) monad -> ('b -> ('a, 'c) monad) -> ('a, 'c) monad
  (* ... *)
end

module MonadOps (Monad : MONAD) : 
sig
  include MONAD with type ('a ,'b) t := ('a, 'b) Monad.t
  include MONAD_OPS with type ('a ,'b) monad = ('a, 'b) Monad.t
end =
struct
  include Monad
  type ('r, 'a) monad = ('r, 'a) t
  let run x = x
  let (>>=) = bind
  let rec foldM f a = function
    | [] -> return a
    | x::xs -> f a x >>= fun a' -> foldM f a' xs
  (* ... *)
end

module type MONAD_PLUS = sig
  include MONAD
  val mzero : ('r, 'a) t
  val mplus : ('r, 'a) t -> ('r, 'a) t -> ('r, 'a) t
end

module type MONAD_PLUS_OPS =
sig
  include MONAD_OPS
  val fail : ('r, 'a) monad
  val (++) : ('r, 'a) monad -> ('r, 'a) monad -> ('r, 'a) monad
  (* ... *)
end

module MonadPlusOps (MonadPlus : MONAD_PLUS) :
sig
  include MONAD_PLUS with type ('a ,'b) t := ('a, 'b) Monad.t
  include MONAD_PLUS_OPS with type ('a ,'b) monad = ('a, 'b) Monad.t
end =
struct
  include MonadPlus
  include MonadOps (MonadPlus)
  let fail = mzero
  let (++) = mplus
  (* ... *)
end