Lifting polymorphic variants in a monad

Learning
1

I’m using polymorphic variants to define an error type which is then used to instantiate a monad. Something like:

module ErrorM(Error : sig type t end) = struct
  type 'a t = ('a,Error.t) Result.t
  let return: 'a -> 'a t = Result.ok
  let ( let* ): 'a t -> ('a -> 'b t) -> 'b t = Result.bind
  let error = Result.error
end

module M1 = struct
  type error = [ `DivByZero ]
  open ErrorM(struct type t = error end)

  let eval x y =
    if y = 0.0 then
      error `DivByZero
    else
      return (x /. y)
end

In a second module, the variant type is extended and used to instantiate a second monad:

module M2 = struct
  type error = [ M1.error | `SqrtOfNeg ]
  open ErrorM(struct type t = error end)

  let eval x y =
    let* u = M1.eval x y in
    let* v =
      if u < 0.0 then
        error `SqrtOfNeg
      else
        return (Float.sqrt u)
    in
    return v
end

Not surprisingly, M2 fails to typecheck. Even though M1.error < M2.error, any polymorphism is lost once the functions in the monad are used. A workaround is to coerce the error type in M1 to restore the polymorphism:

  let lift :
       error
    -> [> error] 
    = fun x -> (x : error :> [> error ])

  let lift_m:
       float t        (* = (float,error) Result.t *)
    -> (float,[> error]) Result.t
    = function
      | Result.Ok v -> Result.Ok v
      | Result.Error e -> Result.Error (lift e)

Then in M2, write:

  let* u = M1.lift_m (M1.eval x y) in

This is arguably not pretty; lift_m seems like a hack. Is there better, more idiomatic way to structure these modules and functors to avoid this?

2

Simplest solution might be to just forget the functor:

module ErrorM = struct
  type ('a,'e) t = ('a,'e) Result.t
  let return: 'a -> ('a,'e) t = Result.ok
  let ( let* ): ('a,'e) t -> ('a -> ('b,'e) t) -> ('b,'e) t = Result.bind
  let error = Result.error
end

module M1 = struct
  type error = [ `DivByZero ]
  open ErrorM

  let eval x y =
    if y = 0.0 then
      error `DivByZero
    else
      return (x /. y)
end

module M2 = struct
  type error = [ M1.error | `SqrtOfNeg ]
  open ErrorM

  let eval x y =
    let* u = M1.eval x y in
    let* v =
      if u < 0.0 then
        error `SqrtOfNeg
      else
        return (Float.sqrt u)
    in
    return v
end