From: Jim <jim.pryor@nyu.edu>
Date: Mon, 23 Mar 2015 13:36:33 +0000 (-0400)
Subject: add some old code, let's review/update before publishing
X-Git-Url: http://lambda.jimpryor.net/git/gitweb.cgi?p=lambda.git;a=commitdiff_plain;h=4f35315db125b1860395e1d9f5b9b816dc7170c9

add some old code, let's review/update before publishing
---

diff --git a/code/_monads.ml b/code/_monads.ml
new file mode 100644
index 00000000..d8725937
--- /dev/null
+++ b/code/_monads.ml
@@ -0,0 +1,1061 @@
+(*
+ * monads.ml
+ *
+ * Relies on features introduced in OCaml 3.12
+ *
+ * This library uses parameterized modules, see tree_monadize.ml for
+ * more examples and explanation.
+ *
+ * Some comparisons with the Haskell monadic libraries, which we mostly follow:
+ * In Haskell, the Reader 'a monadic type would be defined something like this:
+ *     newtype Reader a = Reader { runReader :: env -> a }
+ * (For simplicity, I'm suppressing the fact that Reader is also parameterized
+ * on the type of env.)
+ * This creates a type wrapper around `env -> a`, so that Haskell will
+ * distinguish between values that have been specifically designated as
+ * being of type `Reader a`, and common-garden values of type `env -> a`.
+ * To lift an aribtrary expression E of type `env -> a` into an `Reader a`,
+ * you do this:
+ *     Reader { runReader = E }
+ * or use any of the following equivalent shorthands:
+ *     Reader (E)
+ *     Reader $ E
+ * To drop an expression R of type `Reader a` back into an `env -> a`, you do
+ * one of these:
+ *     runReader (R)
+ *     runReader $ R
+ * The `newtype` in the type declaration ensures that Haskell does this all
+ * efficiently: though it regards E and R as type-distinct, their underlying
+ * machine implementation is identical and doesn't need to be transformed when
+ * lifting/dropping from one type to the other.
+ *
+ * Now, you _could_ also declare monads as record types in OCaml, too, _but_
+ * doing so would introduce an extra level of machine representation, and
+ * lifting/dropping from the one type to the other wouldn't be free like it is
+ * in Haskell.
+ *
+ * This library encapsulates the monadic types in another way: by
+ * making their implementations private. The interpreter won't let
+ * let you freely interchange the `'a Reader_monad.m`s defined below
+ * with `Reader_monad.env -> 'a`. The code in this library can see that
+ * those are equivalent, but code outside the library can't. Instead, you'll
+ * have to use operations like `run` to convert the abstract monadic types
+ * to types whose internals you have free access to.
+ *
+ * Acknowledgements: This is largely based on the mtl library distributed
+ * with the Glasgow Haskell Compiler. I've also been helped in
+ * various ways by posts and direct feedback from Oleg Kiselyov and
+ * Chung-chieh Shan. The following were also useful:
+ * - <http://pauillac.inria.fr/~xleroy/mpri/progfunc/>
+ * - Ken Shan "Monads for natural language semantics" <http://arxiv.org/abs/cs/0205026v1>
+ * - http://www.grabmueller.de/martin/www/pub/Transformers.pdf
+ * - http://en.wikibooks.org/wiki/Haskell/Monad_transformers
+ *
+ * Licensing: MIT (if that's compatible with the ghc sources this is partly
+ * derived from)
+ *)
+
+
+(* Some library functions used below. *)
+
+exception Undefined
+
+module Util = struct
+  let fold_right = List.fold_right
+  let map = List.map
+  let append = List.append
+  let reverse = List.rev
+  let concat = List.concat
+  let concat_map f lst = List.concat (List.map f lst)
+  (* let zip = List.combine *)
+  let unzip = List.split
+  let zip_with = List.map2
+  let replicate len fill =
+    let rec loop n accu =
+      if n == 0 then accu else loop (pred n) (fill :: accu)
+    in loop len []
+  (* 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 Tree_monad). *)
+  let undef = Obj.magic (fun () -> raise Undefined)
+end
+
+(*
+ * This module contains factories that extend a base set of
+ * monadic definitions with a larger family of standard derived values.
+ *)
+
+module Monad = struct
+
+  (*
+   * Signature extenders:
+   *   Make :: BASE -> S
+   *   MakeT :: BASET (with Wrapped : S) -> result sig not declared
+   *)
+
+
+  (* type of base definitions *)
+  module type BASE = sig
+    (* We make all monadic types doubly-parameterized so that they
+     * can layer nicely with Continuation, which needs the second
+     * type parameter. *)
+    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
+    val run : ('x,'a) m -> ('x,'a) result
+    (* run_exn tries to provide a more ground-level result, but may fail *)
+    val run_exn : ('x,'a) m -> ('x,'a) result_exn
+    (* To simplify the library, we require every monad to supply a plus and zero. These obey the following laws:
+     *     zero >>= f   ===  zero
+     *     plus zero u  ===  u
+     *     plus u zero  ===  u
+     * 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.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
+    (* zero has to be thunked to ensure results are always poly enough *)
+    val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
+  end
+  module type S = sig
+    include BASE
+    val (>>=) : ('x,'a) m -> ('a -> ('x,'b) m) -> ('x,'b) m
+    val (>>) : ('x,'a) m -> ('x,'b) m -> ('x,'b) m
+    val join : ('x,('x,'a) m) m -> ('x,'a) m
+    val apply : ('x,'a -> 'b) m -> ('x,'a) m -> ('x,'b) m
+    val lift : ('a -> 'b) -> ('x,'a) m -> ('x,'b) m
+    val lift2 :  ('a -> 'b -> 'c) -> ('x,'a) m -> ('x,'b) m -> ('x,'c) m
+    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 : (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
+    val guard : bool -> ('x,unit) m
+    val sum : ('x,'a) m list -> ('x,'a) m
+  end
+
+  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.undef then Util.undef
+      else B.bind u (fun a -> try f a with Match_failure _ -> zero ())
+    let plus u v =
+      if u == Util.undef then v else if v == Util.undef then u else B.plus u v
+    let run u =
+      if u == Util.undef then raise Undefined else B.run u
+    let run_exn u =
+      if u == Util.undef then raise Undefined else B.run_exn u
+    let (>>=) = bind
+    (* expressions after >> will be evaluated before they're passed to
+     * bind, so you can't do `zero () >> assert false`
+     * this works though: `zero () >>= fun _ -> assert false`
+     *)
+    let (>>) u v = u >>= fun _ -> v
+    let lift f u = u >>= fun a -> unit (f a)
+    (* lift is called listM, fmap, and <$> in Haskell *)
+    let join uu = uu >>= fun u -> u
+    (* u >>= f === join (lift f u) *)
+    let apply u v = u >>= fun f -> v >>= fun a -> unit (f a)
+    (* [f] <*> [x1,x2] = [f x1,f x2] *)
+    (* let apply u v = u >>= fun f -> lift f v *)
+    (* let apply = lift2 id *)
+    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
+    (* A Haskell-like version works:
+         let rec forever uthunk = uthunk () >>= fun _ -> forever uthunk
+     * but the recursive call is not in tail position so this can stack overflow. *)
+    let forever uthunk =
+        let z = zero () in
+        let id result = result in
+        let kcell = ref id in
+        let rec loop _ =
+            let result = uthunk (kcell := id) >>= chained
+            in !kcell result
+        and chained _ =
+            kcell := loop; z (* we use z only for its polymorphism *)
+        in loop z
+    (* Reimplementations of the preceding using a hand-rolled State or StateT
+can also stack overflow. *)
+    let sequence ms =
+      let op u v = u >>= fun x -> v >>= fun xs -> unit (x :: xs) in
+        Util.fold_right op ms (unit [])
+    let sequence_ ms =
+      Util.fold_right (>>) ms (unit ())
+
+    (* Haskell defines these other operations combining lists and monads.
+     * We don't, but notice that M.mapM == ListT(M).distribute
+     * There's also a parallel TreeT(M).distribute *)
+    (*
+    let mapM f alist = sequence (Util.map f alist)
+    let mapM_ f alist = sequence_ (Util.map f alist)
+    let rec filterM f lst = match lst with
+      | [] -> unit []
+      | x::xs -> f x >>= fun flag -> filterM f xs >>= fun ys -> unit (if flag then x :: ys else ys)
+    let forM alist f = mapM f alist
+    let forM_ alist f = mapM_ f alist
+    let map_and_unzipM f xs = sequence (Util.map f xs) >>= fun x -> unit (Util.unzip x)
+    let zip_withM f xs ys = sequence (Util.zip_with f xs ys)
+    let zip_withM_ f xs ys = sequence_ (Util.zip_with f xs ys)
+    let rec foldM f z lst = match lst with
+      | [] -> unit z
+      | x::xs -> f z x >>= fun z' -> foldM f z' xs
+    let foldM_ f z xs = foldM f z xs >> unit ()
+    let replicateM n x = sequence (Util.replicate n x)
+    let replicateM_ n x = sequence_ (Util.replicate n x)
+    *)
+    let guard test = if test then B.unit () else zero ()
+    let sum ms = Util.fold_right plus ms (zero ())
+  end
+
+  (* Signatures for MonadT *)
+  module type BASET = sig
+    module Wrapped : S
+    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
+    (* lift/elevate laws:
+     *     elevate (W.unit a) == unit a
+     *     elevate (W.bind w f) == elevate w >>= fun a -> elevate (f a)
+     *)
+    val zero : unit -> ('x,'a) m
+    val plus : ('x,'a) m -> ('x,'a) m -> ('x,'a) m
+  end
+  module MakeT(T : BASET) = struct
+    include Make(struct
+        include T
+        let unit a = elevate (Wrapped.unit a)
+    end)
+    let elevate = T.elevate
+  end
+
+end
+
+
+
+
+
+module Identity_monad : sig
+  (* expose only the implementation of type `'a result` *)
+  type ('x,'a) result = 'a
+  type ('x,'a) result_exn = 'a
+  include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+end = struct
+  module Base = struct
+    type ('x,'a) m = 'a
+    type ('x,'a) result = 'a
+    type ('x,'a) result_exn = 'a
+    let unit a = a
+    let bind a f = f a
+    let run a = a
+    let run_exn a = a
+    let zero () = Util.undef
+    let plus u v = u
+  end
+  include Monad.Make(Base)
+end
+
+
+module Maybe_monad : sig
+  (* expose only the implementation of type `'a result` *)
+  type ('x,'a) result = 'a option
+  type ('x,'a) result_exn = 'a
+  include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+  (* MaybeT transformer *)
+  module T : functor (Wrapped : Monad.S) -> sig
+    type ('x,'a) result = ('x,'a option) Wrapped.result
+    type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
+    include Monad.S 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
+  end
+end = struct
+  module Base = struct
+    type ('x,'a) m = 'a option
+    type ('x,'a) result = 'a option
+    type ('x,'a) result_exn = 'a
+    let unit a = Some a
+    let bind u f = match u with Some a -> f a | None -> None
+    let run u = u
+    let run_exn u = match u with
+      | Some a -> a
+      | None -> failwith "no value"
+    let zero () = None
+    (* satisfies Catch *)
+    let plus u v = match u with None -> v | _ -> u
+  end
+  include Monad.Make(Base)
+  module T(Wrapped : Monad.S) = struct
+    module BaseT = struct
+      include Monad.MakeT(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
+        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 -> Wrapped.zero ()
+          ) in Wrapped.run_exn w
+        let zero () = Wrapped.unit None
+        let plus u v = Wrapped.bind u (fun t -> match t with | None -> v | _ -> u)
+      end)
+    end
+    include BaseT
+  end
+end
+
+
+module List_monad : sig
+  (* declare additional operation, while still hiding implementation of type m *)
+  type ('x,'a) result = 'a list
+  type ('x,'a) result_exn = 'a
+  include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+  val permute : ('x,'a) m -> ('x,('x,'a) m) m
+  val select : ('x,'a) m -> ('x,'a * ('x,'a) m) m
+  (* ListT transformer *)
+  module T : functor (Wrapped : Monad.S) -> sig
+    type ('x,'a) result = ('x,'a list) Wrapped.result
+    type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
+    include Monad.S 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
+    (* note that second argument is an 'a list, not the more abstract 'a m *)
+    (* type is ('a -> 'b W) -> 'a list -> 'b list W == 'b listT(W) *)
+    val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a list -> ('x,'b) m
+    val permute : ('x,'a) m -> ('x,('x,'a) m) m
+    val select : ('x,'a) m -> ('x,('a * ('x,'a) m)) m
+    val expose : ('x,'a) m -> ('x,'a list) Wrapped.m
+  end
+end = struct
+  module Base = struct
+   type ('x,'a) m = 'a list
+   type ('x,'a) result = 'a list
+   type ('x,'a) result_exn = 'a
+   let unit a = [a]
+   let bind u f = Util.concat_map f u
+   let run u = u
+   let run_exn u = match u with
+     | [] -> failwith "no values"
+     | [a] -> a
+     | many -> failwith "multiple values"
+   let zero () = []
+   (* satisfies Distrib *)
+   let plus = Util.append
+  end
+  include Monad.Make(Base)
+  (* let either u v = plus u v *)
+  (* insert 3 [1;2] ~~> [[3;1;2]; [1;3;2]; [1;2;3]] *)
+  let rec insert a u =
+    plus (unit (a :: u)) (match u with
+        | [] -> zero ()
+        | x :: xs -> (insert a xs) >>= fun v -> unit (x :: v)
+    )
+  (* permute [1;2;3] ~~> [1;2;3]; [2;1;3]; [2;3;1]; [1;3;2]; [3;1;2]; [3;2;1] *)
+  let rec permute u = match u with
+      | [] -> unit []
+      | x :: xs -> (permute xs) >>= (fun v -> insert x v)
+  (* select [1;2;3] ~~> [(1,[2;3]); (2,[1;3]), (3;[1;2])] *)
+  let rec select u = match u with
+    | [] -> zero ()
+    | x::xs -> plus (unit (x, xs)) (select xs >>= fun (x', xs') -> unit (x', x :: xs'))
+  module T(Wrapped : Monad.S) = struct
+    (* Wrapped.sequence ms  ===
+         let plus1 u v =
+           Wrapped.bind u (fun x ->
+           Wrapped.bind v (fun xs ->
+           Wrapped.unit (x :: xs)))
+         in Util.fold_right plus1 ms (Wrapped.unit []) *)
+    (* distribute  ===  Wrapped.mapM; copies alist to its image under f *)
+    let distribute f alist = Wrapped.sequence (Util.map f alist)
+
+    include Monad.MakeT(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
+      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
+          | [] -> Wrapped.zero ()
+          | [a] -> Wrapped.unit a
+          | many -> Wrapped.zero ()
+        ) in Wrapped.run_exn w
+      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)
+
+   (* insert 3 {[1;2]} ~~> {[ {[3;1;2]}; {[1;3;2]}; {[1;2;3]} ]} *)
+   let rec insert a u =
+     plus
+     (unit (Wrapped.bind u (fun us -> Wrapped.unit (a :: us))))
+     (Wrapped.bind u (fun us -> match us with
+         | [] -> zero ()
+         | x::xs -> (insert a (Wrapped.unit xs)) >>= fun v -> unit (Wrapped.bind v (fun vs -> Wrapped.unit (x :: vs)))))
+
+   (* select {[1;2;3]} ~~> {[ (1,{[2;3]}); (2,{[1;3]}), (3;{[1;2]}) ]} *)
+   let rec select u =
+     Wrapped.bind u (fun us -> match us with
+         | [] -> zero ()
+         | x::xs -> plus (unit (x, Wrapped.unit xs))
+             (select (Wrapped.unit xs) >>= fun (x', xs') -> unit (x', Wrapped.bind xs' (fun ys -> Wrapped.unit (x :: ys)))))
+
+   (* permute {[1;2;3]} ~~> {[ {[1;2;3]}; {[2;1;3]}; {[2;3;1]}; {[1;3;2]}; {[3;1;2]}; {[3;2;1]} ]} *)
+
+   let rec permute u =
+     Wrapped.bind u (fun us -> match us with
+         | [] -> unit (zero ())
+         | x::xs -> permute (Wrapped.unit xs) >>= (fun v -> insert x v))
+
+    let expose u = u
+  end
+end
+
+
+(* must be parameterized on (struct type err = ... end) *)
+module Error_monad(Err : sig
+  type err
+  exception Exc of err
+  (*
+  val zero : unit -> err
+  val plus : err -> err -> err
+  *)
+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 ('x,'a) result = 'a error
+  type ('x,'a) result_exn = 'a
+  include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+  val throw : err -> ('x,'a) m
+  val catch : ('x,'a) m -> (err -> ('x,'a) m) -> ('x,'a) m
+  (* ErrorT transformer *)
+  module T : functor (Wrapped : Monad.S) -> sig
+    type ('x,'a) result = ('x,'a) Wrapped.result
+    type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
+    include Monad.S 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 ('x,'a) m = 'a error
+    type ('x,'a) result = 'a error
+    type ('x,'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 *)
+    let run u = u
+    let run_exn u = match u with
+      | Success a -> a
+      | Error e -> raise (Err.Exc e)
+    let zero () = Util.undef
+    (* satisfies Catch *)
+    let plus u v = match u with
+      | Success _ -> u
+      | Error _ -> if v == Util.undef then u else v
+  end
+  include Monad.Make(Base)
+  (* include (Monad.MakeCatch(Base) : Monad.PLUS with type 'a m := 'a m) *)
+  let throw e = Error e
+  let catch u handler = match u with
+    | Success _ -> u
+    | Error e -> handler e
+  module T(Wrapped : Monad.S) = struct
+    include Monad.MakeT(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
+      let plus u v = Wrapped.plus u v
+      let zero () = Wrapped.zero () (* elevate (Wrapped.zero ()) *)
+    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)
+  end
+end
+
+(* pre-define common instance of Error_monad *)
+module Failure = Error_monad(struct
+  type err = string
+  exception Exc = Failure
+  (*
+  let zero = ""
+  let plus s1 s2 = s1 ^ "\n" ^ s2
+  *)
+end)
+
+
+(* 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 *)
+  type env = Env.env
+  type ('x,'a) result = env -> 'a
+  type ('x,'a) result_exn = env -> 'a
+  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
+  (* lookup i == `fun e -> e i` would assume env is a functional type *)
+  val local : (env -> env) -> ('x,'a) m -> ('x,'a) m
+  (* ReaderT transformer *)
+  module T : functor (Wrapped : Monad.S) -> sig
+    type ('x,'a) result = env -> ('x,'a) Wrapped.result
+    type ('x,'a) result_exn = env -> ('x,'a) Wrapped.result_exn
+    include Monad.S 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
+    val expose : ('x,'a) m -> env -> ('x,'a) Wrapped.m
+  end
+end = struct
+  type env = Env.env
+  module Base = struct
+    type ('x,'a) m = env -> 'a
+    type ('x,'a) result = env -> 'a
+    type ('x,'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
+    let run u = fun e -> u e
+    let run_exn = run
+    let zero () = Util.undef
+    let plus u v = u
+  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.S) = struct
+    module BaseT = 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
+      let elevate w = fun e -> w
+      let bind u f = fun e -> Wrapped.bind (u e) (fun a -> f a e)
+      let run u = fun e -> Wrapped.run (u e)
+      let run_exn u = fun e -> Wrapped.run_exn (u e)
+      (* satisfies Distrib *)
+      let plus u v = fun e -> Wrapped.plus (u e) (v e)
+      let zero () = fun e -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
+    end
+    include Monad.MakeT(BaseT)
+    let ask = Wrapped.unit
+    let local modifier u = fun e -> u (modifier e)
+    let asks selector = ask >>= (fun e ->
+      try unit (selector e)
+      with Not_found -> fun e -> Wrapped.zero ())
+    let expose u = u
+  end
+end
+
+
+(* must be parameterized on (struct type store = ... end) *)
+module State_monad(Store : sig type store end) : sig
+  (* declare additional operations, while still hiding implementation of type m *)
+  type store = Store.store
+  type ('x,'a) result =  store -> 'a * store
+  type ('x,'a) result_exn = store -> 'a
+  include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+  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
+  (* StateT transformer *)
+  module T : functor (Wrapped : Monad.S) -> sig
+    type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
+    type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
+    include Monad.S 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
+    (* val passthru : ('x,'a) m -> (('x,'a * store) Wrapped.result * store -> 'b) -> ('x,'b) m *)
+    val expose : ('x,'a) m -> store -> ('x,'a * store) Wrapped.m
+  end
+end = struct
+  type store = Store.store
+  module Base = struct
+    type ('x,'a) m =  store -> 'a * store
+    type ('x,'a) result =  store -> 'a * store
+    type ('x,'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'
+    let run u = fun s -> (u s)
+    let run_exn u = fun s -> fst (u s)
+    let zero () = Util.undef
+    let plus u v = u
+  end
+  include Monad.Make(Base)
+  let get = fun s -> (s, s)
+  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.S) = struct
+    module BaseT = 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
+      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
+      (* satisfies Distrib *)
+      let plus u v = fun s -> Wrapped.plus (u s) (v s)
+      let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
+    end
+    include Monad.MakeT(BaseT)
+    let get = fun s -> Wrapped.unit (s, s)
+    let gets viewer = fun s ->
+      try Wrapped.unit (viewer s, s)
+      with Not_found -> Wrapped.zero ()
+    let put s = fun _ -> Wrapped.unit ((), s)
+    let puts modifier = fun s -> Wrapped.unit ((), modifier s)
+    (* let passthru u f = fun s -> Wrapped.unit (f (Wrapped.run (u s), s), s) *)
+    let expose u = u
+  end
+end
+
+
+(* State monad with different interface (structured store) *)
+module Ref_monad(V : sig
+  type value
+end) : sig
+  type ref
+  type value = V.value
+  type ('x,'a) result = 'a
+  type ('x,'a) result_exn = 'a
+  include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+  val newref : value -> ('x,ref) m
+  val deref : ref -> ('x,value) m
+  val change : ref -> value -> ('x,unit) m
+  (* RefT transformer *)
+  module T : functor (Wrapped : Monad.S) -> sig
+    type ('x,'a) result = ('x,'a) Wrapped.result
+    type ('x,'a) result_exn = ('x,'a) Wrapped.result_exn
+    include Monad.S 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
+end = struct
+  type ref = int
+  type value = V.value
+  module D = Map.Make(struct type t = ref let compare = compare end)
+  type dict = { next: ref; tree : value D.t }
+  let empty = { next = 0; tree = D.empty }
+  let alloc (value : value) (d : dict) =
+    (d.next, { next = succ d.next; tree = D.add d.next value d.tree })
+  let read (key : ref) (d : dict) =
+    D.find key d.tree
+  let write (key : ref) (value : value) (d : dict) =
+    { next = d.next; tree = D.add key value d.tree }
+  module Base = struct
+    type ('x,'a) m = dict -> 'a * dict
+    type ('x,'a) result = 'a
+    type ('x,'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'
+    let run u = fst (u empty)
+    let run_exn = run
+    let zero () = Util.undef
+    let plus u v = u
+  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.S) = struct
+    module BaseT = 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
+      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
+      (* satisfies Distrib *)
+      let plus u v = fun s -> Wrapped.plus (u s) (v s)
+      let zero () = fun s -> Wrapped.zero () (* elevate (Wrapped.zero ()) *)
+    end
+    include Monad.MakeT(BaseT)
+    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
+
+
+(* must be parameterized on (struct type log = ... end) *)
+module Writer_monad(Log : sig
+  type log
+  val zero : log
+  val plus : log -> log -> log
+end) : sig
+  (* declare additional operations, while still hiding implementation of type m *)
+  type log = Log.log
+  type ('x,'a) result = 'a * log
+  type ('x,'a) result_exn = 'a * log
+  include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+  val tell : log -> ('x,unit) m
+  val listen : ('x,'a) m -> ('x,'a * log) m
+  val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
+  (* val pass : ('x,'a * (log -> log)) m -> ('x,'a) m *)
+  val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
+  (* WriterT transformer *)
+  module T : functor (Wrapped : Monad.S) -> sig
+    type ('x,'a) result = ('x,'a * log) Wrapped.result
+    type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
+    include Monad.S 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 tell : log -> ('x,unit) m
+    val listen : ('x,'a) m -> ('x,'a * log) m
+    val listens : (log -> 'b) -> ('x,'a) m -> ('x,'a * 'b) m
+    val censor : (log -> log) -> ('x,'a) m -> ('x,'a) m
+  end
+end = struct
+  type log = Log.log
+  module Base = struct
+    type ('x,'a) m = 'a * log
+    type ('x,'a) result = 'a * log
+    type ('x,'a) result_exn = 'a * log
+    let unit a = (a, Log.zero)
+    let bind (a, w) f = let (b, w') = f a in (b, Log.plus w w')
+    let run u = u
+    let run_exn = run
+    let zero () = Util.undef
+    let plus u v = u
+  end
+  include Monad.Make(Base)
+  let tell entries = ((), entries) (* add entries to log *)
+  let listen (a, w) = ((a, w), w)
+  let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w) (* filter listen through selector *)
+  let pass ((a, f), w) = (a, f w) (* usually use censor helper *)
+  let censor f u = pass (u >>= fun a -> unit (a, f))
+  module T(Wrapped : Monad.S) = struct
+    module BaseT = struct
+      module Wrapped = Wrapped
+      type ('x,'a) m = ('x,'a * log) Wrapped.m
+      type ('x,'a) result = ('x,'a * log) Wrapped.result
+      type ('x,'a) result_exn = ('x,'a * log) Wrapped.result_exn
+      let elevate w =
+        Wrapped.bind w (fun a -> Wrapped.unit (a, Log.zero))
+      let bind u f =
+        Wrapped.bind u (fun (a, w) ->
+        Wrapped.bind (f a) (fun (b, w') ->
+        Wrapped.unit (b, Log.plus w w')))
+      let zero () = elevate (Wrapped.zero ())
+      let plus u v = Wrapped.plus u v
+      let run u = Wrapped.run u
+      let run_exn u = Wrapped.run_exn u
+    end
+    include Monad.MakeT(BaseT)
+    let tell entries = Wrapped.unit ((), entries)
+    let listen u = Wrapped.bind u (fun (a, w) -> Wrapped.unit ((a, w), w))
+    let pass u = Wrapped.bind u (fun ((a, f), w) -> Wrapped.unit (a, f w))
+    (* rest are derived in same way as before *)
+    let listens selector u = listen u >>= fun (a, w) -> unit (a, selector w)
+    let censor f u = pass (u >>= fun a -> unit (a, f))
+  end
+end
+
+(* pre-define simple Writer *)
+module Writer1 = Writer_monad(struct
+  type log = string
+  let zero = ""
+  let plus s1 s2 = s1 ^ "\n" ^ s2
+end)
+
+(* slightly more efficient Writer *)
+module Writer2 = struct
+  include Writer_monad(struct
+    type log = string list
+    let zero = []
+    let plus w w' = Util.append w' w
+  end)
+  let tell_string s = tell [s]
+  let tell entries = tell (Util.reverse entries)
+  let run u = let (a, w) = run u in (a, Util.reverse w)
+  let run_exn = run
+end
+
+
+(* TODO needs a T *)
+module IO_monad : sig
+  (* declare additional operation, while still hiding implementation of type m *)
+  type ('x,'a) result = 'a
+  type ('x,'a) result_exn = 'a
+  include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+  val printf : ('a, unit, string, ('x,unit) m) format4 -> 'a
+  val print_string : string -> ('x,unit) m
+  val print_int : int -> ('x,unit) m
+  val print_hex : int -> ('x,unit) m
+  val print_bool : bool -> ('x,unit) m
+end = struct
+  module Base = struct
+    type ('x,'a) m = { run : unit -> unit; value : 'a }
+    type ('x,'a) result = 'a
+    type ('x,'a) result_exn = 'a
+    let unit a = { run = (fun () -> ()); value = a }
+    let bind (a : ('x,'a) m) (f: 'a -> ('x,'b) m) : ('x,'b) m =
+     let fres = f a.value in
+       { run = (fun () -> a.run (); fres.run ()); value = fres.value }
+    let run a = let () = a.run () in a.value
+    let run_exn = run
+    let zero () = Util.undef
+    let plus u v = u
+  end
+  include Monad.Make(Base)
+  let printf fmt =
+    Printf.ksprintf (fun s -> { Base.run = (fun () -> Pervasives.print_string s); value = () }) fmt
+  let print_string s = { Base.run = (fun () -> Printf.printf "%s\n" s); value = () }
+  let print_int i = { Base.run = (fun () -> Printf.printf "%d\n" i); value = () }
+  let print_hex i = { Base.run = (fun () -> Printf.printf "0x%x\n" i); value = () }
+  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 ('r,'a) m
+  type ('r,'a) result = ('r,'a) m
+  type ('r,'a) result_exn = ('a -> 'r) -> 'r
+  include Monad.S 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
+  (* ContinuationT transformer *)
+  module T : functor (Wrapped : Monad.S) -> sig
+    type ('r,'a) m
+    type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
+    type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
+    include Monad.S 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 elevate : ('x,'a) Wrapped.m -> ('x,'a) m
+    val callcc : (('a -> ('r,'b) m) -> ('r,'a) m) -> ('r,'a) m
+    (* TODO: reset,shift,abort,run0 *)
+  end
+end = struct
+  let id = fun i -> i
+  module Base = struct
+    (* 'r is result type of whole computation *)
+    type ('r,'a) m = ('a -> 'r) -> 'r
+    type ('r,'a) result = ('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
+    let zero () = Util.undef
+    let plus u v = u
+  end
+  include Monad.Make(Base)
+  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
+   *
+   *  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
+  module T(Wrapped : Monad.S) = struct
+    module BaseT = struct
+      module Wrapped = Wrapped
+      type ('r,'a) m = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.m
+      type ('r,'a) result = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result
+      type ('r,'a) result_exn = ('a -> ('r,'r) Wrapped.m) -> ('r,'r) Wrapped.result_exn
+      let elevate w = fun k -> Wrapped.bind w k
+      let bind u f = fun k -> u (fun a -> f a k)
+      let run u k = Wrapped.run (u k)
+      let run_exn u k = Wrapped.run_exn (u k)
+      let zero () = Util.undef
+      let plus u v = u
+    end
+    include Monad.MakeT(BaseT)
+    let callcc f = (fun k ->
+      let usek a = (fun _ -> k a)
+      in (f usek) k)
+  end
+end
+
+
+(*
+ * Scheme:
+ * (define (example n)
+ *    (let ([u (let/cc k ; type int -> int pair
+ *               (let ([v (if (< n 0) (k 0) (list (+ n 100)))])
+ *                 (+ 1 (car v))))]) ; int
+ *      (cons u 0))) ; int pair
+ * ; (example 10) ~~> '(111 . 0)
+ * ; (example -10) ~~> '(0 . 0)
+ *
+ * OCaml monads:
+ * let example n : (int * int) =
+ *   Continuation_monad.(let u = callcc (fun k ->
+ *       (if n < 0 then k 0 else unit [n + 100])
+ *       (* all of the following is skipped by k 0; the end type int is k's input type *)
+ *       >>= fun [x] -> unit (x + 1)
+ *   )
+ *   (* k 0 starts again here, outside the callcc (...); the end type int * int is k's output type *)
+ *   >>= fun x -> unit (x, 0)
+ *   in run u)
+ *
+ *)
+
+
+module Tree_monad : sig
+  (* We implement the type as `'a tree option` because it has a natural`plus`,
+   * and the rest of the library expects that `plus` and `zero` will come together. *)
+  type 'a tree = Leaf of 'a | Node of ('a tree * 'a tree)
+  type ('x,'a) result = 'a tree option
+  type ('x,'a) result_exn = 'a tree
+  include Monad.S with type ('x,'a) result := ('x,'a) result and type ('x,'a) result_exn := ('x,'a) result_exn
+  (* TreeT transformer *)
+  module T : functor (Wrapped : Monad.S) -> sig
+    type ('x,'a) result = ('x,'a tree option) Wrapped.result
+    type ('x,'a) result_exn = ('x,'a tree) Wrapped.result_exn
+    include Monad.S 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
+    (* note that second argument is an 'a tree?, not the more abstract 'a m *)
+    (* type is ('a -> 'b W) -> 'a tree? -> 'b tree? W == 'b treeT(W) *)
+    val distribute : ('a -> ('x,'b) Wrapped.m) -> 'a tree option -> ('x,'b) m
+    val expose : ('x,'a) m -> ('x,'a tree option) Wrapped.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 *)
+  let mapT (f : 'a -> 'b) (t : 'a tree option) (zero : unit -> 'b) (plus : 'b -> 'b -> 'b) : 'b = match t with
+      | None -> zero ()
+      | Some ts -> let rec loop ts = (match ts with
+                     | Leaf a -> f a
+                     | Node (l, r) ->
+                         (* recursive application of f may delete a branch *)
+                         plus (loop l) (loop r)
+                   ) in loop ts
+  module Base = struct
+    type ('x,'a) m = 'a tree option
+    type ('x,'a) result = 'a tree option
+    type ('x,'a) result_exn = 'a tree
+    let unit a = Some (Leaf a)
+    let zero () = None
+    (* satisfies Distrib *)
+    let plus u v = match (u, v) with
+      | None, _ -> v
+      | _, None -> u
+      | Some us, Some vs -> Some (Node (us, vs))
+    let bind u f = mapT f u zero plus
+    let run u = u
+    let run_exn u = match u with
+      | None -> failwith "no values"
+      (*
+      | Some (Leaf a) -> a
+      | many -> failwith "multiple values"
+      *)
+      | Some us -> us
+  end
+  include Monad.Make(Base)
+  module T(Wrapped : Monad.S) = struct
+    module BaseT = struct
+      include Monad.MakeT(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
+        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)))
+        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 -> Wrapped.zero ()
+              | Some ts -> Wrapped.unit ts
+            ) in Wrapped.run_exn w
+      end)
+    end
+    include BaseT
+    let distribute f t = mapT (fun a -> elevate (f a)) t zero plus
+    let expose u = u
+  end
+
+end;;
+
+
diff --git a/code/_tree_monadize.ml b/code/_tree_monadize.ml
new file mode 100644
index 00000000..70e7df98
--- /dev/null
+++ b/code/_tree_monadize.ml
@@ -0,0 +1,278 @@
+(*
+ * tree_monadize.ml
+ *
+ * If you've got some block of code that uses `unit`s and `bind`s, and you
+ * want to interpret it alternately using this monad, that monad, or another
+ * monad, you can use OCaml's module system. You'd write your code like this:
+ *) 
+
+module Reader_monad = struct
+    (* change this to suit your needs *)
+    type env = int -> int;;
+
+    type 'a m = env -> 'a;;
+    let unit a : 'a m = fun e -> a;;
+    let bind (u : 'a m) (f : 'a -> 'b m) : 'b m =
+      fun e -> f (u e) e;;
+end
+
+module State_monad = struct
+    (* change this to suit your needs *)
+    type store = int;;
+
+    type 'a m = store -> 'a * store;;
+    let unit a : 'a m  = fun s -> (a, s);;
+    let bind (u : 'a m) (f : 'a -> 'b m) : 'b m =
+      fun s -> (let (a, s') = u s in (f a) s');;
+end
+
+module List_monad = struct
+    type 'a m = 'a list;;
+    let unit a : 'a m = [a];;
+    let bind (u: 'a m) (f : 'a -> 'b m) : 'b m =
+      List.concat(List.map f u);;
+end
+
+(*
+ * Then you can replace code that looks like this:
+ *     ... reader_bind ...
+ * with code that looks like this:
+ *     ... Reader_monad.bind ...
+ * and the latter can be reformulated like this:
+ *     let open Reader_monad in ... bind ...
+ * or equivalently, like this:
+ *     Reader_monad.(... bind ...)
+ * Then you can use literally the same `... bind ...` code when writing instead:
+ *     State_monad.(... bind ...)
+ *)
+
+(* That's great, however it still requires us to repeat the
+ * `... bind ...` code every time we want to change which monad we're working
+ * with. Shouldn't there be a way to _parameterize_ the `... bind ...` code
+ * on a monad, so that we only have to write the `... bind ...` code once,
+ * but can invoke it alternately with the Reader_monad supplied as an
+ * argument, or the State_monad, or another?
+ *
+ * There is a way to do this, but it requires putting the `... bind ...` code in
+ * its own module, and making that module parameterized on some M_monad
+ * module. Also we have to explicitly declare what commonality we're expecting
+ * from M_monad modules we're going to use as parameters. We'll explain how to
+ * do this in a moment.
+ *
+ * As preparation, a general observation:
+ * 'a and so on are type variables in OCaml; they stand for arbitrary types.
+ * What if you want a variable for a type constructor? For example, you want to
+ * generalize this pattern:
+ *      type ('a) t1 = 'a -> ('a) list
+ *      type ('a) t2 = 'a -> ('a) option
+ *      type ('a) t3 = 'a -> ('a) reader
+ * and so on? OCaml won't let you do this:
+ *      type ('a, 'b) t = 'a -> ('a) 'b
+ * To generalize on the 'b position, we instead have to use OCaml's modules,
+ * and in particular its ability to make modules parameterized on other modules
+ * (OCaml calls these parameterized modules Functors, but that name is also
+ * used in other ways in this literature, so I won't give in to it.)
+ *
+ * Here's how you'd have to define the t type from above:
+ *      module T_maker(
+ *      (* A sig...end block specifies the type of a module
+ *       * What we're doing here is specifying the type of the 
+ *       * module parameter that will choose
+ *       * whether b = list or b = option or b = reader...
+ *       * This module parameter may supply values as well as types *)
+ *      M : sig
+ *          type ('a) b
+ *      end
+ *      ) = 
+ *      (* A struct...end block gives a module value
+ *       * What we're doing here is building a new module that makes
+ *       * use of the module that was supplied as M *)
+ *      struct
+ *          type ('a) t = 'a -> ('a) M.b
+ *      end
+ * And here's how you'd use it:
+ *      module T_list = T_maker(struct type 'a b = 'a list end);;
+ *      type 'a t1 = 'a T_list.t;;
+ *      module T_option = T_maker(struct type 'a b = 'a option end);;
+ *      type 'a t2 = 'a T_option.t;;
+ *      (* and so on *)
+ *
+ * I know, it seems unnecessarily complicated. Nonetheless, that's how it
+ * works. And that is also the technique we'll use to make our
+ * `... bind ...` code parametric on some M_monad module.
+ *)
+
+type 'a tree = Leaf of 'a | Node of ('a tree) * ('a tree);;
+
+let t1 = Node
+           (Node
+             (Leaf 2, Leaf 3),
+            Node
+             (Leaf 5,
+              Node
+                (Leaf 7, Leaf 11)));;
+
+
+module Tree_monadizer(M : sig
+  (* the module we're using as a parameter has to supply function values
+   * for unit and bind, as well as a monadic type constructor *)
+  type 'a m
+  val unit : 'a -> 'a m
+  val bind : 'a m -> ('a -> 'b m) -> 'b m
+end) = struct
+  let rec monadize (f: 'a -> 'b M.m) (t: 'a tree) : 'b tree M.m =
+    match t with
+    | Leaf a -> M.bind (f a) (fun b -> M.unit (Leaf b))
+    | Node(l, r) ->
+        M.bind (monadize f l) (fun l' ->
+          M.bind (monadize f r) (fun r' ->
+            M.unit (Node (l', r'))))
+end;;
+
+
+(* Now we supply Reader_monad as a parameter to Tree_monadizer.
+ * We'll get back a module TreeReader that contains a single value,
+ * the monadize function specialized to the Reader monad *)
+module TreeReader = Tree_monadizer(Reader_monad);;
+
+
+(* Make a TreeState module containing monadize specialized to the State monad *)
+module TreeState =  Tree_monadizer(State_monad);;
+
+
+(* Make a TreeList module containing monadize specialized to the List monad *)
+module TreeList =  Tree_monadizer(List_monad);;
+
+
+(* The Continuation monad is a bit more complicated *)
+module Continuation_monad = struct
+    type ('r,'a) m = ('a -> 'r) -> 'r;;
+    let unit a : ('r,'a) m = fun k -> k a;;
+    let bind (u: ('r,'a) m) (f: 'a -> ('r,'b) m) : ('r,'b) m =
+      fun k -> u (fun a -> f a k);;
+end
+
+(* Since the Continuation monad is parameterized on two types---it's
+ * ('r,'a) cont not ('a) cont---we can't match the type ('a) monad that
+ * Tree_monadizer expects in its parameter. So we have to make a different
+ * Tree_monadizer2 that takes a ('r,'a) monad type constructor in its
+ * parameter instead *)
+module Tree_monadizer2(M : sig
+  type ('r,'a) m
+  val unit : 'a -> ('r,'a) m
+  val bind : ('r,'a) m -> ('a -> ('r,'b) m) -> ('r,'b) m
+end) = struct
+  (* the body of the monadize function is the same; the only difference is in
+   * the types *)
+  let rec monadize (f: 'a -> ('r,'b) M.m) (t: 'a tree) : ('r,'b tree) M.m =
+    match t with
+    | Leaf a -> M.bind (f a) (fun b -> M.unit (Leaf b))
+    | Node(l, r) ->
+        M.bind (monadize f l) (fun l' ->
+          M.bind (monadize f r) (fun r' ->
+            M.unit (Node (l', r'))))
+end;;
+
+(* Make a TreeCont module containing monadize specialized to the Cont monad *)
+module TreeCont =  Tree_monadizer2(Continuation_monad);;
+
+
+
+(* 
+ * Here are all the examples from
+ * http://lambda.jimpryor.net/manipulating_trees_with_monads/
+ *)
+
+
+let asker : int -> int Reader_monad.m =
+  fun (a : int) -> fun (env : int -> int) -> env a;;
+
+(* asker takes an int and returns a Reader monad that
+ * "looks up" that int in the environment (i.e. modifies it)
+ * this is structurally parallel to the function `lookup` we used
+ * before to "look up" variables in the environment *)
+
+(* double each leaf *)
+let env = fun i -> i + i in
+TreeReader.monadize asker t1 env;;
+
+(* You can also avoid declaring a separate toplevel TreeReader module
+ * (or even a separate Reader_monad module) by using one of these forms:
+ *     ...
+ *     let module T = Tree_monadizer(Reader_monad) in
+ *     T.monadize asker t1 env;;
+ * or:
+ *     ...
+ *     let env = fun i -> i + i in
+ *     let module Monad = struct
+ *       type env = int -> int;;
+ *       type 'a m = env -> 'a;;
+ *       let unit a : 'a m = fun e -> a;;
+ *       let bind (u : 'a m) (f : 'a -> 'b m) : 'b m =
+ *         fun e -> f (u e) e;;
+ *     end in
+ *     let module T = Tree_monadizer(Monad) in
+ *     T.monadize asker t1 env;;
+ * or:
+ *     ...
+ *     let module T = Tree_monadizer(struct
+ *       type env = int -> int;;
+ *       type 'a m = env -> 'a;;
+ *       let unit a : 'a m = fun e -> a;;
+ *       let bind (u : 'a m) (f : 'a -> 'b m) : 'b m =
+ *         fun e -> f (u e) e;;
+ *     end) in
+ *     T.monadize asker t1 env;;
+ *)
+
+
+(* square each leaf *)
+let env = fun i -> i * i in
+TreeReader.monadize asker t1 env;;
+
+
+
+(* count leaves *)
+
+let incrementer : int -> int State_monad.m =
+  fun (a : int) -> fun s -> (a, s+1);;
+(* incrementer takes an 'a and returns it wrapped in a
+ * State monad that increments the store *)
+
+let initial_store = 0 in
+TreeState.monadize incrementer t1 initial_store;;
+
+(* annotate leaves as they're visited *)
+
+let annotater : int -> (int * int) State_monad.m =
+  fun (a : int) -> fun s -> ((a,s+1), s+1);;
+
+let initial_store = 0 in
+TreeState.monadize annotater t1 initial_store;;
+
+
+(* copy tree with different choices for leaves *)
+
+let chooser i = if i = 2 then [20; 21] else [i];;
+
+TreeList.monadize chooser t1;;
+
+
+
+(* do nothing *)
+let initial_continuation = fun t -> t in
+TreeCont.monadize Continuation_monad.unit t1 initial_continuation;;
+
+(* convert tree to list of leaves *)
+let initial_continuation = fun t -> [] in
+TreeCont.monadize (fun a k -> a :: k a) t1 initial_continuation;;
+
+(* square each leaf using continuation *)
+let initial_continuation = fun t -> t in
+TreeCont.monadize (fun a k -> k (a*a)) t1 initial_continuation;;
+
+(* count leaves, using continuation *)
+let initial_continuation = fun t -> 0 in
+TreeCont.monadize (fun a k -> 1 + k a) t1 initial_continuation;;
+
+