monads.ml: add TP2 to Error, make Error.run less exn-y

Signed-off-by: Jim Pryor <profjim@jimpryor.net>

diff --git a/code/monads.ml b/code/monads.ml
index 7bb6894..4db605c 100644 (file)
--- 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