Commits

camlspotter committed ea8524f Merge

Comments (0)

Files changed (2)

 open Monad_intf
 
-module Make(M:S) : T with type 'a t := 'a M.t = struct
+module Generic = struct
+  module type MONAD = sig
+    type a
+    module Repr (M : S) : sig
+      val extract : a M.t
+    end
+  end
+    
+  type 'a t = (module MONAD with type a = 'a)
+  
+  let return (type a_) (a_ : a_) = (module struct
+    type a = a_
+    module Repr (M : S) = struct
+      let extract = M.return a_
+    end
+  end : MONAD with type a = a_)
+      
+  let bind (type a_) (type b_) (a_t : a_ t) (f : a_ -> b_ t) = (module struct
+    type a = b_
+    module AT = (val a_t)
+    module Repr (M : S) = struct
+      let at : a_ M.t = 
+        let module AT' = AT.Repr(M) in
+        AT'.extract
+      let extract : b_ M.t = M.bind at (fun a -> 
+        let b_t : b_ t = f a in
+        let module BT = (val b_t) in
+        let module BT' = BT.Repr(M) in
+        BT'.extract)
+    end
+  end : MONAD with type a = b_)
+  
+  module MakeRun( M : S ) = struct
+    let run (type a_) (a_t : a_ t) =
+      let module AT = (val a_t) in
+      let module AT' = AT.Repr(M) in
+      AT'.extract
+  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 tt = tt >>= fun at -> at
+end
+
+include Generic
+
+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))
     include Open_
   end
 
-  let ignore a = a >>= fun _ -> return ()
-  let void = ignore
+  let void a = a >>= fun _ -> return ()
 
   let rec seq = function
     | [] -> return []
   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
 
   let join tt = tt >>= fun at -> at
 end
-
 (** Monad implementation. See [Monad_intf] for more details. *)
 
 open Monad_intf
-module Make(M : S) : T with type 'a t := 'a M.t
+
+(** Generic monad type *)
+module Generic : sig
+  type 'a t
+       
+  val return : 'a -> 'a t
+  val bind : 'a t -> ('a -> 'b t) -> 'b t
+  val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
+  val fmap : ('a -> 'b) -> 'a t -> 'b t
+  val ( >>| ) : ('a -> 'b) -> 'a t -> 'b t
+  val map : f:('a -> 'b) -> 'a t -> 'b t
+  val ( ^<$> ) : ('a -> 'b) -> 'a t -> 'b t
+  val ( /<*> ) : ('a -> 'b) t -> 'a t -> 'b t
+  val void : 'a t -> unit t
+  val seq : 'a t list -> 'a list t
+  val seq_ : unit t list -> unit t
+  val mapM : ('a -> 'b t) -> 'a list -> 'b list t
+  val for_ : int -> int -> (int -> unit t) -> unit t
+  val iteri : (int -> 'a -> unit t) -> 'a list -> unit t
+  val join : 'a t t -> 'a t
+end
+
+include module type of Generic
+
+module Make(M : S) : sig
+  include T with type 'a t := 'a M.t
+  val run : 'a Generic.t -> 'a M.t
+end
+
 module Make2(M : S2) : T2 with type ('a, 'z) t := ('a, 'z) M.t