* have to use operations like `run` to convert the abstract monadic types
* to types whose internals you have free access to.
*
+ * Acknowledgements: This is largely based on the mtl library distributed
+ * with the Glasgow Haskell Compiler. I've also been helped in
+ * various ways by posts and direct feedback from Oleg Kiselyov and
+ * Chung-chieh Shan. The following were also useful:
+ * - <http://pauillac.inria.fr/~xleroy/mpri/progfunc/>
+ * - Ken Shan "Monads for natural language semantics" <http://arxiv.org/abs/cs/0205026v1>
+ * - http://www.grabmueller.de/martin/www/pub/Transformers.pdf
+ * - http://en.wikibooks.org/wiki/Haskell/Monad_transformers
+ *
+ * Licensing: MIT (if that's compatible with the ghc sources this is partly
+ * derived from)
*)
+exception Undefined
(* Some library functions used below. *)
module Util = struct
let rec loop n accu =
if n == 0 then accu else loop (pred n) (fill :: accu)
in loop len []
+ (* Dirty hack to be a default polymorphic zero.
+ * To implement this cleanly, monads without a natural zero
+ * should always wrap themselves in an option layer (see Tree_monad). *)
+ let undef = Obj.magic (fun () -> raise Undefined)
end
(*
* Signature extenders:
* Make :: BASE -> S
- * MakeCatch, MakeDistrib :: PLUSBASE -> PLUS
- * which merges into S
- * (P is merged sig)
- * MakeT :: TRANS (with Wrapped : S or P) -> custom sig
- *
- * Make2 :: BASE2 -> S2
- * MakeCatch2, MakeDistrib2 :: PLUSBASE2 -> PLUS2 (P2 is merged sig)
- * to wrap double-typed inner monads:
- * MakeT2 :: TRANS2 (with Wrapped : S2 or P2) -> custom sig
- *
+ * MakeT :: BASET (with Wrapped : S) -> result sig not declared
*)
-
(* type of base definitions *)
module type BASE = sig
- (* The only constraints we impose here on how the monadic type
- * is implemented is that it have a single type parameter 'a. *)
- type 'a m
- type 'a result
- type 'a result_exn
- val unit : 'a -> 'a m
- val bind : 'a m -> ('a -> 'b m) -> 'b m
- val run : 'a m -> 'a result
+ (* We make all monadic types doubly-parameterized so that they
+ * can layer nicely with Continuation, which needs the second
+ * type parameter. *)
+ type ('x,'a) m
+ type ('x,'a) result
+ type ('x,'a) result_exn
+ val unit : 'a -> ('x,'a) m
+ val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
+ val run : ('x,'a) m -> ('x,'a) result
(* run_exn tries to provide a more ground-level result, but may fail *)
- val run_exn : 'a m -> 'a result_exn
+ val run_exn : ('x,'a) m -> ('x,'a) result_exn
+ (* To simplify the library, we require every monad to supply a plus and zero. These obey the following laws:
+ * zero >>= f === zero
+ * plus zero u === u
+ * plus u zero === u
+ * Additionally, they will obey one of the following laws:
+ * (Catch) plus (unit a) v === unit a
+ * (Distrib) plus u v >>= f === plus (u >>= f) (v >>= f)
+ * When no natural zero is available, use `let zero () = Util.undef`.
+ * The Make functor automatically detects for zero >>= ..., and
+ * plus zero _, plus _ zero; it also substitutes zero for pattern-match failures.
+ *)
+ val zero : unit -> ('x,'a) m
+ (* zero has to be thunked to ensure results are always poly enough *)
+ val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
end
module type S = sig
include BASE
- val (>>=) : 'a m -> ('a -> 'b m) -> 'b m
- val (>>) : 'a m -> 'b m -> 'b m
- val join : ('a m) m -> 'a m
- val apply : ('a -> 'b) m -> 'a m -> 'b m
- val lift : ('a -> 'b) -> 'a m -> 'b m
- val lift2 : ('a -> 'b -> 'c) -> 'a m -> 'b m -> 'c m
- val (>=>) : ('a -> 'b m) -> ('b -> 'c m) -> 'a -> 'c m
- val do_when : bool -> unit m -> unit m
- val do_unless : bool -> unit m -> unit m
- val forever : (unit -> 'a m) -> 'b m
- val sequence : 'a m list -> 'a list m
- val sequence_ : 'a m list -> unit m
+ val (>>=) : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
+ val (>>) : ('x,'a) m -> ('x,'b) m -> ('x,'b) m
+ val join : ('x,('x,'a) m) m -> ('x,'a) m
+ val apply : ('x,'a -> 'b) m -> ('x,'a) m -> ('x,'b) m
+ val lift : ('a -> 'b) -> ('x,'a) m -> ('x,'b) m
+ val lift2 : ('a -> 'b -> 'c) -> ('x,'a) m -> ('x,'b) m -> ('x,'c) m
+ val (>=>) : ('a -> ('x,'b) m) -> ('b -> ('x,'c) m) -> 'a -> ('x,'c) m
+ val do_when : bool -> ('x,unit) m -> ('x,unit) m
+ val do_unless : bool -> ('x,unit) m -> ('x,unit) m
+ val forever : (unit -> ('x,'a) m) -> ('x,'b) m
+ val sequence : ('x,'a) m list -> ('x,'a list) m
+ val sequence_ : ('x,'a) m list -> ('x,unit) m
+ val guard : bool -> ('x,unit) m
+ val sum : ('x,'a) m list -> ('x,'a) m
end
- (* Standard, single-type-parameter monads. *)
- module Make(B : BASE) : S with type 'a m = 'a B.m and type 'a result = 'a B.result and type 'a result_exn = 'a B.result_exn = struct
+ module Make(B : BASE) : S with type ('x,'a) m = ('x,'a) B.m and type ('x,'a) result = ('x,'a) B.result and type ('x,'a) result_exn = ('x,'a) B.result_exn = struct
include B
+ let bind (u : ('x,'a) m) (f : 'a -> ('x,'b) m) : ('x,'b) m =
+ if u == Util.undef then Util.undef
+ else B.bind u (fun a -> try f a with Match_failure _ -> zero ())
+ let plus u v =
+ if u == Util.undef then v else if v == Util.undef then u else B.plus u v
+ let run u =
+ if u == Util.undef then raise Undefined else B.run u
+ let run_exn u =
+ if u == Util.undef then raise Undefined else B.run_exn u
let (>>=) = bind
+ (* expressions after >> will be evaluated before they're passed to
+ * bind, so you can't do `zero () >> assert false`
+ * this works though: `zero () >>= fun _ -> assert false`
+ *)
let (>>) u v = u >>= fun _ -> v
let lift f u = u >>= fun a -> unit (f a)
(* lift is called listM, fmap, and <$> in Haskell *)
let (>=>) f g = fun a -> f a >>= g
let do_when test u = if test then u else unit ()
let do_unless test u = if test then unit () else u
+ (* A Haskell-like version works:
+ let rec forever uthunk = uthunk () >>= fun _ -> forever uthunk
+ * but the recursive call is not in tail position so this can stack overflow. *)
let forever uthunk =
- let rec loop () = uthunk () >>= fun _ -> loop ()
- in loop ()
+ let z = zero () in
+ let id result = result in
+ let kcell = ref id in
+ let rec loop _ =
+ let result = uthunk (kcell := id) >>= chained
+ in !kcell result
+ and chained _ =
+ kcell := loop; z (* we use z only for its polymorphism *)
+ in loop z
+ (* Reimplementations of the preceding using a hand-rolled State or StateT
+can also stack overflow. *)
let sequence ms =
let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
Util.fold_right op ms (unit [])
let replicateM n x = sequence (Util.replicate n x)
let replicateM_ n x = sequence_ (Util.replicate n x)
*)
- end
-
- (* Single-type-parameter monads that also define `plus` and `zero`
- * operations. These obey the following laws:
- * zero >>= f === zero
- * plus zero u === u
- * plus u zero === u
- * Additionally, these monads will obey one of the following laws:
- * (Catch) plus (unit a) v === unit a
- * (Distrib) plus u v >>= f === plus (u >>= f) (v >>= f)
- *)
- module type PLUSBASE = sig
- include BASE
- val zero : unit -> 'a m
- val plus : 'a m -> 'a m -> 'a m
- end
- module type PLUS = sig
- type 'a m
- val zero : unit -> 'a m
- val plus : 'a m -> 'a m -> 'a m
- val guard : bool -> unit m
- val sum : 'a m list -> 'a m
- end
- (* MakeCatch and MakeDistrib have the same implementation; we just declare
- * them twice to document which laws the client code is promising to honor. *)
- module MakeCatch(B : PLUSBASE) : PLUS with type 'a m = 'a B.m = struct
- type 'a m = 'a B.m
- let zero = B.zero
- let plus = B.plus
let guard test = if test then B.unit () else zero ()
let sum ms = Util.fold_right plus ms (zero ())
end
- module MakeDistrib = MakeCatch
(* Signatures for MonadT *)
- (* sig for Wrapped that include S and PLUS *)
- module type P = sig
- include S
- include PLUS with type 'a m := 'a m
- end
- module type TRANS = sig
+ module type BASET = sig
module Wrapped : S
- type 'a m
- type 'a result
- type 'a result_exn
- val bind : 'a m -> ('a -> 'b m) -> 'b m
- val run : 'a m -> 'a result
- val run_exn : 'a m -> 'a result_exn
- val elevate : 'a Wrapped.m -> 'a m
- (* lift/elevate laws:
- * elevate (W.unit a) == unit a
- * elevate (W.bind w f) == elevate w >>= fun a -> elevate (f a)
- *)
- end
- module MakeT(T : TRANS) = struct
- include Make(struct
- include T
- let unit a = elevate (Wrapped.unit a)
- end)
- let elevate = T.elevate
- end
-
-
- (* We have to define BASE, S, and Make again for double-type-parameter monads. *)
- module type BASE2 = sig
type ('x,'a) m
type ('x,'a) result
type ('x,'a) result_exn
- val unit : 'a -> ('x,'a) m
val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
val run : ('x,'a) m -> ('x,'a) result
val run_exn : ('x,'a) m -> ('x,'a) result_exn
- end
- module type S2 = sig
- include BASE2
- val (>>=) : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
- val (>>) : ('x,'a) m -> ('x,'b) m -> ('x,'b) m
- val join : ('x,('x,'a) m) m -> ('x,'a) m
- val apply : ('x,'a -> 'b) m -> ('x,'a) m -> ('x,'b) m
- val lift : ('a -> 'b) -> ('x,'a) m -> ('x,'b) m
- val lift2 : ('a -> 'b -> 'c) -> ('x,'a) m -> ('x,'b) m -> ('x,'c) m
- val (>=>) : ('a -> ('x,'b) m) -> ('b -> ('x,'c) m) -> 'a -> ('x,'c) m
- val do_when : bool -> ('x,unit) m -> ('x,unit) m
- val do_unless : bool -> ('x,unit) m -> ('x,unit) m
- val forever : (unit -> ('x,'a) m) -> ('x,'b) m
- val sequence : ('x,'a) m list -> ('x,'a list) m
- val sequence_ : ('x,'a) m list -> ('x,unit) m
- end
- module Make2(B : BASE2) : S2 with type ('x,'a) m = ('x,'a) B.m and type ('x,'a) result = ('x,'a) B.result and type ('x,'a) result_exn = ('x,'a) B.result_exn = struct
- (* code repetition, ugh *)
- include B
- let (>>=) = bind
- let (>>) u v = u >>= fun _ -> v
- let lift f u = u >>= fun a -> unit (f a)
- let join uu = uu >>= fun u -> u
- let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
- let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
- let (>=>) f g = fun a -> f a >>= g
- let do_when test u = if test then u else unit ()
- let do_unless test u = if test then unit () else u
- let forever uthunk =
- let rec loop () = uthunk () >>= fun _ -> loop ()
- in loop ()
- let sequence ms =
- let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
- Util.fold_right op ms (unit [])
- let sequence_ ms =
- Util.fold_right (>>) ms (unit ())
- end
-
- module type PLUSBASE2 = sig
- include BASE2
- val zero : unit -> ('x,'a) m
- val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
- end
- module type PLUS2 = sig
- type ('x,'a) m
+ val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
+ (* lift/elevate laws:
+ * elevate (W.unit a) == unit a
+ * elevate (W.bind w f) == elevate w >>= fun a -> elevate (f a)
+ *)
val zero : unit -> ('x,'a) m
val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
- val guard : bool -> ('x,unit) m
- val sum : ('x,'a) m list -> ('x,'a) m
- end
- module MakeCatch2(B : PLUSBASE2) : PLUS2 with type ('x,'a) m = ('x,'a) B.m = struct
- type ('x,'a) m = ('x,'a) B.m
- (* code repetition, ugh *)
- let zero = B.zero
- let plus = B.plus
- let guard test = if test then B.unit () else zero ()
- let sum ms = Util.fold_right plus ms (zero ())
- end
- module MakeDistrib2 = MakeCatch2
-
- (* Signatures for MonadT *)
- (* sig for Wrapped that include S and PLUS *)
- module type P2 = sig
- include S2
- include PLUS2 with type ('x,'a) m := ('x,'a) m
end
- module type TRANS2 = sig
- module Wrapped : S2
- type ('x,'a) m
- type ('x,'a) result
- type ('x,'a) result_exn
- val bind : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
- val run : ('x,'a) m -> ('x,'a) result
- val run_exn : ('x,'a) m -> ('x,'a) result_exn
- val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
- end
- module MakeT2(T : TRANS2) = struct
- (* code repetition, ugh *)
- include Make2(struct
+ module MakeT(T : BASET) = struct
+ include Make(struct
include T
let unit a = elevate (Wrapped.unit a)
end)
module Identity_monad : sig
(* expose only the implementation of type `'a result` *)
- type 'a result = 'a
- type 'a result_exn = 'a
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
+ type ('x,'a) result = 'a
+ type ('x,'a) result_exn = 'a
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
end = struct
module Base = struct
- type 'a m = 'a
- type 'a result = 'a
- type 'a result_exn = 'a
+ type ('x,'a) m = 'a
+ type ('x,'a) result = 'a
+ type ('x,'a) result_exn = 'a
let unit a = a
let bind a f = f a
let run a = a
let run_exn a = a
+ let zero () = Util.undef
+ let plus u v = u
end
include Monad.Make(Base)
end
module Maybe_monad : sig
(* expose only the implementation of type `'a result` *)
- type 'a result = 'a option
- type 'a result_exn = 'a
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- include Monad.PLUS with type 'a m := 'a m
+ type ('x,'a) result = 'a option
+ type ('x,'a) result_exn = 'a
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
(* MaybeT transformer *)
module T : functor (Wrapped : Monad.S) -> sig
- type 'a result = 'a option Wrapped.result
- type 'a result_exn = 'a Wrapped.result_exn
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- include Monad.PLUS with type 'a m := 'a m
- val elevate : 'a Wrapped.m -> 'a m
- end
- module T2 : functor (Wrapped : Monad.S2) -> sig
type ('x,'a) result = ('x,'a option) Wrapped.result
type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
- include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
- include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
end
end = struct
module Base = struct
- type 'a m = 'a option
- type 'a result = 'a option
- type 'a result_exn = 'a
- let unit a = Some a
- let bind u f = match u with Some a -> f a | None -> None
- let run u = u
- let run_exn u = match u with
- | Some a -> a
- | None -> failwith "no value"
- let zero () = None
- let plus u v = match u with None -> v | _ -> u
+ type ('x,'a) m = 'a option
+ type ('x,'a) result = 'a option
+ type ('x,'a) result_exn = 'a
+ let unit a = Some a
+ let bind u f = match u with Some a -> f a | None -> None
+ let run u = u
+ let run_exn u = match u with
+ | Some a -> a
+ | None -> failwith "no value"
+ let zero () = None
+ (* satisfies Catch *)
+ let plus u v = match u with None -> v | _ -> u
end
include Monad.Make(Base)
- include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m)
module T(Wrapped : Monad.S) = struct
- module Trans = struct
+ module BaseT = struct
include Monad.MakeT(struct
module Wrapped = Wrapped
- type 'a m = 'a option Wrapped.m
- type 'a result = 'a option Wrapped.result
- type 'a result_exn = 'a Wrapped.result_exn
- let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
- let bind u f = Wrapped.bind u (fun t -> match t with
- | Some a -> f a
- | None -> Wrapped.unit None)
- let run u = Wrapped.run u
- let run_exn u =
- let w = Wrapped.bind u (fun t -> match t with
- | Some a -> Wrapped.unit a
- | None -> failwith "no value")
- in Wrapped.run_exn w
- end)
- let zero () = Wrapped.unit None
- let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
- end
- include Trans
- include (Monad.MakeCatch(Trans) : Monad.PLUS with type 'a m := 'a m)
- end
- module T2(Wrapped : Monad.S2) = struct
- module Trans = struct
- include Monad.MakeT2(struct
- module Wrapped = Wrapped
type ('x,'a) m = ('x,'a option) Wrapped.m
type ('x,'a) result = ('x,'a option) Wrapped.result
type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
- (* code repetition, ugh *)
let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some a))
let bind u f = Wrapped.bind u (fun t -> match t with
| Some a -> f a
let run_exn u =
let w = Wrapped.bind u (fun t -> match t with
| Some a -> Wrapped.unit a
- | None -> failwith "no value")
- in Wrapped.run_exn w
+ | None -> Wrapped.zero ()
+ ) in Wrapped.run_exn w
+ let zero () = Wrapped.unit None
+ let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
end)
- let zero () = Wrapped.unit None
- let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
end
- include Trans
- include (Monad.MakeCatch2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
+ include BaseT
end
end
module List_monad : sig
(* declare additional operation, while still hiding implementation of type m *)
- type 'a result = 'a list
- type 'a result_exn = 'a
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- include Monad.PLUS with type 'a m := 'a m
- val permute : 'a m -> 'a m m
- val select : 'a m -> ('a * 'a m) m
+ type ('x,'a) result = 'a list
+ type ('x,'a) result_exn = 'a
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ val permute : ('x,'a) m -> ('x,('x,'a) m) m
+ val select : ('x,'a) m -> ('x,'a * ('x,'a) m) m
(* ListT transformer *)
module T : functor (Wrapped : Monad.S) -> sig
- type 'a result = 'a list Wrapped.result
- type 'a result_exn = 'a Wrapped.result_exn
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- include Monad.PLUS with type 'a m := 'a m
- val elevate : 'a Wrapped.m -> 'a m
+ type ('x,'a) result = ('x,'a list) Wrapped.result
+ type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
(* note that second argument is an 'a list, not the more abstract 'a m *)
(* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
- val distribute : ('a -> 'b Wrapped.m) -> 'a list -> 'b m
+ val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
(* TODO
val permute : 'a m -> 'a m m
val select : 'a m -> ('a * 'a m) m
*)
end
- module T2 : functor (Wrapped : Monad.S2) -> sig
- type ('x,'a) result = ('x,'a list) Wrapped.result
- type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
- include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
- include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
- val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
- val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
- end
end = struct
module Base = struct
- type 'a m = 'a list
- type 'a result = 'a list
- type 'a result_exn = 'a
+ type ('x,'a) m = 'a list
+ type ('x,'a) result = 'a list
+ type ('x,'a) result_exn = 'a
let unit a = [a]
let bind u f = Util.concat_map f u
let run u = u
| [a] -> a
| many -> failwith "multiple values"
let zero () = []
+ (* satisfies Distrib *)
let plus = Util.append
end
include Monad.Make(Base)
- include (Monad.MakeDistrib(Base) : Monad.PLUS with type 'a m := 'a m)
(* let either u v = plus u v *)
(* insert 3 [1;2] ~~> [[3;1;2]; [1;3;2]; [1;2;3]] *)
let rec insert a u =
let rec select u = match u with
| [] -> zero ()
| x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
- let base_plus = plus
module T(Wrapped : Monad.S) = struct
- module Trans = struct
- (* Wrapped.sequence ms ===
- let plus1 u v =
- Wrapped.bind u (fun x ->
- Wrapped.bind v (fun xs ->
- Wrapped.unit (x :: xs)))
- in Util.fold_right plus1 ms (Wrapped.unit []) *)
- (* distribute === Wrapped.mapM; copies alist to its image under f *)
- let distribute f alist = Wrapped.sequence (Util.map f alist)
- include Monad.MakeT(struct
- module Wrapped = Wrapped
- type 'a m = 'a list Wrapped.m
- type 'a result = 'a list Wrapped.result
- type 'a result_exn = 'a Wrapped.result_exn
- let elevate w = Wrapped.bind w (fun a -> Wrapped.unit [a])
- let bind u f =
- Wrapped.bind u (fun ts ->
- Wrapped.bind (distribute f ts) (fun tts ->
- Wrapped.unit (Util.concat tts)))
- let run u = Wrapped.run u
- let run_exn u =
- let w = Wrapped.bind u (fun ts -> match ts with
- | [] -> failwith "no values"
- | [a] -> Wrapped.unit a
- | many -> failwith "multiple values"
- ) in Wrapped.run_exn w
- end)
+ (* Wrapped.sequence ms ===
+ let plus1 u v =
+ Wrapped.bind u (fun x ->
+ Wrapped.bind v (fun xs ->
+ Wrapped.unit (x :: xs)))
+ in Util.fold_right plus1 ms (Wrapped.unit []) *)
+ (* distribute === Wrapped.mapM; copies alist to its image under f *)
+ let distribute f alist = Wrapped.sequence (Util.map f alist)
+
+ include Monad.MakeT(struct
+ module Wrapped = Wrapped
+ type ('x,'a) m = ('x,'a list) Wrapped.m
+ type ('x,'a) result = ('x,'a list) Wrapped.result
+ type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
+ let elevate w = Wrapped.bind w (fun a -> Wrapped.unit [a])
+ let bind u f =
+ Wrapped.bind u (fun ts ->
+ Wrapped.bind (distribute f ts) (fun tts ->
+ Wrapped.unit (Util.concat tts)))
+ let run u = Wrapped.run u
+ let run_exn u =
+ let w = Wrapped.bind u (fun ts -> match ts with
+ | [] -> Wrapped.zero ()
+ | [a] -> Wrapped.unit a
+ | many -> Wrapped.zero ()
+ ) in Wrapped.run_exn w
let zero () = Wrapped.unit []
let plus u v =
Wrapped.bind u (fun us ->
Wrapped.bind v (fun vs ->
- Wrapped.unit (base_plus us vs)))
- end
- include Trans
- include (Monad.MakeDistrib(Trans) : Monad.PLUS with type 'a m := 'a m)
+ Wrapped.unit (Base.plus us vs)))
+ end)
(*
let permute : 'a m -> 'a m m
let select : 'a m -> ('a * 'a m) m
*)
end
- module T2(Wrapped : Monad.S2) = struct
- module Trans = struct
- let distribute f alist = Wrapped.sequence (Util.map f alist)
- include Monad.MakeT2(struct
- module Wrapped = Wrapped
- type ('x,'a) m = ('x,'a list) Wrapped.m
- type ('x,'a) result = ('x,'a list) Wrapped.result
- type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
- (* code repetition, ugh *)
- let elevate w = Wrapped.bind w (fun a -> Wrapped.unit [a])
- let bind u f =
- Wrapped.bind u (fun ts ->
- Wrapped.bind (distribute f ts) (fun tts ->
- Wrapped.unit (Util.concat tts)))
- let run u = Wrapped.run u
- let run_exn u =
- let w = Wrapped.bind u (fun ts -> match ts with
- | [] -> failwith "no values"
- | [a] -> Wrapped.unit a
- | many -> failwith "multiple values"
- ) in Wrapped.run_exn w
- end)
- let zero () = Wrapped.unit []
- let plus u v =
- Wrapped.bind u (fun us ->
- Wrapped.bind v (fun vs ->
- Wrapped.unit (base_plus us vs)))
- end
- include Trans
- include (Monad.MakeDistrib2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
- end
end
(* declare additional operations, while still hiding implementation of type m *)
type err = Err.err
type 'a error = Error of err | Success of 'a
- type 'a result = 'a error
- type 'a result_exn = 'a
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- (* include Monad.PLUS with type 'a m := 'a m *)
- val throw : err -> 'a m
- val catch : 'a m -> (err -> 'a m) -> 'a m
+ type ('x,'a) result = 'a error
+ type ('x,'a) result_exn = 'a
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ val throw : err -> ('x,'a) m
+ val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
(* ErrorT transformer *)
module T : functor (Wrapped : Monad.S) -> sig
- type 'a result = 'a error Wrapped.result
- type 'a result_exn = 'a Wrapped.result_exn
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- val elevate : 'a Wrapped.m -> 'a m
- val throw : err -> 'a m
- val catch : 'a m -> (err -> 'a m) -> 'a m
- end
- (* ErrorT transformer when wrapped monad has plus, zero *)
- module TP : functor (Wrapped : Monad.P) -> sig
- type 'a result = 'a Wrapped.result
- type 'a result_exn = 'a Wrapped.result_exn
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- val elevate : 'a Wrapped.m -> 'a m
- val throw : err -> 'a m
- val catch : 'a m -> (err -> 'a m) -> 'a m
- include Monad.PLUS with type 'a m := 'a m
- end
- module T2 : functor (Wrapped : Monad.S2) -> sig
- type ('x,'a) result = ('x,'a error) Wrapped.result
- type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
- include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
- val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
- val throw : err -> ('x,'a) m
- val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
- end
- module TP2 : functor (Wrapped : Monad.P2) -> sig
type ('x,'a) result = ('x,'a) Wrapped.result
type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
- include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
val throw : err -> ('x,'a) m
val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
- include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
end
end = struct
type err = Err.err
type 'a error = Error of err | Success of 'a
module Base = struct
- type 'a m = 'a error
- type 'a result = 'a error
- type 'a result_exn = 'a
+ type ('x,'a) m = 'a error
+ type ('x,'a) result = 'a error
+ type ('x,'a) result_exn = 'a
let unit a = Success a
let bind u f = match u with
| Success a -> f a
let run_exn u = match u with
| Success a -> a
| Error e -> raise (Err.Exc e)
- (*
- let zero () = Error Err.zero
- let plus u v = match (u, v) with
- | Success _, _ -> u
- (* to satisfy (Catch) laws, plus u zero = u, even if u = Error _
- * otherwise, plus (Error _) v = v *)
- | Error _, _ when v = zero -> u
- (* combine errors *)
- | Error e1, Error e2 when u <> zero -> Error (Err.plus e1 e2)
- | Error _, _ -> v
- *)
+ let zero () = Util.undef
+ (* satisfies Catch *)
+ let plus u v = match u with
+ | Success _ -> u
+ | Error _ -> if v == Util.undef then u else v
end
include Monad.Make(Base)
(* include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m) *)
| Success _ -> u
| Error e -> handler e
module T(Wrapped : Monad.S) = struct
- module Trans = struct
- module Wrapped = Wrapped
- type 'a m = 'a error Wrapped.m
- type 'a result = 'a error Wrapped.result
- type 'a result_exn = 'a Wrapped.result_exn
- let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
- let bind u f = Wrapped.bind u (fun t -> match t with
- | Success a -> f a
- | Error e -> Wrapped.unit (Error e))
- let run u = Wrapped.run u
- let run_exn u =
- let w = Wrapped.bind u (fun t -> match t with
- | Success a -> Wrapped.unit a
- (* | _ -> Wrapped.fail () *)
- | Error e -> raise (Err.Exc e))
- in Wrapped.run_exn w
- end
- include Monad.MakeT(Trans)
- let throw e = Wrapped.unit (Error e)
- let catch u handler = Wrapped.bind u (fun t -> match t with
- | Success _ -> Wrapped.unit t
- | Error e -> handler e)
- end
- module TP(Wrapped : Monad.P) = struct
- (* code repetition, ugh *)
- module TransP = struct
- include Monad.MakeT(struct
- module Wrapped = Wrapped
- type 'a m = 'a error Wrapped.m
- type 'a result = 'a Wrapped.result
- type 'a result_exn = 'a Wrapped.result_exn
- let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
- let bind u f = Wrapped.bind u (fun t -> match t with
- | Success a -> f a
- | Error e -> Wrapped.unit (Error e))
- let run u =
- let w = Wrapped.bind u (fun t -> match t with
- | Success a -> Wrapped.unit a
- | Error e -> Wrapped.zero ())
- in Wrapped.run w
- let run_exn u =
- let w = Wrapped.bind u (fun t -> match t with
- | Success a -> Wrapped.unit a
- (* | _ -> Wrapped.fail () *)
- | Error e -> raise (Err.Exc e))
- in Wrapped.run_exn w
- end)
- let throw e = Wrapped.unit (Error e)
- let catch u handler = Wrapped.bind u (fun t -> match t with
- | Success _ -> Wrapped.unit t
- | Error e -> handler e)
- let plus u v = Wrapped.plus u v
- let zero () = elevate (Wrapped.zero ())
- end
- include TransP
- include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
- end
- module T2(Wrapped : Monad.S2) = struct
- module Trans = struct
+ include Monad.MakeT(struct
module Wrapped = Wrapped
type ('x,'a) m = ('x,'a error) Wrapped.m
- type ('x,'a) result = ('x,'a error) Wrapped.result
+ type ('x,'a) result = ('x,'a) Wrapped.result
type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
- (* code repetition, ugh *)
let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
let bind u f = Wrapped.bind u (fun t -> match t with
| Success a -> f a
| Error e -> Wrapped.unit (Error e))
- let run u = Wrapped.run u
+ let run u =
+ let w = Wrapped.bind u (fun t -> match t with
+ | Success a -> Wrapped.unit a
+ | Error e -> Wrapped.zero ()
+ ) in Wrapped.run w
let run_exn u =
let w = Wrapped.bind u (fun t -> match t with
| Success a -> Wrapped.unit a
| Error e -> raise (Err.Exc e))
in Wrapped.run_exn w
- end
- include Monad.MakeT2(Trans)
+ let plus u v = Wrapped.plus u v
+ let zero () = Wrapped.zero () (* elevate (Wrapped.zero ()) *)
+ end)
let throw e = Wrapped.unit (Error e)
let catch u handler = Wrapped.bind u (fun t -> match t with
| Success _ -> Wrapped.unit t
| Error e -> handler e)
end
- module TP2(Wrapped : Monad.P2) = struct
- (* code repetition, ugh *)
- module TransP = struct
- include Monad.MakeT2(struct
- module Wrapped = Wrapped
- type ('x,'a) m = ('x,'a error) Wrapped.m
- type ('x,'a) result = ('x,'a) Wrapped.result
- type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
- let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Success a))
- let bind u f = Wrapped.bind u (fun t -> match t with
- | Success a -> f a
- | Error e -> Wrapped.unit (Error e))
- let run u =
- let w = Wrapped.bind u (fun t -> match t with
- | Success a -> Wrapped.unit a
- | Error e -> Wrapped.zero ())
- in Wrapped.run w
- let run_exn u =
- let w = Wrapped.bind u (fun t -> match t with
- | Success a -> Wrapped.unit a
- (* | _ -> Wrapped.fail () *)
- | Error e -> raise (Err.Exc e))
- in Wrapped.run_exn w
- end)
- let throw e = Wrapped.unit (Error e)
- let catch u handler = Wrapped.bind u (fun t -> match t with
- | Success _ -> Wrapped.unit t
- | Error e -> handler e)
- let plus u v = Wrapped.plus u v
- let zero () = elevate (Wrapped.zero ())
- end
- include TransP
- include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
- end
end
(* pre-define common instance of Error_monad *)
*)
end)
-(*
-# EL.(run( plus (throw "bye") (unit 20) >>= fun i -> unit(i+10)));;
-- : int EL.result = [Failure.Error "bye"; Failure.Success 30]
-# LE.(run( plus (elevate (Failure.throw "bye")) (unit 20) >>= fun i -> unit(i+10)));;
-- : int LE.result = Failure.Error "bye"
-# EL.(run_exn( plus (throw "bye") (unit 20) >>= fun i -> unit(i+10)));;
-Exception: Failure "bye".
-# LE.(run_exn( plus (elevate (Failure.throw "bye")) (unit 20) >>= fun i -> unit(i+10)));;
-Exception: Failure "bye".
-
-# ES.(run( elevate (S.puts succ) >> throw "bye" >> elevate S.get >>= fun i -> unit(i+10) )) 0;;
-- : int Failure.error * S.store = (Failure.Error "bye", 1)
-# SE.(run( puts succ >> elevate (Failure.throw "bye") >> get >>= fun i -> unit(i+10) )) 0;;
-- : (int * S.store) Failure.result = Failure.Error "bye"
-# ES.(run_exn( elevate (S.puts succ) >> throw "bye" >> elevate S.get >>= fun i -> unit(i+10) )) 0;;
-Exception: Failure "bye".
-# SE.(run_exn( puts succ >> elevate (Failure.throw "bye") >> get >>= fun i -> unit(i+10) )) 0;;
-Exception: Failure "bye".
- *)
-
(* must be parameterized on (struct type env = ... end) *)
module Reader_monad(Env : sig type env end) : sig
(* declare additional operations, while still hiding implementation of type m *)
type env = Env.env
- type 'a result = env -> 'a
- type 'a result_exn = env -> 'a
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- val ask : env m
- val asks : (env -> 'a) -> 'a m
- val local : (env -> env) -> 'a m -> 'a m
+ type ('x,'a) result = env -> 'a
+ type ('x,'a) result_exn = env -> 'a
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ val ask : ('x,env) m
+ val asks : (env -> 'a) -> ('x,'a) m
+ (* lookup i == `fun e -> e i` would assume env is a functional type *)
+ val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
(* ReaderT transformer *)
module T : functor (Wrapped : Monad.S) -> sig
- type 'a result = env -> 'a Wrapped.result
- type 'a result_exn = env -> 'a Wrapped.result_exn
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- val elevate : 'a Wrapped.m -> 'a m
- val ask : env m
- val asks : (env -> 'a) -> 'a m
- val local : (env -> env) -> 'a m -> 'a m
- end
- (* ReaderT transformer when wrapped monad has plus, zero *)
- module TP : functor (Wrapped : Monad.P) -> sig
- include module type of T(Wrapped)
- include Monad.PLUS with type 'a m := 'a m
- end
- module T2 : functor (Wrapped : Monad.S2) -> sig
type ('x,'a) result = env -> ('x,'a) Wrapped.result
type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
- include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
val ask : ('x,env) m
val asks : (env -> 'a) -> ('x,'a) m
val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
end
- module TP2 : functor (Wrapped : Monad.P2) -> sig
- include module type of T2(Wrapped)
- include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
- end
end = struct
type env = Env.env
module Base = struct
- type 'a m = env -> 'a
- type 'a result = env -> 'a
- type 'a result_exn = env -> 'a
+ type ('x,'a) m = env -> 'a
+ type ('x,'a) result = env -> 'a
+ type ('x,'a) result_exn = env -> 'a
let unit a = fun e -> a
let bind u f = fun e -> let a = u e in let u' = f a in u' e
let run u = fun e -> u e
let run_exn = run
+ let zero () = Util.undef
+ let plus u v = u
end
include Monad.Make(Base)
let ask = fun e -> e
let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
let local modifier u = fun e -> u (modifier e)
module T(Wrapped : Monad.S) = struct
- module Trans = struct
- module Wrapped = Wrapped
- type 'a m = env -> 'a Wrapped.m
- type 'a result = env -> 'a Wrapped.result
- type 'a result_exn = env -> 'a Wrapped.result_exn
- let elevate w = fun e -> w
- let bind u f = fun e -> Wrapped.bind (u e) (fun v -> f v e)
- let run u = fun e -> Wrapped.run (u e)
- let run_exn u = fun e -> Wrapped.run_exn (u e)
- end
- include Monad.MakeT(Trans)
- let ask = fun e -> Wrapped.unit e
- let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
- let local modifier u = fun e -> u (modifier e)
- end
- module TP(Wrapped : Monad.P) = struct
- module TransP = struct
- include T(Wrapped)
- let plus u v = fun s -> Wrapped.plus (u s) (v s)
- let zero () = elevate (Wrapped.zero ())
- let asks selector = ask >>= (fun e ->
- try unit (selector e)
- with Not_found -> fun e -> Wrapped.zero ())
- end
- include TransP
- include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
- end
- module T2(Wrapped : Monad.S2) = struct
- module Trans = struct
+ module BaseT = struct
module Wrapped = Wrapped
type ('x,'a) m = env -> ('x,'a) Wrapped.m
type ('x,'a) result = env -> ('x,'a) Wrapped.result
type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
- (* code repetition, ugh *)
let elevate w = fun e -> w
- let bind u f = fun e -> Wrapped.bind (u e) (fun v -> f v e)
+ let bind u f = fun e -> Wrapped.bind (u e) (fun a -> f a e)
let run u = fun e -> Wrapped.run (u e)
let run_exn u = fun e -> Wrapped.run_exn (u e)
+ (* satisfies Distrib *)
+ let plus u v = fun e -> Wrapped.plus (u e) (v e)
+ let zero () = fun e -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
end
- include Monad.MakeT2(Trans)
- let ask = fun e -> Wrapped.unit e
- let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
+ include Monad.MakeT(BaseT)
+ let ask = Wrapped.unit
let local modifier u = fun e -> u (modifier e)
- end
- module TP2(Wrapped : Monad.P2) = struct
- module TransP = struct
- include T2(Wrapped)
- (* code repetition, ugh *)
- let plus u v = fun s -> Wrapped.plus (u s) (v s)
- let zero () = elevate (Wrapped.zero ())
- let asks selector = ask >>= (fun e ->
- try unit (selector e)
- with Not_found -> fun e -> Wrapped.zero ())
- end
- include TransP
- include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
+ let asks selector = ask >>= (fun e ->
+ try unit (selector e)
+ with Not_found -> fun e -> Wrapped.zero ())
end
end
module State_monad(Store : sig type store end) : sig
(* declare additional operations, while still hiding implementation of type m *)
type store = Store.store
- type 'a result = store -> 'a * store
- type 'a result_exn = store -> 'a
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- val get : store m
- val gets : (store -> 'a) -> 'a m
- val put : store -> unit m
- val puts : (store -> store) -> unit m
+ type ('x,'a) result = store -> 'a * store
+ type ('x,'a) result_exn = store -> 'a
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ val get : ('x,store) m
+ val gets : (store -> 'a) -> ('x,'a) m
+ val put : store -> ('x,unit) m
+ val puts : (store -> store) -> ('x,unit) m
(* StateT transformer *)
module T : functor (Wrapped : Monad.S) -> sig
- type 'a result = store -> ('a * store) Wrapped.result
- type 'a result_exn = store -> 'a Wrapped.result_exn
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- val elevate : 'a Wrapped.m -> 'a m
- val get : store m
- val gets : (store -> 'a) -> 'a m
- val put : store -> unit m
- val puts : (store -> store) -> unit m
- end
- (* StateT transformer when wrapped monad has plus, zero *)
- module TP : functor (Wrapped : Monad.P) -> sig
- include module type of T(Wrapped)
- include Monad.PLUS with type 'a m := 'a m
- end
- module T2 : functor (Wrapped : Monad.S2) -> sig
type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
- include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
val get : ('x,store) m
val gets : (store -> 'a) -> ('x,'a) m
val put : store -> ('x,unit) m
val puts : (store -> store) -> ('x,unit) m
end
- module TP2 : functor (Wrapped : Monad.P2) -> sig
- include module type of T2(Wrapped)
- include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
- end
end = struct
type store = Store.store
module Base = struct
- type 'a m = store -> 'a * store
- type 'a result = store -> 'a * store
- type 'a result_exn = store -> 'a
+ type ('x,'a) m = store -> 'a * store
+ type ('x,'a) result = store -> 'a * store
+ type ('x,'a) result_exn = store -> 'a
let unit a = fun s -> (a, s)
let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
let run u = fun s -> (u s)
let run_exn u = fun s -> fst (u s)
+ let zero () = Util.undef
+ let plus u v = u
end
include Monad.Make(Base)
let get = fun s -> (s, s)
let put s = fun _ -> ((), s)
let puts modifier = fun s -> ((), modifier s)
module T(Wrapped : Monad.S) = struct
- module Trans = struct
- module Wrapped = Wrapped
- type 'a m = store -> ('a * store) Wrapped.m
- type 'a result = store -> ('a * store) Wrapped.result
- type 'a result_exn = store -> 'a Wrapped.result_exn
- let elevate w = fun s ->
- Wrapped.bind w (fun a -> Wrapped.unit (a, s))
- let bind u f = fun s ->
- Wrapped.bind (u s) (fun (a, s') -> f a s')
- let run u = fun s -> Wrapped.run (u s)
- let run_exn u = fun s ->
- let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
- in Wrapped.run_exn w
- end
- include Monad.MakeT(Trans)
- let get = fun s -> Wrapped.unit (s, s)
- let gets viewer = fun s -> Wrapped.unit (viewer s, s) (* may fail *)
- let put s = fun _ -> Wrapped.unit ((), s)
- let puts modifier = fun s -> Wrapped.unit ((), modifier s)
- end
- module TP(Wrapped : Monad.P) = struct
- module TransP = struct
- include T(Wrapped)
- let plus u v = fun s -> Wrapped.plus (u s) (v s)
- let zero () = elevate (Wrapped.zero ())
- end
- let gets viewer = fun s ->
- try Wrapped.unit (viewer s, s)
- with Not_found -> Wrapped.zero ()
- include TransP
- include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
- end
- module T2(Wrapped : Monad.S2) = struct
- module Trans = struct
+ module BaseT = struct
module Wrapped = Wrapped
type ('x,'a) m = store -> ('x,'a * store) Wrapped.m
type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
- (* code repetition, ugh *)
let elevate w = fun s ->
Wrapped.bind w (fun a -> Wrapped.unit (a, s))
let bind u f = fun s ->
let run_exn u = fun s ->
let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
in Wrapped.run_exn w
- end
- include Monad.MakeT2(Trans)
- let get = fun s -> Wrapped.unit (s, s)
- let gets viewer = fun s -> Wrapped.unit (viewer s, s) (* may fail *)
- let put s = fun _ -> Wrapped.unit ((), s)
- let puts modifier = fun s -> Wrapped.unit ((), modifier s)
- end
- module TP2(Wrapped : Monad.P2) = struct
- module TransP = struct
- include T2(Wrapped)
- (* code repetition, ugh *)
+ (* satisfies Distrib *)
let plus u v = fun s -> Wrapped.plus (u s) (v s)
- let zero () = elevate (Wrapped.zero ())
+ let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
end
+ include Monad.MakeT(BaseT)
+ let get = fun s -> Wrapped.unit (s, s)
let gets viewer = fun s ->
try Wrapped.unit (viewer s, s)
with Not_found -> Wrapped.zero ()
- include TransP
- include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
+ let put s = fun _ -> Wrapped.unit ((), s)
+ let puts modifier = fun s -> Wrapped.unit ((), modifier s)
end
end
+
(* State monad with different interface (structured store) *)
module Ref_monad(V : sig
type value
end) : sig
type ref
type value = V.value
- type 'a result = 'a
- type 'a result_exn = 'a
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- val newref : value -> ref m
- val deref : ref -> value m
- val change : ref -> value -> unit m
+ type ('x,'a) result = 'a
+ type ('x,'a) result_exn = 'a
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ val newref : value -> ('x,ref) m
+ val deref : ref -> ('x,value) m
+ val change : ref -> value -> ('x,unit) m
(* RefT transformer *)
module T : functor (Wrapped : Monad.S) -> sig
- type 'a result = 'a Wrapped.result
- type 'a result_exn = 'a Wrapped.result_exn
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- val elevate : 'a Wrapped.m -> 'a m
- val newref : value -> ref m
- val deref : ref -> value m
- val change : ref -> value -> unit m
- end
- (* RefT transformer when wrapped monad has plus, zero *)
- module TP : functor (Wrapped : Monad.P) -> sig
- include module type of T(Wrapped)
- include Monad.PLUS with type 'a m := 'a m
- end
- module T2 : functor (Wrapped : Monad.S2) -> sig
type ('x,'a) result = ('x,'a) Wrapped.result
type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
- include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
val newref : value -> ('x,ref) m
val deref : ref -> ('x,value) m
val change : ref -> value -> ('x,unit) m
end
- module TP2 : functor (Wrapped : Monad.P2) -> sig
- include module type of T2(Wrapped)
- include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
- end
end = struct
type ref = int
type value = V.value
let write (key : ref) (value : value) (d : dict) =
{ next = d.next; tree = D.add key value d.tree }
module Base = struct
- type 'a m = dict -> 'a * dict
- type 'a result = 'a
- type 'a result_exn = 'a
+ type ('x,'a) m = dict -> 'a * dict
+ type ('x,'a) result = 'a
+ type ('x,'a) result_exn = 'a
let unit a = fun s -> (a, s)
let bind u f = fun s -> let (a, s') = u s in let u' = f a in u' s'
let run u = fst (u empty)
let run_exn = run
+ let zero () = Util.undef
+ let plus u v = u
end
include Monad.Make(Base)
let newref value = fun s -> alloc value s
let deref key = fun s -> (read key s, s) (* shouldn't fail because key will have an abstract type, and we never garbage collect *)
let change key value = fun s -> ((), write key value s) (* shouldn't allocate because key will have an abstract type *)
module T(Wrapped : Monad.S) = struct
- module Trans = struct
- module Wrapped = Wrapped
- type 'a m = dict -> ('a * dict) Wrapped.m
- type 'a result = 'a Wrapped.result
- type 'a result_exn = 'a Wrapped.result_exn
- let elevate w = fun s ->
- Wrapped.bind w (fun a -> Wrapped.unit (a, s))
- let bind u f = fun s ->
- Wrapped.bind (u s) (fun (a, s') -> f a s')
- let run u =
- let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
- in Wrapped.run w
- let run_exn u =
- let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
- in Wrapped.run_exn w
- end
- include Monad.MakeT(Trans)
- let newref value = fun s -> Wrapped.unit (alloc value s)
- let deref key = fun s -> Wrapped.unit (read key s, s)
- let change key value = fun s -> Wrapped.unit ((), write key value s)
- end
- module TP(Wrapped : Monad.P) = struct
- module TransP = struct
- include T(Wrapped)
- let plus u v = fun s -> Wrapped.plus (u s) (v s)
- let zero () = elevate (Wrapped.zero ())
- end
- include TransP
- include (Monad.MakeDistrib(TransP) : Monad.PLUS with type 'a m := 'a m)
- end
- module T2(Wrapped : Monad.S2) = struct
- module Trans = struct
+ module BaseT = struct
module Wrapped = Wrapped
type ('x,'a) m = dict -> ('x,'a * dict) Wrapped.m
type ('x,'a) result = ('x,'a) Wrapped.result
type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
- (* code repetition, ugh *)
let elevate w = fun s ->
Wrapped.bind w (fun a -> Wrapped.unit (a, s))
let bind u f = fun s ->
let run_exn u =
let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
in Wrapped.run_exn w
+ (* satisfies Distrib *)
+ let plus u v = fun s -> Wrapped.plus (u s) (v s)
+ let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
end
- include Monad.MakeT2(Trans)
+ include Monad.MakeT(BaseT)
let newref value = fun s -> Wrapped.unit (alloc value s)
let deref key = fun s -> Wrapped.unit (read key s, s)
let change key value = fun s -> Wrapped.unit ((), write key value s)
end
- module TP2(Wrapped : Monad.P2) = struct
- module TransP = struct
- include T2(Wrapped)
- (* code repetition, ugh *)
- let plus u v = fun s -> Wrapped.plus (u s) (v s)
- let zero () = elevate (Wrapped.zero ())
- end
- include TransP
- include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
- end
end
end) : sig
(* declare additional operations, while still hiding implementation of type m *)
type log = Log.log
- type 'a result = 'a * log
- type 'a result_exn = 'a * log
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- val tell : log -> unit m
- val listen : 'a m -> ('a * log) m
- val listens : (log -> 'b) -> 'a m -> ('a * 'b) m
- (* val pass : ('a * (log -> log)) m -> 'a m *)
- val censor : (log -> log) -> 'a m -> 'a m
+ type ('x,'a) result = 'a * log
+ type ('x,'a) result_exn = 'a * log
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ val tell : log -> ('x,unit) m
+ val listen : ('x,'a) m -> ('x,'a * log) m
+ val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
+ (* val pass : ('x,'a * (log -> log)) m -> ('x,'a) m *)
+ val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
+ (* WriterT transformer *)
+ module T : functor (Wrapped : Monad.S) -> sig
+ type ('x,'a) result = ('x,'a * log) Wrapped.result
+ type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
+ val tell : log -> ('x,unit) m
+ val listen : ('x,'a) m -> ('x,'a * log) m
+ val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
+ val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
+ end
end = struct
type log = Log.log
module Base = struct
- type 'a m = 'a * log
- type 'a result = 'a * log
- type 'a result_exn = 'a * log
+ type ('x,'a) m = 'a * log
+ type ('x,'a) result = 'a * log
+ type ('x,'a) result_exn = 'a * log
let unit a = (a, Log.zero)
- let bind (a, w) f = let (a', w') = f a in (a', Log.plus w w')
+ let bind (a, w) f = let (b, w') = f a in (b, Log.plus w w')
let run u = u
let run_exn = run
+ let zero () = Util.undef
+ let plus u v = u
end
include Monad.Make(Base)
let tell entries = ((), entries) (* add entries to log *)
let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w) (* filter listen through selector *)
let pass ((a, f), w) = (a, f w) (* usually use censor helper *)
let censor f u = pass (u >>= fun a -> unit (a, f))
+ module T(Wrapped : Monad.S) = struct
+ module BaseT = struct
+ module Wrapped = Wrapped
+ type ('x,'a) m = ('x,'a * log) Wrapped.m
+ type ('x,'a) result = ('x,'a * log) Wrapped.result
+ type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
+ let elevate w =
+ Wrapped.bind w (fun a -> Wrapped.unit (a, Log.zero))
+ let bind u f =
+ Wrapped.bind u (fun (a, w) ->
+ Wrapped.bind (f a) (fun (b, w') ->
+ Wrapped.unit (b, Log.plus w w')))
+ let zero () = elevate (Wrapped.zero ())
+ let plus u v = Wrapped.plus u v
+ let run u = Wrapped.run u
+ let run_exn u = Wrapped.run_exn u
+ end
+ include Monad.MakeT(BaseT)
+ let tell entries = Wrapped.unit ((), entries)
+ let listen u = Wrapped.bind u (fun (a, w) -> Wrapped.unit ((a, w), w))
+ let pass u = Wrapped.bind u (fun ((a, f), w) -> Wrapped.unit (a, f w))
+ (* rest are derived in same way as before *)
+ let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w)
+ let censor f u = pass (u >>= fun a -> unit (a, f))
+ end
end
(* pre-define simple Writer *)
end
+(* TODO needs a T *)
module IO_monad : sig
(* declare additional operation, while still hiding implementation of type m *)
- type 'a result = 'a
- type 'a result_exn = 'a
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- val printf : ('a, unit, string, unit m) format4 -> 'a
- val print_string : string -> unit m
- val print_int : int -> unit m
- val print_hex : int -> unit m
- val print_bool : bool -> unit m
+ type ('x,'a) result = 'a
+ type ('x,'a) result_exn = 'a
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ val printf : ('a, unit, string, ('x,unit) m) format4 -> 'a
+ val print_string : string -> ('x,unit) m
+ val print_int : int -> ('x,unit) m
+ val print_hex : int -> ('x,unit) m
+ val print_bool : bool -> ('x,unit) m
end = struct
module Base = struct
- type 'a m = { run : unit -> unit; value : 'a }
- type 'a result = 'a
- type 'a result_exn = 'a
+ type ('x,'a) m = { run : unit -> unit; value : 'a }
+ type ('x,'a) result = 'a
+ type ('x,'a) result_exn = 'a
let unit a = { run = (fun () -> ()); value = a }
- let bind (a : 'a m) (f: 'a -> 'b m) : 'b m =
+ let bind (a : ('x,'a) m) (f: 'a -> ('x,'b) m) : ('x,'b) m =
let fres = f a.value in
{ run = (fun () -> a.run (); fres.run ()); value = fres.value }
let run a = let () = a.run () in a.value
let run_exn = run
+ let zero () = Util.undef
+ let plus u v = u
end
include Monad.Make(Base)
let printf fmt =
let print_bool b = { Base.run = (fun () -> Printf.printf "%B\n" b); value = () }
end
-(*
-module Continuation_monad : sig
- (* expose only the implementation of type `('r,'a) result` *)
- type 'a m
- type 'a result = 'a m
- type 'a result_exn = 'a m
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn and type 'a m := 'a m
- (* val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m *)
- (* misses that the answer types of all the cont's must be the same *)
- val callcc : (('a -> 'b m) -> 'a m) -> 'a m
- (* val reset : ('a,'a) m -> ('r,'a) m *)
- val reset : 'a m -> 'a m
- (* val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m *)
- (* misses that the answer types of second and third continuations must be b *)
- val shift : (('a -> 'b m) -> 'b m) -> 'a m
- (* overwrite the run declaration in S, because I can't declare 'a result =
- * this polymorphic type (complains that 'r is unbound *)
- val runk : 'a m -> ('a -> 'r) -> 'r
- val run0 : 'a m -> 'a
-end = struct
- let id = fun i -> i
- module Base = struct
- (* 'r is result type of whole computation *)
- type 'a m = { cont : 'r. ('a -> 'r) -> 'r }
- type 'a result = 'a m
- type 'a result_exn = 'a m
- let unit a =
- let cont : 'r. ('a -> 'r) -> 'r =
- fun k -> k a
- in { cont }
- let bind u f =
- let cont : 'r. ('a -> 'r) -> 'r =
- fun k -> u.cont (fun a -> (f a).cont k)
- in { cont }
- let run (u : 'a m) : 'a result = u
- let run_exn (u : 'a m) : 'a result_exn = u
- let callcc f =
- let cont : 'r. ('a -> 'r) -> 'r =
- (* Can't figure out how to make the type polymorphic enough
- * to satisfy the OCaml type-checker (it's ('a -> 'r) -> 'r
- * instead of 'r. ('a -> 'r) -> 'r); so we have to fudge
- * with Obj.magic... which tells OCaml's type checker to
- * relax, the supplied value has whatever type the context
- * needs it to have. *)
- fun k ->
- let usek a = { cont = Obj.magic (fun _ -> k a) }
- in (f usek).cont k
- in { cont }
- let reset u = unit (u.cont id)
- let shift (f : ('a -> 'b m) -> 'b m) : 'a m =
- let cont = fun k ->
- (f (fun a -> unit (k a))).cont id
- in { cont = Obj.magic cont }
- let runk u k = (u.cont : ('a -> 'r) -> 'r) k
- let run0 u = runk u id
- end
- include Monad.Make(Base)
- let callcc = Base.callcc
- let reset = Base.reset
- let shift = Base.shift
- let runk = Base.runk
- let run0 = Base.run0
-end
- *)
-(* This two-type parameter version works without Obj.magic *)
module Continuation_monad : sig
(* expose only the implementation of type `('r,'a) result` *)
type ('r,'a) m
type ('r,'a) result = ('r,'a) m
type ('r,'a) result_exn = ('a -> 'r) -> 'r
- include Monad.S2 with type ('r,'a) result := ('r,'a) result and type ('r,'a) result_exn := ('r,'a) result_exn and type ('r,'a) m := ('r,'a) m
+ include Monad.S with type ('r,'a) result := ('r,'a) result and type ('r,'a) result_exn := ('r,'a) result_exn and type ('r,'a) m := ('r,'a) m
val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
val reset : ('a,'a) m -> ('r,'a) m
val shift : (('a -> ('q,'r) m) -> ('r,'r) m) -> ('r,'a) m
(* val abort : ('a,'a) m -> ('a,'b) m *)
val abort : 'a -> ('a,'b) m
val run0 : ('a,'a) m -> 'a
+ (* ContinuationT transformer *)
+ module T : functor (Wrapped : Monad.S) -> sig
+ type ('r,'a) m
+ type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
+ type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
+ include Monad.S with type ('r,'a) result := ('r,'a) result and type ('r,'a) result_exn := ('r,'a) result_exn and type ('r,'a) m := ('r,'a) m
+ val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
+ val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
+ (* TODO: reset,shift,abort,run0 *)
+ end
end = struct
let id = fun i -> i
module Base = struct
let bind u f = (fun k -> (u) (fun a -> (f a) k))
let run u k = (u) k
let run_exn = run
+ let zero () = Util.undef
+ let plus u v = u
end
- include Monad.Make2(Base)
+ include Monad.Make(Base)
let callcc f = (fun k ->
let usek a = (fun _ -> k a)
in (f usek) k)
(* let abort a = shift (fun _ -> a) *)
let abort a = shift (fun _ -> unit a)
let run0 (u : ('a,'a) m) = (u) id
+ module T(Wrapped : Monad.S) = struct
+ module BaseT = struct
+ module Wrapped = Wrapped
+ type ('r,'a) m = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.m
+ type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
+ type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
+ let elevate w = fun k -> Wrapped.bind w k
+ let bind u f = fun k -> u (fun a -> f a k)
+ let run u k = Wrapped.run (u k)
+ let run_exn u k = Wrapped.run_exn (u k)
+ let zero () = Util.undef
+ let plus u v = u
+ end
+ include Monad.MakeT(BaseT)
+ let callcc f = (fun k ->
+ let usek a = (fun _ -> k a)
+ in (f usek) k)
+ end
end
*)
-module Leaf_monad : sig
+module Tree_monad : sig
(* We implement the type as `'a tree option` because it has a natural`plus`,
* and the rest of the library expects that `plus` and `zero` will come together. *)
type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
- type 'a result = 'a tree option
- type 'a result_exn = 'a tree
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- include Monad.PLUS with type 'a m := 'a m
- (* LeafT transformer *)
+ type ('x,'a) result = 'a tree option
+ type ('x,'a) result_exn = 'a tree
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+ (* TreeT transformer *)
module T : functor (Wrapped : Monad.S) -> sig
- type 'a result = 'a tree option Wrapped.result
- type 'a result_exn = 'a tree Wrapped.result_exn
- include Monad.S with type 'a result := 'a result and type 'a result_exn := 'a result_exn
- include Monad.PLUS with type 'a m := 'a m
- val elevate : 'a Wrapped.m -> 'a m
- (* note that second argument is an 'a tree?, not the more abstract 'a m *)
- (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
- val distribute : ('a -> 'b Wrapped.m) -> 'a tree option -> 'b m
- end
- module T2 : functor (Wrapped : Monad.S2) -> sig
type ('x,'a) result = ('x,'a tree option) Wrapped.result
type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
- include Monad.S2 with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
- include Monad.PLUS2 with type ('x,'a) m := ('x,'a) m
+ include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
+ (* note that second argument is an 'a tree?, not the more abstract 'a m *)
+ (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
end
end = struct
plus (loop l) (loop r)
) in loop ts
module Base = struct
- type 'a m = 'a tree option
- type 'a result = 'a tree option
- type 'a result_exn = 'a tree
+ type ('x,'a) m = 'a tree option
+ type ('x,'a) result = 'a tree option
+ type ('x,'a) result_exn = 'a tree
let unit a = Some (Leaf a)
let zero () = None
+ (* satisfies Distrib *)
let plus u v = match (u, v) with
| None, _ -> v
| _, None -> u
| Some us -> us
end
include Monad.Make(Base)
- include (Monad.MakeDistrib(Base) : Monad.PLUS with type 'a m := 'a m)
- let base_plus = plus
- let base_lift = lift
module T(Wrapped : Monad.S) = struct
- module Trans = struct
- let zero () = Wrapped.unit None
- let plus u v =
- Wrapped.bind u (fun us ->
- Wrapped.bind v (fun vs ->
- Wrapped.unit (base_plus us vs)))
+ module BaseT = struct
include Monad.MakeT(struct
module Wrapped = Wrapped
- type 'a m = 'a tree option Wrapped.m
- type 'a result = 'a tree option Wrapped.result
- type 'a result_exn = 'a tree Wrapped.result_exn
- let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
- let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
- let run u = Wrapped.run u
- let run_exn u =
- let w = Wrapped.bind u (fun t -> match t with
- | None -> failwith "no values"
- | Some ts -> Wrapped.unit ts)
- in Wrapped.run_exn w
- end)
- end
- include Trans
- include (Monad.MakeDistrib(Trans) : Monad.PLUS with type 'a m := 'a m)
- (* let distribute f t = mapT (fun a -> a) (base_lift (fun a -> elevate (f a)) t) zero plus *)
- let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
- end
- module T2(Wrapped : Monad.S2) = struct
- module Trans = struct
- let zero () = Wrapped.unit None
- let plus u v =
- Wrapped.bind u (fun us ->
- Wrapped.bind v (fun vs ->
- Wrapped.unit (base_plus us vs)))
- include Monad.MakeT2(struct
- module Wrapped = Wrapped
type ('x,'a) m = ('x,'a tree option) Wrapped.m
type ('x,'a) result = ('x,'a tree option) Wrapped.result
type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
- (* code repetition, ugh *)
+ let zero () = Wrapped.unit None
+ let plus u v =
+ Wrapped.bind u (fun us ->
+ Wrapped.bind v (fun vs ->
+ Wrapped.unit (Base.plus us vs)))
let elevate w = Wrapped.bind w (fun a -> Wrapped.unit (Some (Leaf a)))
let bind u f = Wrapped.bind u (fun t -> mapT f t zero plus)
let run u = Wrapped.run u
let run_exn u =
let w = Wrapped.bind u (fun t -> match t with
- | None -> failwith "no values"
- | Some ts -> Wrapped.unit ts)
- in Wrapped.run_exn w
+ | None -> Wrapped.zero ()
+ | Some ts -> Wrapped.unit ts
+ ) in Wrapped.run_exn w
end)
end
- include Trans
- include (Monad.MakeDistrib2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
+ include BaseT
let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
end
end
module L = List_monad;;
module R = Reader_monad(struct type env = int -> int end);;
module S = State_monad(struct type store = int end);;
-module T = Leaf_monad;;
+module T = Tree_monad;;
module LR = L.T(R);;
module LS = L.T(S);;
module TL = T.T(L);;
module TR = T.T(R);;
module TS = T.T(S);;
module C = Continuation_monad
-module TC = T.T2(C);;
+module TC = T.T(C);;
-print_endline "=== test Leaf(...).distribute ==================";;
+print_endline "=== test TreeT(...).distribute ==================";;
let t1 = Some (T.Node (T.Node (T.Leaf 2, T.Leaf 3), T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11))));;
- : S.store list * S.store = ([10; 0; 0; 1; 20], 1)
*)
-print_endline "=== test Leaf(Continuation).distribute ==================";;
+print_endline "=== test TreeT(Continuation).distribute ==================";;
let id : 'z. 'z -> 'z = fun x -> x