- let undefined = Obj.magic ""
+ (* 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 Leaf_monad). *)
+ let undef = Obj.magic (fun () -> raise Undefined)
- (* The only constraints we impose here on how the monadic type
- * is implemented is that it have a single type parameter 'a. *)
+ (* We make all monadic types doubly-parameterized so that they
+ * can layer nicely with Continuation, which needs the second
+ * type parameter. *)
* 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)
* 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
+ * 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
* 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
val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
end
module type S = sig
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 =
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 ())
+ if u == Util.undef then Util.undef
+ else B.bind u (fun a -> try f a with Match_failure _ -> zero ())
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 (>=>) 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
val zero : unit -> ('x,'a) m
val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
end
val zero : unit -> ('x,'a) m
val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
end
include Monad.MakeT(struct
module Wrapped = Wrapped
type ('x,'a) m = ('x,'a option) Wrapped.m
include Monad.MakeT(struct
module Wrapped = Wrapped
type ('x,'a) m = ('x,'a option) Wrapped.m
let zero () = Wrapped.unit None
let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
end)
end
let zero () = Wrapped.unit None
let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
end)
end
let rec select u = match u with
| [] -> zero ()
| x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
let rec select u = match u with
| [] -> zero ()
| x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
) in Wrapped.run_exn w
let zero () = Wrapped.unit []
let plus u v =
Wrapped.bind u (fun us ->
Wrapped.bind v (fun vs ->
) in Wrapped.run_exn w
let zero () = Wrapped.unit []
let plus u v =
Wrapped.bind u (fun us ->
Wrapped.bind v (fun vs ->
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
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
val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
(* ReaderT transformer *)
module T : functor (Wrapped : Monad.S) -> sig
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
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 Wrapped = Wrapped
type ('x,'a) m = env -> ('x,'a) Wrapped.m
type ('x,'a) result = env -> ('x,'a) Wrapped.result
module Wrapped = Wrapped
type ('x,'a) m = env -> ('x,'a) Wrapped.m
type ('x,'a) result = env -> ('x,'a) Wrapped.result
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)
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)
let ask = fun e -> Wrapped.unit e
let local modifier u = fun e -> u (modifier e)
let asks selector = ask >>= (fun e ->
let ask = fun e -> Wrapped.unit e
let local modifier u = fun e -> u (modifier e)
let asks selector = ask >>= (fun e ->
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 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 put s = fun _ -> ((), s)
let puts modifier = fun s -> ((), modifier s)
module T(Wrapped : Monad.S) = struct
let put s = fun _ -> ((), s)
let puts modifier = fun s -> ((), modifier s)
module T(Wrapped : Monad.S) = struct
module Wrapped = Wrapped
type ('x,'a) m = store -> ('x,'a * store) Wrapped.m
type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
module Wrapped = Wrapped
type ('x,'a) m = store -> ('x,'a * store) Wrapped.m
type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
let get = fun s -> Wrapped.unit (s, s)
let gets viewer = fun s ->
try Wrapped.unit (viewer s, s)
let get = fun s -> Wrapped.unit (s, s)
let gets viewer = fun s ->
try Wrapped.unit (viewer s, 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 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 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
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 Wrapped = Wrapped
type ('x,'a) m = dict -> ('x,'a * dict) Wrapped.m
type ('x,'a) result = ('x,'a) Wrapped.result
module Wrapped = Wrapped
type ('x,'a) m = dict -> ('x,'a * dict) Wrapped.m
type ('x,'a) result = ('x,'a) Wrapped.result
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
end
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
end
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 bind (a, w) f = let (a', w') = f a in (a', Log.plus w w')
let run u = u
let run_exn = run
{ run = (fun () -> a.run (); fres.run ()); value = fres.value }
let run a = let () = a.run () in a.value
let run_exn = run
{ run = (fun () -> a.run (); fres.run ()); value = fres.value }
let run a = let () = a.run () in a.value
let run_exn = run
module Continuation_monad : sig
(* expose only the implementation of type `('r,'a) result` *)
type ('r,'a) m
module Continuation_monad : sig
(* expose only the implementation of type `('r,'a) result` *)
type ('r,'a) m
type ('x,'a) result_exn = 'a tree
let unit a = Some (Leaf a)
let zero () = None
type ('x,'a) result_exn = 'a tree
let unit a = Some (Leaf a)
let zero () = None
include Monad.MakeT(struct
module Wrapped = Wrapped
type ('x,'a) m = ('x,'a tree option) Wrapped.m
include Monad.MakeT(struct
module Wrapped = Wrapped
type ('x,'a) m = ('x,'a tree option) Wrapped.m
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
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