Monad with modular implicits

monad.ml

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

let fmap (implicit F : Functor) = F.map

implicit module FunctorList = struct
    type 'a t = 'a list
    let map = List.map
end

implicit module FunctorOption = struct
    type 'a t = 'a option
    let map f = function
        | Some x -> Some (f x)
        | None -> None
end

module type Applicative = sig
    module F : Functor
    val return : 'a -> 'a F.t
end

implicit module ApplicativeOption = struct
    module F = FunctorOption
    let return x = Some x
end

implicit module ApplicativeList = struct
    module F = FunctorList
    let return x = [x]
end

module type Monad = sig
    module A : Applicative
    val bind : 'a A.F.t -> ('a -> 'b A.F.t) -> 'b A.F.t
end

let return (implicit M : Monad) = M.A.return
let (>>=) (implicit M : Monad) = M.bind

let join (implicit M : Monad) n = M.bind n (fun x -> x)

let sequence (implicit M : Monad) ms = 
    let k m n = m >>= (fun x -> n >>= (fun xs -> return (x :: xs))) in
    List.fold_right k ms (return [])

let mapM (implicit M : Monad) f xs = sequence (List.map f xs)

implicit module MonadOption = struct
    module A = ApplicativeOption
    let bind mx f = match mx with
        | Some x -> f x
        | None -> None
end

implicit module MonadList = struct
    module A = ApplicativeList
    let bind x f =
        let (<<) h g y = h (g y) in
        List.fold_right (List.append << f) x []
end