From 58bf3ee4a3e5ee6e343787e432602b677a596109 Mon Sep 17 00:00:00 2001 From: Jim Pryor Date: Sat, 11 Dec 2010 13:03:59 -0500 Subject: [PATCH] monads lib: made all monad types doubly param'd; required plus,zero from all monads Signed-off-by: Jim Pryor --- code/monads.ml | 1045 +++++++++++++------------------------------------------- 1 file changed, 237 insertions(+), 808 deletions(-) diff --git a/code/monads.ml b/code/monads.ml index ae0ecc51..0a205f6a 100644 --- a/code/monads.ml +++ b/code/monads.ml @@ -60,6 +60,7 @@ module Util = struct let rec loop n accu = if n == 0 then accu else loop (pred n) (fill :: accu) in loop len [] + let undefined = Obj.magic "" end @@ -73,52 +74,65 @@ module Monad = struct (* * 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 :: TRANS (with Wrapped : S) -> custom sig *) - (* 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 + 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.undefined + * The Make process automatically detects for zero >>= ..., and + * plus zero _, plus _ zero; it also substitutes zero for pattern-match failures. + *) + val zero : unit -> ('x,'a) m + 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.undefined then Util.undefined + else bind u (fun a -> try f a with Match_failure _ -> zero ()) + let plus u v = + if u == Util.undefined then v else if v == Util.undefined then u else plus u v + let run u = + if u == Util.undefined then failwith "no zero" else run u + let run_exn u = + if u == Util.undefined then failwith "no zero" else run_exn u let (>>=) = bind let (>>) u v = u >>= fun _ -> v let lift f u = u >>= fun a -> unit (f a) @@ -165,157 +179,29 @@ module Monad = struct 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 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 : TRANS) = struct + include Make(struct include T let unit a = elevate (Wrapped.unit a) end) @@ -330,18 +216,20 @@ 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.undefined + let plus u v = u end include Monad.Make(Base) end @@ -349,73 +237,39 @@ 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 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 @@ -426,52 +280,41 @@ end = struct | Some a -> Wrapped.unit a | None -> failwith "no value") 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) 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 @@ -483,7 +326,6 @@ end = struct 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 = @@ -501,77 +343,43 @@ end = struct | 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 + | [] -> failwith "no values" + | [a] -> Wrapped.unit a + | many -> failwith "multiple values" + ) 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) + 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 @@ -587,55 +395,27 @@ end) : sig (* 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 @@ -644,6 +424,8 @@ end = struct let run_exn u = match u with | Success a -> a | Error e -> raise (Err.Exc e) + let zero () = Util.undefined + let plus u v = u (* let zero () = Error Err.zero let plus u v = match (u, v) with @@ -663,118 +445,33 @@ end = struct | 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 - | 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 - | 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 () = 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 - | 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 *) @@ -812,50 +509,34 @@ Exception: Failure "bye". 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 + 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.undefined + let plus u v = u end include Monad.Make(Base) let ask = fun e -> e @@ -864,60 +545,22 @@ end = struct 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 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 run u = fun e -> Wrapped.run (u e) let run_exn u = fun e -> Wrapped.run_exn (u e) - end - include Monad.MakeT2(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 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) + include Monad.MakeT(Trans) + let ask = fun e -> Wrapped.unit e + let local modifier u = fun e -> u (modifier e) + let asks selector = ask >>= (fun e -> + try unit (selector e) + with Not_found -> fun e -> Wrapped.zero ()) end end @@ -926,53 +569,36 @@ 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.undefined + let plus u v = u end include Monad.Make(Base) let get = fun s -> (s, s) @@ -982,43 +608,9 @@ end = struct 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 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 -> @@ -1027,25 +619,16 @@ end = struct 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 *) let plus u v = fun s -> Wrapped.plus (u s) (v s) let zero () = elevate (Wrapped.zero ()) end + include Monad.MakeT(Trans) + 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 @@ -1055,40 +638,22 @@ module Ref_monad(V : sig 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 @@ -1102,13 +667,15 @@ end = struct 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.undefined + let plus u v = u end include Monad.Make(Base) let newref value = fun s -> alloc value s @@ -1117,41 +684,9 @@ end = struct 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 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 -> @@ -1162,22 +697,14 @@ end = struct let run_exn u = let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a) in Wrapped.run_exn w + let plus u v = fun s -> Wrapped.plus (u s) (v s) + let zero () = elevate (Wrapped.zero ()) end - include Monad.MakeT2(Trans) + 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 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 @@ -1189,24 +716,26 @@ module Writer_monad(Log : sig 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 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 run u = u let run_exn = run + let zero () = Util.undefined + let plus u v = u end include Monad.Make(Base) let tell entries = ((), entries) (* add entries to log *) @@ -1239,25 +768,27 @@ end 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.undefined + let plus u v = u end include Monad.Make(Base) let printf fmt = @@ -1268,78 +799,13 @@ end = struct 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 @@ -1357,8 +823,10 @@ end = 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.undefined + 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) @@ -1449,27 +917,17 @@ module Leaf_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 + 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 (* LeafT 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 @@ -1484,9 +942,9 @@ 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 let plus u v = match (u, v) with @@ -1504,49 +962,20 @@ end = struct | 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))) 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 @@ -1558,7 +987,7 @@ end = struct end) end include Trans - include (Monad.MakeDistrib2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'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 end @@ -1574,7 +1003,7 @@ 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 ==================";; -- 2.11.0