X-Git-Url: http://lambda.jimpryor.net/git/gitweb.cgi?p=lambda.git;a=blobdiff_plain;f=code%2Fmonads.ml;h=7bb6894cda77723d028f216f38628a1c012c79ef;hp=a334b0f018df76bda19e644dfeb2cc9b09c6f5e8;hb=77808abfd2b5033980938ba74b82a733e36ed4e4;hpb=341631c0ca1850cc0e2bdaa459fc1bdc771a3175

diff --git a/code/monads.ml b/code/monads.ml
index a334b0f0..7bb6894c 100644
--- a/code/monads.ml
+++ b/code/monads.ml
@@ -70,20 +70,34 @@ end
  *)
 
 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
+   *
+   *)
+
+
 
   (* 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.
-     *)
+    (* 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
-    type 'a result
     val run : 'a m -> 'a result
     (* run_exn tries to provide a more ground-level result, but may fail *)
-    type 'a result_exn
     val run_exn : 'a m -> 'a result_exn
   end
   module type S = sig
@@ -97,7 +111,7 @@ module Monad = struct
     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 : 'a m -> 'b m
+    val forever : (unit -> 'a m) -> 'b m
     val sequence : 'a m list -> 'a list m
     val sequence_ : 'a m list -> unit m
   end
@@ -118,11 +132,12 @@ module Monad = struct
     let lift2 f u v = u >>= fun a -> v >>= fun a' -> unit (f a a')
     (* let lift f u === apply (unit f) u *)
     (* let lift2 f u v = apply (lift f u) v *)
-
     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 rec forever u = u >> forever 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 [])
@@ -184,15 +199,44 @@ module Monad = struct
   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
-    type ('x,'a) result
     val run : ('x,'a) m -> ('x,'a) result
-    type ('x,'a) result_exn
-    val run_exn : ('x,'a) m -> ('x,'a) result
+    val run_exn : ('x,'a) m -> ('x,'a) result_exn
   end
   module type S2 = sig
     include BASE2
@@ -205,11 +249,12 @@ module Monad = struct
     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 : ('x,'a) m -> ('x,'b) 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
@@ -220,7 +265,9 @@ module Monad = struct
     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 rec forever u = u >> forever 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 [])
@@ -228,31 +275,47 @@ module Monad = struct
       Util.fold_right (>>) ms (unit ())
   end
 
-  (* Signatures for MonadT *)
-  module type W = sig
-    include S
+  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 WP = sig
-    include W
-    val zero : unit -> 'a m
-    val plus : 'a m -> 'a m -> 'a m
+  module type PLUS2 = sig
+    type ('x,'a) m
+    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 type TRANS = sig
-    type 'a m
-    val bind : 'a m -> ('a -> 'b m) -> 'b m
-    module Wrapped : W
-    type 'a result
-    val run : 'a m -> 'a result
-    type 'a result_exn
-    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)
-     *)
+  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 MakeT(T : TRANS) = struct
-    include Make(struct
+  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
         include T
         let unit a = elevate (Wrapped.unit a)
     end)
@@ -273,11 +336,11 @@ module Identity_monad : sig
 end = struct
   module Base = struct
     type 'a m = 'a
+    type 'a result = 'a
+    type 'a result_exn = 'a
     let unit a = a
     let bind a f = f a
-    type 'a result = 'a
     let run a = a
-    type 'a result_exn = 'a
     let run_exn a = a
   end
   include Monad.Make(Base)
@@ -291,21 +354,28 @@ module Maybe_monad : sig
   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
   (* MaybeT transformer *)
-  module T : functor (Wrapped : Monad.W) -> sig
+  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
+    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
-   type 'a result = 'a option
    let run u = u
-   type 'a result_exn = 'a
    let run_exn u = match u with
      | Some a -> a
      | None -> failwith "no value"
@@ -314,18 +384,18 @@ end = struct
   end
   include Monad.Make(Base)
   include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m)
-  module T(Wrapped : Monad.W) = struct
+  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)
-        type 'a result = 'a option Wrapped.result
         let run u = Wrapped.run u
-        type 'a result_exn = 'a Wrapped.result_exn
         let run_exn u =
           let w = Wrapped.bind u (fun t -> match t with
             | Some a -> Wrapped.unit a
@@ -338,6 +408,31 @@ end = struct
     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
+          | 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.MakeCatch2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
+  end
 end
 
 
@@ -350,7 +445,7 @@ module List_monad : sig
   val permute : 'a m -> 'a m m
   val select : 'a m -> ('a * 'a m) m
   (* ListT transformer *)
-  module T : functor (Wrapped : Monad.W) -> sig
+  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
@@ -364,14 +459,22 @@ module List_monad : sig
     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
    let unit a = [a]
    let bind u f = Util.concat_map f u
-   type 'a result = 'a list
    let run u = u
-   type 'a result_exn = 'a
    let run_exn u = match u with
      | [] -> failwith "no values"
      | [a] -> a
@@ -397,13 +500,8 @@ end = struct
     | [] -> zero ()
     | x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
   let base_plus = plus
-  module T(Wrapped : Monad.W) = struct
+  module T(Wrapped : Monad.S) = struct
     module Trans = struct
-      let zero () = Wrapped.unit []
-      let plus u v =
-        Wrapped.bind u (fun us ->
-        Wrapped.bind v (fun vs ->
-        Wrapped.unit (base_plus us vs)))
       (* Wrapped.sequence ms  ===  
            let plus1 u v =
              Wrapped.bind u (fun x ->
@@ -415,14 +513,14 @@ end = struct
       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)))
-        type 'a result = 'a list Wrapped.result
         let run u = Wrapped.run u
-        type 'a result_exn = 'a Wrapped.result_exn
         let run_exn u =
           let w = Wrapped.bind u (fun ts -> match ts with
             | [] -> failwith "no values"
@@ -430,6 +528,11 @@ end = struct
             | 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.MakeDistrib(Trans) : Monad.PLUS with type 'a m := 'a m)
@@ -438,6 +541,37 @@ end = struct
     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
 
 
@@ -460,7 +594,7 @@ end) : sig
   val throw : err -> 'a m
   val catch : 'a m -> (err -> 'a m) -> 'a m
   (* ErrorT transformer *)
-  module T : functor (Wrapped : Monad.W) -> sig
+  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
@@ -468,21 +602,34 @@ end) : sig
     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
+    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
+    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
 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_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 *)
-    type 'a result = 'a
     (* TODO: should run refrain from failing? *)
     let run u = match u with
       | Success a -> a
       | Error e -> raise (Err.Exc e)
-    type 'a result_exn = 'a
     let run_exn = run
     (*
     let zero () = Error Err.zero
@@ -502,15 +649,16 @@ end = struct
   let catch u handler = match u with
     | Success _ -> u
     | Error e -> handler e
-  module T(Wrapped : Monad.W) = struct
+  module T(Wrapped : Monad.S) = struct
     module Trans = struct
       module Wrapped = Wrapped
-      type 'a m = 'a Base.m Wrapped.m
+      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))
-      type 'a result = 'a Wrapped.result
       (* TODO: should run refrain from failing? *)
       let run u =
         let w = Wrapped.bind u (fun t -> match t with
@@ -518,7 +666,6 @@ end = struct
           (* | _ -> Wrapped.fail () *)
           | Error e -> raise (Err.Exc e))
         in Wrapped.run w
-      type 'a result_exn = 'a Wrapped.result_exn
       let run_exn u =
         let w = Wrapped.bind u (fun t -> match t with
           | Success a -> Wrapped.unit a
@@ -532,6 +679,43 @@ end = struct
       | Success _ -> Wrapped.unit t
       | Error e -> handler e)
   end
+  module TP(Wrapped : Monad.P) = struct
+    module TransP = struct
+      include T(Wrapped)
+      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_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_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 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
 end
 
 (* pre-define common instance of Error_monad *)
@@ -555,7 +739,7 @@ module Reader_monad(Env : sig type env end) : sig
   val asks : (env -> 'a) -> 'a m
   val local : (env -> env) -> 'a m -> 'a m
   (* ReaderT transformer *)
-  module T : functor (Wrapped : Monad.W) -> sig
+  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
@@ -565,34 +749,47 @@ module Reader_monad(Env : sig type env end) : sig
     val local : (env -> env) -> 'a m -> 'a m
   end
   (* ReaderT transformer when wrapped monad has plus, zero *)
-  module TP : functor (Wrapped : Monad.WP) -> sig
+  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
+    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
     let unit a = fun e -> a
     let bind u f = fun e -> let a = u e in let u' = f a in u' e
-    type 'a result = env -> 'a
     let run u = fun e -> u e
-    type 'a result_exn = env -> 'a
     let run_exn = run
   end
   include Monad.Make(Base)
   let ask = fun e -> e
   let asks selector = ask >>= (fun e -> unit (selector e)) (* may fail *)
   let local modifier u = fun e -> u (modifier e)
-  module T(Wrapped : Monad.W) = 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)
-      type 'a result = env -> 'a Wrapped.result
       let run u = fun e -> Wrapped.run (u e)
-      type 'a result_exn = env -> 'a Wrapped.result_exn
       let run_exn u = fun e -> Wrapped.run_exn (u e)
     end
     include Monad.MakeT(Trans)
@@ -600,7 +797,7 @@ end = struct
     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.WP) = struct
+  module TP(Wrapped : Monad.P) = struct
     module TransP = struct
       include T(Wrapped)
       let plus u v = fun s -> Wrapped.plus (u s) (v s)
@@ -612,6 +809,36 @@ end = struct
     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
+      (* code repetition, ugh *)
+      include T2(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.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
+  end
 end
 
 
@@ -627,7 +854,7 @@ module State_monad(Store : sig type store end) : sig
   val put : store -> unit m
   val puts : (store -> store) -> unit m
   (* StateT transformer *)
-  module T : functor (Wrapped : Monad.W) -> sig
+  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
@@ -638,19 +865,33 @@ module State_monad(Store : sig type store end) : sig
     val puts : (store -> store) -> unit m
   end
   (* StateT transformer when wrapped monad has plus, zero *)
-  module TP : functor (Wrapped : Monad.WP) -> sig
+  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
+    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
     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'
-    type 'a result = store -> 'a * store
     let run u = fun s -> (u s)
-    type 'a result_exn = store -> 'a
     let run_exn u = fun s -> fst (u s)
   end
   include Monad.Make(Base)
@@ -658,17 +899,17 @@ end = struct
   let gets viewer = fun s -> (viewer s, s) (* may fail *)
   let put s = fun _ -> ((), s)
   let puts modifier = fun s -> ((), modifier s)
-  module T(Wrapped : Monad.W) = 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')
-      type 'a result = store -> ('a * store) Wrapped.result
       let run u = fun s -> Wrapped.run (u s)
-      type 'a result_exn = store -> 'a Wrapped.result_exn
       let run_exn u = fun s ->
         let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
         in Wrapped.run_exn w
@@ -679,7 +920,7 @@ end = struct
     let put s = fun _ -> Wrapped.unit ((), s)
     let puts modifier = fun s -> Wrapped.unit ((), modifier s)
   end
-  module TP(Wrapped : Monad.WP) = struct
+  module TP(Wrapped : Monad.P) = struct
     module TransP = struct
       include T(Wrapped)
       let plus u v = fun s -> Wrapped.plus (u s) (v s)
@@ -691,6 +932,40 @@ end = struct
     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 ->
+        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.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)
+      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.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
+  end
 end
 
 (* State monad with different interface (structured store) *)
@@ -706,7 +981,7 @@ end) : sig
   val deref : ref -> value m
   val change : ref -> value -> unit m
   (* RefT transformer *)
-  module T : functor (Wrapped : Monad.W) -> sig
+  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
@@ -716,10 +991,23 @@ end) : sig
     val change : ref -> value -> unit m
   end
   (* RefT transformer when wrapped monad has plus, zero *)
-  module TP : functor (Wrapped : Monad.WP) -> sig
+  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
+    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
@@ -734,30 +1022,30 @@ end = struct
     { 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
     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'
-    type 'a result = 'a
     let run u = fst (u empty)
-    type 'a result_exn = 'a
     let run_exn = run
   end
   include Monad.Make(Base)
   let newref value = fun s -> alloc value s
   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.W) = 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')
-      type 'a result = 'a Wrapped.result
       let run u =
         let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
         in Wrapped.run w
-      type 'a result_exn = 'a Wrapped.result_exn
       let run_exn u =
         let w = Wrapped.bind (u empty) (fun (a,s) -> Wrapped.unit a)
         in Wrapped.run_exn w
@@ -767,7 +1055,7 @@ end = struct
     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.WP) = struct
+  module TP(Wrapped : Monad.P) = struct
     module TransP = struct
       include T(Wrapped)
       let plus u v = fun s -> Wrapped.plus (u s) (v s)
@@ -776,6 +1064,38 @@ end = struct
     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 ->
+        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.MakeT2(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)
+      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
 
 
@@ -799,11 +1119,11 @@ 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
     let unit a = (a, Log.zero)
     let bind (a, w) f = let (a', w') = f a in (a', Log.plus w w')
-    type 'a result = 'a * log
     let run u = u
-    type 'a result_exn = 'a * log
     let run_exn = run
   end
   include Monad.Make(Base)
@@ -848,13 +1168,13 @@ module IO_monad : sig
 end = struct
   module Base = struct
     type 'a m = { run : unit -> unit; value : 'a }
+    type 'a result = 'a
+    type 'a result_exn = 'a
     let unit a = { run = (fun () -> ()); value = a }
     let bind (a : 'a m) (f: 'a -> 'b m) : 'b m =
      let fres = f a.value in
        { run = (fun () -> a.run (); fres.run ()); value = fres.value }
-    type 'a result = 'a
     let run a = let () = a.run () in a.value
-    type 'a result_exn = 'a
     let run_exn = run
   end
   include Monad.Make(Base)
@@ -866,15 +1186,19 @@ 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 =
@@ -886,6 +1210,8 @@ end = struct
   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
@@ -894,28 +1220,27 @@ end = struct
       let cont : 'r. ('a -> 'r) -> 'r =
         fun k -> u.cont (fun a -> (f a).cont k)
       in { cont }
-    type 'a result = 'a m
     let run (u : 'a m) : 'a result = u
-    type 'a result_exn = 'a m
     let run_exn (u : 'a m) : 'a result_exn = u
     let callcc f =
-      let cont : 'r. ('a -> 'r) -> 'r = fun k ->
+      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
+      let cont = fun k ->
+        (f (fun a -> unit (k a))).cont id
       in { cont = Obj.magic cont }
-    let runk u k = u.cont k
-    let run0 u = u.cont id
+    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
@@ -924,46 +1249,58 @@ end = struct
   let runk = Base.runk
   let run0 = Base.run0
 end
+ *)
 
-(*
 (* This two-type parameter version works without Obj.magic *)
-
-module Continuation_monad2 : sig
+module Continuation_monad : sig
   (* expose only the implementation of type `('r,'a) result` *)
-  type ('r,'a) result = ('a -> 'r) -> 'r
+  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
+  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
   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
-
+  (* val abort : ('a,'a) m -> ('a,'b) m *)
+  val abort : 'a -> ('a,'b) m
+  val run0 : ('a,'a) m -> 'a
 end = struct
   let id = fun i -> i
   module Base = struct
     (* 'r is result type of whole computation *)
     type ('r,'a) m = ('a -> 'r) -> 'r
-    let unit a = fun k -> k a
-    let bind u f = fun k -> u (fun a -> (f a) k)
     type ('r,'a) result = ('a -> 'r) -> 'r
-    let run u = u
-    type ('r,'a) result_exn = ('a -> 'r) -> 'r
+    type ('r,'a) result_exn = ('r,'a) result
+    let unit a = (fun k -> k a)
+    let bind u f = (fun k -> (u) (fun a -> (f a) k))
+    let run u k = (u) k
     let run_exn = run
   end
   include Monad.Make2(Base)
-  let callcc f = fun k ->
-    let usek a = fun _ -> k a
-    in f usek k
+  let callcc f = (fun k ->
+    let usek a = (fun _ -> k a)
+    in (f usek) k)
   (*
   val callcc : (('a -> 'r) -> ('r,'a) m) -> ('r,'a) m
   val throw : ('a -> 'r) -> 'a -> ('r,'b) m
   let callcc f = fun k -> f k k
   let throw k a = fun _ -> k a
   *)
-  (* from http://www.haskell.org/haskellwiki/MonadCont_done_right *)
-  let reset u = unit (u id)
-  let shift u = fun k -> u (fun a -> unit (k a)) id
+
+  (* from http://www.haskell.org/haskellwiki/MonadCont_done_right
+   *
+   *  reset :: (Monad m) => ContT a m a -> ContT r m a
+   *  reset e = ContT $ \k -> runContT e return >>= k
+   *
+   *  shift :: (Monad m) => ((a -> ContT r m b) -> ContT b m b) -> ContT b m a
+   *  shift e = ContT $ \k ->
+   *              runContT (e $ \v -> ContT $ \c -> k v >>= c) return *)
+  let reset u = unit ((u) id)
+  let shift f = (fun k -> (f (fun a -> unit (k a))) id)
+  (* let abort a = shift (fun _ -> a) *)
+  let abort a = shift (fun _ -> unit a)
+  let run0 (u : ('a,'a) m) = (u) id
 end
- *)
 
 
 (*
@@ -1035,7 +1372,7 @@ module Leaf_monad : sig
   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
   (* LeafT transformer *)
-  module T : functor (Wrapped : Monad.W) -> sig
+  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
@@ -1045,6 +1382,14 @@ module Leaf_monad : sig
     (* 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
+    val elevate : ('x,'a) Wrapped.m -> ('x,'a) m
+    val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
+  end
 end = struct
   type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
   (* uses supplied plus and zero to copy t to its image under f *)
@@ -1058,6 +1403,8 @@ end = struct
                    ) in loop ts
   module Base = struct
     type 'a m = 'a tree option
+    type 'a result = 'a tree option
+    type 'a result_exn = 'a tree
     let unit a = Some (Leaf a)
     let zero () = None
     let plus u v = match (u, v) with
@@ -1065,9 +1412,7 @@ end = struct
       | _, None -> u
       | Some us, Some vs -> Some (Node (us, vs))
     let bind u f = mapT f u zero plus
-    type 'a result = 'a tree option
     let run u = u
-    type 'a result_exn = 'a tree
     let run_exn u = match u with
       | None -> failwith "no values"
       (*
@@ -1080,7 +1425,7 @@ end = struct
   include (Monad.MakeDistrib(Base) : Monad.PLUS with type 'a m := 'a m)
   let base_plus = plus
   let base_lift = lift
-  module T(Wrapped : Monad.W) = struct
+  module T(Wrapped : Monad.S) = struct
     module Trans = struct
       let zero () = Wrapped.unit None
       let plus u v =
@@ -1089,12 +1434,12 @@ end = struct
         Wrapped.unit (base_plus us vs)))
       include Monad.MakeT(struct
         module Wrapped = Wrapped
-        type 'a m = 'a Base.m Wrapped.m
+        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)
-        type 'a result = 'a tree option Wrapped.result
         let run u = Wrapped.run u
-        type 'a result_exn = 'a tree Wrapped.result_exn
         let run_exn u =
             let w = Wrapped.bind u (fun t -> match t with
               | None -> failwith "no values"
@@ -1107,6 +1452,33 @@ end = struct
     (* 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 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.MakeDistrib2(Trans) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
+    let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
+  end
 end
 
 
@@ -1119,10 +1491,14 @@ module LS = L.T(S);;
 module TL = T.T(L);;
 module TR = T.T(R);;
 module TS = T.T(S);;
+module C = Continuation_monad
+module TC = T.T2(C);;
+
+
+print_endline "=== test Leaf(...).distribute ==================";;
 
 let t1 = Some (T.Node (T.Node (T.Leaf 2, T.Leaf 3), T.Node (T.Leaf 5, T.Node (T.Leaf 7, T.Leaf 11))));;
 
-(*
 let ts = TS.distribute (fun i -> S.(puts succ >> unit i)) t1;;
 TS.run ts 0;;
 (*
@@ -1189,7 +1565,7 @@ LS.run (LS.distribute (fun i -> if i = -1 then S.get else if i < 0 then S.(puts
 - : S.store list * S.store = ([10; 0; 0; 1; 20], 1)
 *)
 
-*)
+print_endline "=== test Leaf(Continuation).distribute ==================";;
 
 let id : 'z. 'z -> 'z = fun x -> x
 
@@ -1234,24 +1610,22 @@ let example3 () =
 (* (+ 100 (prompt (+ 10 (shift k (k (k 1)))))) ~~> 121 *)
 let example5 () : int =
   Continuation_monad.(let v = reset (
-      let u = shift (fun k -> k 1 >>= fun x -> k x)
+      let u = shift (fun k -> k 1 >>= k)
       in u >>= fun x -> unit (10 + x)
     ) in let w = v >>= fun x -> unit (100 + x)
     in run0 w)
 
-
 ;;
 
+print_endline "=== test bare Continuation ============";;
+
 (1011, 1111, 1111, 121);;
 (example1(), example2(), example3(), example5());;
 ((111,0), (0,0));;
 (example ~+10, example ~-10);;
 
-module C = Continuation_monad
-module TC = T.T(C)
-
 let testc df ic =
-    C.runk TC.(run_exn (distribute df t1)) ic;;
+    C.run_exn TC.(run (distribute df t1)) ic;;
 
 
 (*
@@ -1294,3 +1668,22 @@ TreeCont.monadize t1 (fun a k -> k [a; a*a]) initial_continuation;;
 
 testc C.(fun a -> shift (fun k -> k (a,a+1))) (fun t -> t);;
 
+print_endline "=== pa_monad's Continuation Tests ============";;
+
+(1, 5 = C.(run0 (unit 1 >>= fun x -> unit (x+4))) );;
+(2, 9 = C.(run0 (reset (unit 5 >>= fun x -> unit (x+4)))) );;
+(3, 9 = C.(run0 (reset (abort 5 >>= fun y -> unit (y+6)) >>= fun x -> unit (x+4))) );;
+(4, 9 = C.(run0 (reset (reset (abort 5 >>= fun y -> unit (y+6))) >>= fun x -> unit (x+4))) );;
+(5, 27 = C.(run0 (
+              let c = reset(abort 5 >>= fun y -> unit (y+6))
+              in reset(c >>= fun v1 -> abort 7 >>= fun v2 -> unit (v2+10) ) >>= fun x -> unit (x+20))) );;
+
+(7, 117 = C.(run0 (reset (shift (fun sk -> sk 3 >>= sk >>= fun v3 -> unit (v3+100) ) >>= fun v1 -> unit (v1+2)) >>= fun x -> unit (x+10))) );;
+
+(8, 115 = C.(run0 (reset (shift (fun sk -> sk 3 >>= fun v3 -> unit (v3+100)) >>= fun v1 -> unit (v1+2)) >>= fun x -> unit (x+10))) );;
+
+(12, ["a"] = C.(run0 (reset (shift (fun f -> f [] >>= fun t -> unit ("a"::t)  ) >>= fun xv -> shift (fun _ -> unit xv)))) );;
+
+
+(0, 15 = C.(run0 (let f k = k 10 >>= fun v-> unit (v+100) in reset (callcc f >>= fun v -> unit (v+5)))) );;
+