(** how to sharing the code is still a problem
how to encode the relationship
Monad => MonadState
*)
module type MONAD = sig
type ('a,'param) t
val return: 'a -> ('a,'param) t
val (>>=): ('a,'param) t -> ('a -> ('b,'param) t) -> ('b,'param) t
end
module type Monad =sig
type a
type param
module Repr (M:MONAD):sig
val extract: (a,param) M.t
end
end
module type MONADSTATE =sig
include MONAD
val gets: ('s->'a) -> ('a,'s)t
end
module type MonadState = sig
type a
type param
module Repr(M:MONADSTATE) : sig
val extract:(a,param) M.t
end
end
(*
reify a type constructor ['a t] as a module
*)
type ('a,'param) monad =
(module Monad with type a = 'a and type param='param)
type ('a,'param) monad_state =
(module MonadState with type a = 'a and type param = 'param)
(* result can not esscape M *)
(* let get (type s) (mx :s monad) (module M: MONAD) =
* let module MX = (val mx) in
* let module NX = MX.Repr(M) in
* NX.extract *)
module Make(M:MONAD) = struct
include M
(* let unwrap (x:) *)
let run (type s) (type param) (mx : (s,param) monad) : (s,param) t =
let module MX = (val mx) in
let module NX = MX.Repr(M) in NX.extract
end
(* let unwrap (type s) (type p) (x: : (s,p) monad=
* (module struct
* type a = s
* type param = p
* module Repr (M : MONAD) = struct
* let extract = x
* end
* end ) *)
(** how to reuse [return] for monad_state
if not reusable,
reuse liftM
*)
let return (type s) (type p) x : (s,p) monad=
(module struct
type a = s
type param = p
module Repr (M : MONAD) = struct
let extract = M.return x
end
end )
let (>>=) (type s) (type t) (type p)
(mx:(s,p) monad)
(f:s -> (t,p) monad)
: (t,p) monad =
(module struct
type a = t
type param = p
module Repr (M:MONAD) = struct
let extract =
let module MX = (val mx) in
let module RX = MX.Repr(M) in
M.(RX.extract >>= fun x ->
let my = f x in
let module MY = (val my) in
let module RY = MY.Repr(M) in
RY.extract)
end
end);;
let liftM f mx = mx >>= fun x -> return (f x)
let (>>) mx my = mx >>= fun _ -> my
(* let guard p = if p then return () else fail *)
module OptionM = Make(struct
type ('a,'param) t = 'a option
let return x = Some x
let (>>=) mx f = match mx with None -> None | Some x -> f x
end)
module ListM = Make(struct
type ('a,
'param
) t
= 'a
list let return x = [x]
let (>>=) mx f
= List.(concat
(map f mx
)) end)
;;
(* module StateM = Make(struct
* type 'a t = (s -> ('a*s))
* end) *)
liftM
succ (return
3) >>= fun x
-> return
(succ x
);;
match OptionM
.run v
with Some v
-> print_int v
module StateM = struct
include Make(struct
type ('a,'param) t = ('param -> ('a*'param))
let return x = (fun s -> (x,s))
let (>>=) mx f = fun s ->
let a,s = mx s in
f a s
let gets f = fun s -> return (f s)
end)
end
(*
gets :: (s->a) -> a monad
*)