Source

spotlib / lib / monad.ml

The default branch has multiple heads

Full commit
open Monad_intf

module Generic = struct

  module type MONAD = sig
    type a (** the parameter *)

    (** The generic monad is a function, 
        waiting an actual implementation of a monad *)
    module F(M : S) : sig val it : a M.t end
  end
    
  type 'a t = (module MONAD with type a = 'a)
  
  let return (type alpha) (alpha : alpha) : alpha t = (module struct
      type a = alpha
      module F (M : S) = struct let it = M.return alpha end
    end)

  let bind (type alpha) (type beta) 
      (module AT : MONAD with type a = alpha)  (* = module AT : alpha t *)
      (f : alpha -> beta t) : beta t = 
    (module struct
      type a = beta
          
      module F (M : S) = struct
        let it = 
          let aMt = let module ATFM = AT.F(M) in ATFM.it in
          M.bind aMt (fun a -> 
            let (module BT) = f a in
            let module BTFM = BT.F(M) in BTFM.it)
      end
    end)
  
  module MakeRun( M : S ) = struct
    let run (type alpha) (module AT : MONAD with type a = alpha) =
      let module ATFM = AT.F(M) in ATFM.it
  end
  
  let (>>=) = bind

  let fmap f t = bind t (fun x -> return (f x))
  let map ~f t = fmap f t
  let (>>|) = fmap
  
  (* Applicative style *)
  let ( ^<$> ) f t = map ~f t 
  let ( /<*> ) : ('a -> 'b) t -> 'a t -> 'b t = fun f a ->
      f >>= fun f -> 
      a >>= fun a ->
      return (f a)
  
  let void a = a >>= fun _ -> return ()
  
  let rec seq = function
    | [] -> return []
    | x::xs -> 
        x >>= fun x -> 
        seq xs >>= fun xs ->
        return (x::xs)
  
  let rec seq_ = function
    | [] -> return ()
    | x::xs -> x >>= fun () -> seq_ xs
  
  let mapM f ls = seq (List.map f ls)
  
  let rec for_ i to_ f =
    if i > to_ then return ()
    else f i >>= fun () -> for_ (i+1) to_ f
  
  let iteri f ls = seq_ (Xlist.mapi f ls)
  let join att = att >>= fun at -> at
end

module Make(M:S) : sig 
  include T with type 'a t := 'a M.t 
  val run : 'a Generic.t -> 'a M.t
end = struct
  include M

  let fmap f t = bind t (fun x -> return (f x))
  let liftM = fmap
  let map ~f t = fmap f t

  let fmap2 f t1 t2 = bind t1 (fun v1 -> bind t2 (fun v2 -> return (f v1 v2)))
  let liftM2 = fmap2

  module Open_ = struct
    let bind = M.bind
    let (>>=) = M.bind
    let fmap = fmap
    let (>>|) t f = fmap f t
    let return = return

    (* Applicative style *)
    let ( ^<$> ) f t = map ~f t 
    let ( /<*> ) : ('a -> 'b) t -> 'a t -> 'b t = fun f a ->
      f >>= fun f -> 
      a >>= fun a ->
      return (f a)
  end
  include Open_
  module Open = struct
    type 'a t = 'a M.t
    include Open_
  end

  let void a = a >>= fun _ -> return ()

  let rec seq = function
    | [] -> return []
    | x::xs -> 
        x >>= fun x -> 
        seq xs >>= fun xs ->
        return (x::xs)

  let rec seq_ = function
    | [] -> return ()
    | x::xs -> x >>= fun () -> seq_ xs

  let mapM f ls = seq (List.map f ls)

  let rec for_ i to_ f =
    if i > to_ then return ()
    else f i >>= fun () -> for_ (i+1) to_ f
    
  let iteri f ls = seq_ (Xlist.mapi f ls)

  let join tt = tt >>= fun at -> at

  include Generic.MakeRun(M)  
end

module Make2(M:S2) : T2 with type ('a, 'z) t := ('a, 'z) M.t = struct
  include M

  let fmap f t = bind t (fun x -> return (f x))
  let map ~f t = fmap f t

  module Open_ = struct
    let bind = M.bind
    let (>>=) = M.bind
    let fmap = fmap
    let (>>|) t f = map ~f t
    let return = return

    (* Applicative style *)
    let ( ^<$> ) f t = map ~f t 
    let ( /<*> ) = fun f a ->
      f >>= fun f -> 
      a >>= fun a ->
      return (f a)
  end
  include Open_
  module Open = struct
    type ('a, 'z) t = ('a, 'z) M.t
    include Open_
  end

  let ignore a = a >>= fun _ -> return ()
  let void = ignore

  let rec seq = function
    | [] -> return []
    | x::xs -> 
        x >>= fun x -> 
        seq xs >>= fun xs ->
        return (x::xs)

  let rec seq_unit = function
    | [] -> return ()
    | x::xs -> x >>= fun () -> seq_unit xs

  let mapM f ls = seq (List.map f ls)

  let rec for_ i to_ f =
    if i > to_ then return ()
    else f i >>= fun () -> for_ (i+1) to_ f
    
  let iteri f ls = seq_unit (Xlist.mapi f ls)

  let join tt = tt >>= fun at -> at
end