仿函数的继承

Question

对不起冗长的例子：

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

有没有办法让MonadPlus类似于Monad而没有过多的签名代码重复？沿着（错误的解决方案）：

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)

或（不进行类型检查）：

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

修改更新 - 更好的最终解决方案

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

我不完全确定你想要实现的目标，但我可能会尝试将其考虑如下：

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

Answer 2

作为Andreas回答的补充，我希望证明你可以使用仿函数来制作签名。我没有完全按照你想要的类型抽象的确切级别进行讨论，因此这段代码将与Andreas的版本进行比较。

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

module MonadOpsSig (M : MonadSig.S) = struct
  module type S = sig
    type ('a, 'b) monad = ('a, 'b) M.t
    val run : ('a, 'b) monad -> ('a, 'b) monad
    val (>>=) : ('a, 'b) monad -> ('b -> ('a, 'c) monad) -> ('a, 'c) monad
    (* ... *)
  end
end

module MonadOps (M : MonadSig.S) : MonadOpsSig(M).S = struct
  open M
  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 MonadPlusSig = struct
  module type S = sig
    include MonadSig.S
    val mzero : ('r, 'a) t
    val mplus : ('r, 'a) t -> ('r, 'a) t -> ('r, 'a) t
  end
end

module MonadPlusOpsSig (Monad : MonadPlusSig.S) = struct
  module type S = sig
    include MonadOpsSig(Monad).S
    val fail : ('r, 'a) monad
    val (++) : ('r, 'a) monad -> ('r, 'a) monad -> ('r, 'a) monad
    (* ... *)
  end
end

module MonadPlusOps (M : MonadPlusSig.S) : MonadPlusOpsSig(M).S = struct
  include MonadOps(M)
  open M
  let fail = mzero
  let (++) = mplus
  (* ... *)
end

这个想法是为了提供一个参数化的签名，你可以将这个签名嵌入到参数化的仿函数中（我称之为“仿函数风格”），或者将参数定义为抽象（但它们确实是输入而不是输出），并在使用现场，将它们与实际参数等同起来（我称之为“mixin风格”）。我不是说上面的代码比Andreas更好，事实上我可能更喜欢使用他的版本，但比较它们很有意思。