end
module type MONADT = sig
- include MONAD
type 'a ut
+ include MONAD
val hoist : 'a ut -> 'a t
end
- module type MONADZERO = sig
- include MONAD
+ module type ZERO = sig
+ type 'a t
(* mzero is a value of type α that is exemplified by Nothing for the box type Maybe α and by [] for the box type List α. It has the behavior that anything ¢ mzero == mzero == mzero ¢ anything == mzero >>= anything. In Haskell, this notion is called Control.Applicative.empty or Control.Monad.mzero. *)
val mzero : 'a t
val guard : bool -> unit t
+ end
+
+ module type MONADZERO = sig
+ include MONAD
+ include ZERO with type 'a t := 'a t
end
module type MONADZEROT = sig
- include MONADZERO
- type 'a ut
- val hoist : 'a ut -> 'a t
+ include MONADT
+ include ZERO with type 'a t := 'a t
end
-
+
module type MAPPABLE2 = sig
type ('a,'d) t
val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t
let do_unless res xx = if res then mid () else xx
end
- module MonadFromT(B : TRANS) : MONADT with type 'a t = 'a B.t and type 'a ut := 'a B.U.t and type 'a result = 'a B.result = struct
+ module MonadFromT(B : TRANS) : MONADT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = struct
include MonadFromBind(struct
include B
let mid x = hoist U.(mid x)
let hoist = B.hoist
end
- module MonadFromTUZ(B : TRANSUZ) : MONADZEROT with type 'a t = 'a B.t and type 'a ut := 'a B.U.t and type 'a result = 'a B.result = struct
+ module MonadFromTUZ(B : TRANSUZ) : MONADZEROT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = struct
let mzero = Obj.magic (B.hoist (B.U.mzero)) (* Obj.magic hack to generate enough polymorphism without having to thunk mzero *)
include MonadFromBind(struct
include B
let guard res = if res then mid () else mzero
end
- module MonadFromTZ(B : TRANSZ) : MONADZEROT with type 'a t = 'a B.t and type 'a ut := 'a B.U.t and type 'a result = 'a B.result = struct
+ module MonadFromTZ(B : TRANSZ) : MONADZEROT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = struct
include MonadFromBind(struct
include B
let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero
end (* Make *)
+ module type OPTION = sig
+ include MONADZERO with type 'a result = 'a option
+ val test : ('a option -> bool) -> 'a t -> 'a t
+ end
+ module type OPTIONT = sig
+ type 'a uresult
+ include MONADT with type 'a result = 'a option uresult
+ val test : ('a option ut -> bool) -> 'a t -> 'a t
+ end
+
module Option = struct
include Juli8.Option
module type EXTRA = sig
type ('a,'d) t
val test : ('a option -> bool) -> ('a,'d) t -> ('a,'d) t
end
- module M : sig
- include MONADZERO with type 'a result = 'a option
- include EXTRA with type 'a t := 'a t
- end = struct
+ module M : OPTION = struct
include Make.MonadFromBind(struct
type 'a t = 'a option
type 'a result = 'a t let run xx = xx
let guard res : (unit,'d) t = if res then Some () else None
let test p xx = if p xx then xx else None
end (* Option.M2 *)
- module T(U : MONAD) : sig
- include MONADZEROT with type 'a result = 'a option U.result and type 'a ut := 'a U.t
- include EXTRA with type 'a t := 'a t
- val test : ('a option U.t -> bool) -> 'a t -> 'a t
- end = struct
+ module T(U : MONAD) : OPTIONT with type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
include Make.MonadFromTZ(struct
module U = U
type 'a t = 'a option U.t
end (* Option.T2 *)
end (* Option *)
+
+ module type LIST = sig
+ include MONADZERO with type 'a result = 'a list
+ val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
+ val pick : 'a t -> ('a * 'a t) t (* monadically pick each element *)
+ val test : ('a list -> bool) -> 'a t -> 'a t
+ end
+
+ module type LISTT = sig
+ type 'a uresult
+ include MONADZEROT with type 'a result = 'a list uresult
+ val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
+ val pick : 'a t -> ('a * 'a t) t (* monadically pick each element *)
+ val test : ('a list ut -> bool) -> 'a t -> 'a t
+ (*
+ Monadically seq k over box<a>.
+ OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running)
+ ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...]
+ TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly
+ *)
+ val distribute : ('a -> 'b ut) -> 'a list -> 'b t
+ end
+
module List = struct
include Juli8.List
- module type EXTRA = sig
- type 'a t
- val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
- val pick : 'a t -> ('a * 'a t) t (* monadically pick each element *)
- val test : ('a list (* U.t *) -> bool) -> 'a t -> 'a t
- end
module type EXTRA2 = sig
type ('a,'d) t
val (++) : ('a,'d) t -> ('a,'d) t -> ('a,'d) t
val pick : ('a,'d) t -> ('a * ('a,'d) t,'d) t
val test : ('a list -> bool) -> ('a,'d) t -> ('a,'d) t
end
- module M : sig
- include MONADZERO with type 'a result = 'a list
- include EXTRA with type 'a t := 'a t
- end = struct
+ module M : LIST = struct
include Make.MonadFromBind(struct
type 'a t = 'a list
type 'a result = 'a t let run xx = xx
let rec pick = function [] -> mzero | x::xs -> mid (x,xs) ++ (pick xs >>= fun (y,ys) -> mid (y, x::ys))
let test p xx = if p xx then xx else []
end (* List.M2 *)
- module T(U : MONAD) : sig
- include MONADZEROT with type 'a result = 'a list U.result and type 'a ut := 'a U.t
- include EXTRA with type 'a t := 'a t
- val test : ('a list U.t -> bool) -> 'a t -> 'a t
- (*
- Monadically seq k over box<a>.
- OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running)
- ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...]
- TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly
- *)
- val distribute : ('a -> 'b U.t) -> 'a list -> 'b t
- end = struct
+ module T(U : MONAD) : LISTT with type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
let distribute k xs = U.seq (List.map k xs)
include Make.MonadFromTZ(struct
module U = U
(* LTree, unit centers, has natural ++ *)
(* ITree, unit leaves, has natural mzero *)
+ module type TREE = sig
+ type 'a tree
+ include MONAD with type 'a result = 'a tree
+ val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
+ end
+
+ module type TREET = sig
+ type 'a tree
+ type 'a uresult
+ include MONADT with type 'a result = 'a tree uresult
+ val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
+ (*
+ Monadically seq k over box<a>.
+ OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running)
+ ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...]
+ TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly
+ *)
+ val distribute : ('a -> 'b ut) -> 'a tree -> 'b t
+ end
+
module LTree = struct
type 'a tree = Leaf of 'a | Branch of 'a tree * 'a tree
let branch x y = Branch(x,y)
| Leaf x -> Leaf (f x)
| Branch(l, r) -> Branch(aux l, aux r) in
aux xt
- module type EXTRA = sig
- type 'a t
- val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
- end
- module M : sig
- include MONAD with type 'a result = 'a tree
- include EXTRA with type 'a t := 'a t
- end = struct
+ module M : TREE with type 'a tree := 'a tree = struct
include Make.MonadFromBind(struct
type 'a t = 'a tree
type 'a result = 'a t let run xx = xx
end)
let (++) xx yy = Branch(xx, yy)
end (* Tree.M *)
- module T(U : MONAD) : sig
- include MONADT with type 'a result = 'a tree U.result and type 'a ut := 'a U.t
- include EXTRA with type 'a t := 'a t
- (*
- Monadically seq k over box<a>.
- OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running)
- ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...]
- TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly
- *)
- val distribute : ('a -> 'b U.t) -> 'a tree -> 'b t
- end = struct
+ module T(U : MONAD) : TREET with type 'a tree := 'a tree and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
let hoist uu = U.(uu >>= fun u -> mid (Leaf u))
let distribute k xt = traverse (U.map2 branch) (fun x -> hoist (k x)) xt
include Make.MonadFromT(struct
let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
end (* Tree.T *)
module Z(U : MONADZERO) : sig
- include MONADZEROT with type 'a result = 'a tree U.result and type 'a ut := 'a U.t
- include EXTRA with type 'a t := 'a t
- val distribute : ('a -> 'b U.t) -> 'a tree -> 'b t
+ include TREET with type 'a tree := 'a tree and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
+ include ZERO with type 'a t := 'a t
end = struct
let hoist uu = U.(uu >>= fun u -> mid (Leaf u))
let distribute k xt = traverse (U.map2 branch) (fun x -> hoist (k x)) xt
end
end
+
+ module type READER = sig
+ type env
+ include MONAD with type 'a result = env -> 'a
+ val ask : env t
+ val asks : (env -> 'a) -> 'a t
+ val shift : (env -> env) -> 'a t -> 'a t
+ end
+
+ module type READERT = sig
+ type env
+ type 'a uresult
+ include MONADT with type 'a result = env -> 'a uresult
+ val ask : env t
+ val asks : (env -> 'a) -> 'a t
+ val shift : (env -> env) -> 'a t -> 'a t
+ end
+
(* must be parameterized on `struct type env = ... end` *)
module Reader(E : sig type env end) = struct
type env = E.env
- module type EXTRA = sig
- type 'a t
- val ask : env t
- val asks : (env -> 'a) -> 'a t
- val shift : (env -> env) -> 'a t -> 'a t
- end
- module M : sig
- include MONAD with type 'a result = env -> 'a
- include EXTRA with type 'a t := 'a t
- end = struct
+ module M : READER with type env := env = struct
include Make.MonadFromBind(struct
type 'a t = env -> 'a
type 'a result = 'a t let run xx = fun e -> xx e
let asks selector = ask >>= (fun e -> mid (selector e)) (* may fail with Not_found *)
let shift modifier xx = fun e -> xx (modifier e)
end (* Reader.M *)
- module T(U : MONAD) : sig
- include MONADT with type 'a result = env -> 'a U.result and type 'a ut := 'a U.t
- include EXTRA with type 'a t := 'a t
- end = struct
+ module T(U : MONAD) : READERT with type env := env and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
include Make.MonadFromT(struct
module U = U
type 'a t = env -> 'a U.t
let shift modifier xx = fun e -> xx (modifier e)
end (* Reader.T *)
module Z(U : MONADZERO) : sig
- include MONADZEROT with type 'a result = env -> 'a U.result and type 'a ut := 'a U.t
- include EXTRA with type 'a t := 'a t
+ include READERT with type env := env and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
+ include ZERO with type 'a t := 'a t
end = struct
include Make.MonadFromTUZ(struct
module U = U
end (* Reader.Z *)
end (* Reader *)
+
+ module type STATE = sig
+ type store
+ include MONAD with type 'a result = store -> 'a * store
+ val get : store t
+ val gets : (store -> 'a) -> 'a t
+ val put : store -> unit t
+ val modify : (store -> store) -> unit t
+ end
+
+ module type STATET = sig
+ type store
+ type 'a uresult
+ include MONADT with type 'a result = store -> ('a * store) uresult
+ val get : store t
+ val gets : (store -> 'a) -> 'a t
+ val put : store -> unit t
+ val modify : (store -> store) -> unit t
+ end
+
(* must be parameterized on `struct type store = ... end` *)
module State(S : sig type store end) = struct
type store = S.store
- module type EXTRA = sig
- type 'a t
- val get : store t
- val gets : (store -> 'a) -> 'a t
- val put : store -> unit t
- val modify : (store -> store) -> unit t
- end
- module M : sig
- include MONAD with type 'a result = store -> 'a * store
- include EXTRA with type 'a t := 'a t
- end = struct
+ module M : STATE with type store := store = struct
include Make.MonadFromBind(struct
type 'a t = store -> 'a * store
type 'a result = 'a t let run xx = fun s -> xx s
let put s = fun _ -> (), s
let modify modifier = fun s -> (), modifier s
end (* State.M *)
- module T(U : MONAD) : sig
- include MONADT with type 'a result = store -> ('a * store) U.result and type 'a ut := 'a U.t
- include EXTRA with type 'a t := 'a t
- end = struct
+ module T(U : MONAD) : STATET with type store := store and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
include Make.MonadFromT(struct
module U = U
type 'a t = store -> ('a * store) U.t
let modify modifier = fun s -> U.mid ((), modifier s)
end (* State.T *)
module Z(U : MONADZERO) : sig
- include MONADZEROT with type 'a result = store -> ('a * store) U.result and type 'a ut := 'a U.t
- include EXTRA with type 'a t := 'a t
+ include STATET with type store := store and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
+ include ZERO with type 'a t := 'a t
end = struct
include Make.MonadFromTUZ(struct
module U = U
end (* State.Z *)
end (* State *)
+
+ module type REF = sig
+ type ref
+ type value
+ include MONAD with type 'a result = 'a
+ val newref : value -> ref t
+ val deref : ref -> value t
+ val change : ref -> value -> unit t
+ end
+
+ module type REFT = sig
+ type ref
+ type value
+ type 'a uresult
+ include MONADT with type 'a result = 'a uresult
+ val newref : value -> ref t
+ val deref : ref -> value t
+ val change : ref -> value -> unit t
+ end
+
(* State with a different interface; must be parameterized on `struct type value = ... end` *)
module Ref(V : sig type value end) = struct
type ref = int
let alloc v d = d.next, { next = succ d.next; tree = D.add d.next v d.tree}
let read (k : ref) d = D.find k d.tree
let write (k : ref) v d = { next = d.next; tree = D.add k v d.tree }
- module type EXTRA = sig
- type 'a t
- val newref : value -> ref t
- val deref : ref -> value t
- val change : ref -> value -> unit t
- end
- module M : sig
- include MONAD with type 'a result = 'a
- include EXTRA with type 'a t := 'a t
- end = struct
+ module M : REF with type value := value and type ref := ref = struct
include Make.MonadFromBind(struct
type 'a t = dict -> 'a * dict
type 'a result = 'a let run xx = fst (xx empty)
let deref k = fun s -> read k s, s (* shouldn't fail because k will have an abstract type? and we never GC *)
let change k v = fun s -> (), write k v s (* shouldn't allocate because k will have an abstract type *)
end (* Ref.M *)
- module T(U : MONAD) : sig
- include MONADT with type 'a result = 'a U.result and type 'a ut := 'a U.t
- include EXTRA with type 'a t := 'a t
- end = struct
+ module T(U : MONAD) : REFT with type value := value and type ref := ref and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
include Make.MonadFromT(struct
module U = U
type 'a t = dict -> ('a * dict) U.t
let change k v = fun s -> U.mid ((), write k v s)
end (* Ref.T *)
module Z(U : MONADZERO) : sig
- include MONADZEROT with type 'a result = 'a U.result and type 'a ut := 'a U.t
- include EXTRA with type 'a t := 'a t
+ include REFT with type value := value and type ref := ref and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
+ include ZERO with type 'a t := 'a t
end = struct
include Make.MonadFromTUZ(struct
module U = U
end (* Ref.Z *)
end (* Ref *)
+
+ module type WRITER = sig
+ type log
+ include MONAD with type 'a result = 'a * log
+ val listen : 'a t -> ('a * log) t
+ val listens : (log -> 'b) -> 'a t -> ('a * 'b) t
+ val tell : log -> unit t
+ (* val pass : ('a * (log -> log)) t -> 'a t *)
+ val censor : (log -> log) -> 'a t -> 'a t
+ end
+
+ module type WRITERT = sig
+ type log
+ type 'a uresult
+ include MONADT with type 'a result = ('a * log) uresult
+ val listen : 'a t -> ('a * log) t
+ val listens : (log -> 'b) -> 'a t -> ('a * 'b) t
+ val tell : log -> unit t
+ (* val pass : ('a * (log -> log)) t -> 'a t *)
+ val censor : (log -> log) -> 'a t -> 'a t
+ end
+
(* must be parameterized on `struct type log = ... end` *)
module Writer(W : sig type log val empty : log val append : log -> log -> log end) = struct
type log = W.log
- module type EXTRA = sig
- type 'a t
- val listen : 'a t -> ('a * log) t
- val listens : (log -> 'b) -> 'a t -> ('a * 'b) t
- val tell : log -> unit t
- (* val pass : ('a * (log -> log)) t -> 'a t *)
- val censor : (log -> log) -> 'a t -> 'a t
- end
- module M : sig
- include MONAD with type 'a result = 'a * log
- include EXTRA with type 'a t := 'a t
- end = struct
+ module M : WRITER with type log := log = struct
include Make.MonadFromBind(struct
type 'a t = 'a * log
type 'a result = 'a t let run xx = xx
let pass ((x,c),w) = (x, c w) (* usually use censor *)
let censor c xx = pass (xx >>= fun x -> mid (x,c)) (* ==> (x, c w) *)
end (* Writer.M *)
- module T(U : MONAD) : sig
- include MONADT with type 'a result = ('a * log) U.result and type 'a ut := 'a U.t
- include EXTRA with type 'a t := 'a t
- end = struct
+ module T(U : MONAD) : WRITERT with type log := log and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
include Make.MonadFromT(struct
module U = U
type 'a t = ('a * log) U.t
let censor c xx = pass (xx >>= fun x -> mid (x,c))
end (* Writer.T *)
module Z(U : MONADZERO) : sig
- include MONADZEROT with type 'a result = ('a * log) U.result and type 'a ut := 'a U.t
- include EXTRA with type 'a t := 'a t
+ include WRITERT with type log := log and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
+ include ZERO with type 'a t := 'a t
end = struct
include Make.MonadFromTUZ(struct
module U = U
end (* Writer.Z *)
end (* Writer *)
- (* must be parameterized on `struct type err = ... end` *)
- module Error(E : sig type err exception Exc of err end) = struct
- type err = E.err
- type 'a error = Error of err | OK of 'a
- module type EXTRA = sig
- type 'a t
- val throw : err -> 'a t
- val catch : 'a t -> (err -> 'a t) -> 'a t
- end
- module M : sig
- include MONAD with type 'a result = 'a error
- include EXTRA with type 'a t := 'a t
- end = struct
+
+ module type ERROR = sig
+ type msg
+ type 'a error
+ include MONAD with type 'a result = 'a error
+ val throw : msg -> 'a t
+ val catch : 'a t -> (msg -> 'a t) -> 'a t
+ end
+
+ module type ERRORT = sig
+ type msg
+ type 'a error
+ type 'a uresult
+ include MONADT with type 'a result = 'a uresult (* note the difference from ERROR *)
+ val throw : msg -> 'a t
+ val catch : 'a t -> (msg -> 'a t) -> 'a t
+ end
+
+ (* must be parameterized on `struct type msg = ... end` *)
+ module Error(E : sig type msg exception Exc of msg (* Exc used only by T *) end) = struct
+ type msg = E.msg
+ type 'a error = Error of msg | OK of 'a
+ module M : ERROR with type msg := msg and type 'a error := 'a error = struct
include Make.MonadFromBind(struct
type 'a t = 'a error
- type 'a result = 'a t let run xx = xx
+ type 'a result = 'a t
+ (* note that M.run doesn't raise *)
+ let run xx = xx
let map = `Generate let map2 = `Generate let mapply = `Generate
let mid x = OK x
let (>>=) xx k = match xx with OK x -> k x | Error e -> Error e
let throw e = Error e
let catch xx handler = match xx with OK _ -> xx | Error e -> handler e
end (* Error.M *)
- module T(U : MONAD) : sig
- include MONADT with type 'a result = 'a U.result and type 'a ut := 'a U.t
- include EXTRA with type 'a t := 'a t
- end = struct
+ module T(U : MONAD) : ERRORT with type msg := msg and type 'a error := 'a error and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct
include Make.MonadFromT(struct
module U = U
type 'a t = 'a error U.t
type 'a result = 'a U.result
+ (* note that T.run does raise *)
let run xx = let uu = U.(xx >>= function OK x -> mid x | Error e -> raise (E.Exc e)) in U.run uu
let hoist uu = U.(uu >>= fun u -> mid (OK u))
let (>>=) xx k = U.(xx >>= function OK x -> k x | Error e -> mid (Error e))
let catch xx handler = U.(xx >>= function OK _ as x -> mid x | Error e -> handler e)
end (* Error.T *)
module Z(U : MONADZERO) : sig
- include MONADZEROT with type 'a result = 'a U.result and type 'a ut := 'a U.t
- include EXTRA with type 'a t := 'a t
+ include ERRORT with type msg := msg and type 'a error := 'a error and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
+ include ZERO with type 'a t := 'a t
end = struct
include Make.MonadFromTUZ(struct
module U = U
end (* Error.Z *)
end (* Error *)
+
(* predefine some common instances *)
- module Writer1 = Writer(struct type log = string let empty = "" let append s1 s2 = s1 ^ "\n" ^ s2 end)
+ module Writer1 = Writer(struct type log = string let empty = "" let append s1 s2 = if s2 = "" then s1 else if s1 = "" then s2 else s1 ^ "\n" ^ s2 end)
module Writer2 = struct
include Writer(struct
let run xx = let (x,w) = M.run xx in (x, List.rev w)
end
- module Failure = Error(struct type err = string exception Exc = Failure end)
+ module Failure = Error(struct type msg = string exception Exc = Failure end)
end (* Monad *)