From 4d820711650b0ec6e0402d6d4dc46d7de23e6653 Mon Sep 17 00:00:00 2001 From: Jim Pryor Date: Sat, 11 Dec 2010 10:37:59 -0500 Subject: [PATCH] monads.ml: add TP2 to Error, make Error.run less exn-y Signed-off-by: Jim Pryor --- code/monads.ml | 70 ++++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 48 insertions(+), 22 deletions(-) diff --git a/code/monads.ml b/code/monads.ml index 7bb6894c..4db605c8 100644 --- a/code/monads.ml +++ b/code/monads.ml @@ -587,7 +587,7 @@ 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 + 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 *) @@ -595,7 +595,7 @@ end) : sig val catch : 'a m -> (err -> 'a m) -> 'a m (* ErrorT transformer *) module T : functor (Wrapped : Monad.S) -> sig - type 'a result = 'a Wrapped.result + 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 @@ -608,29 +608,32 @@ end) : sig 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 = ('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 + include module type of T2(Wrapped) + 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 @@ -653,19 +656,13 @@ end = struct 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 @@ -692,18 +689,14 @@ end = 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 @@ -716,6 +709,16 @@ end = struct | Success _ -> Wrapped.unit t | Error e -> handler e) end + module TP2(Wrapped : Monad.P2) = struct + module TransP = struct + include T2(Wrapped) + (* code repetition, ugh *) + 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 *) @@ -728,6 +731,27 @@ module Failure = Error_monad(struct *) 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 *) @@ -828,8 +852,8 @@ end = struct 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 -> @@ -957,6 +981,7 @@ end = struct 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 @@ -1090,6 +1115,7 @@ end = struct 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 -- 2.11.0