(* 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
+ 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 catch : 'a m -> (err -> 'a m) -> '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
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
+ type 'a result = 'a error
type 'a result_exn = 'a
let unit a = Success a
let bind u f = match u with
| Success a -> f a
| Error e -> Error e (* input and output may be of different 'a types *)
- (* TODO: should run refrain from failing? *)
- let run u = match u with
+ let run u = u
+ let run_exn u = match u with
| Success a -> a
| Error e -> raise (Err.Exc e)
- let run_exn = run
(*
let zero () = Error Err.zero
let plus u v = match (u, v) with
module Trans = struct
module Wrapped = Wrapped
type 'a m = 'a error Wrapped.m
- type 'a result = 'a Wrapped.result
+ 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))
- (* TODO: should run refrain from failing? *)
- let run 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 w
+ 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
| 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
module Wrapped = Wrapped
type ('x,'a) m = ('x,'a error) Wrapped.m
- type ('x,'a) result = ('x,'a) Wrapped.result
+ type ('x,'a) result = ('x,'a error) 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 =
- let w = Wrapped.bind u (fun t -> match t with
- | Success a -> Wrapped.unit a
- | Error e -> raise (Err.Exc e))
- in Wrapped.run w
+ 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
| 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 *)
*)
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 *)
end
module TP2(Wrapped : Monad.P2) = struct
module TransP = struct
- (* code repetition, ugh *)
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 ->
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
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