X-Git-Url: http://lambda.jimpryor.net/git/gitweb.cgi?p=lambda.git;a=blobdiff_plain;f=code%2Fmonad.ml;fp=code%2Fmonad.ml;h=79dbf4f69980480b14fd35e2313ce87e72568016;hp=0000000000000000000000000000000000000000;hb=59a91510110916c1467d62f70828c53fb7c96bc3;hpb=f444e1009ca1e0a55bc058d05955fbe3dd39bcea

diff --git a/code/monad.ml b/code/monad.ml
new file mode 100644
index 00000000..79dbf4f6
--- /dev/null
+++ b/code/monad.ml
@@ -0,0 +1,1134 @@
+(* This version from 1 April 2015 *)
+
+module Monad = struct
+
+  module type MAPPABLE = sig
+    type 'a t
+    val map : ('a -> 'b) -> 'a t -> 'b t
+    (* mapconst is definable as map % const. For example mapconst 4 [1,2,3] == [4,4,4]. Haskell calls mapconst <$ in Data.Functor and Control.Applicative. They also use $> for flip mapconst, and Control.Monad.void for mapconst (). *)
+  end
+
+  module type APPLICATIVE = sig
+    include MAPPABLE
+    val mid : 'a -> 'a t
+    val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
+    val mapply : ('a -> 'b) t -> 'a t -> 'b t
+    val (>>) : 'a t -> 'b t -> 'b t
+    val (<<) : 'a t -> 'b t -> 'a t
+  end
+
+  module type MONAD = sig
+    include APPLICATIVE
+    type 'a result
+    val run : 'a t -> 'a result
+    val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+    val (>=>) : ('a -> 'b t) -> ('b -> 'c t) -> ('a -> 'c t)
+    val (<=<) : ('b -> 'c t) -> ('a -> 'b t) -> ('a -> 'c t)
+    val join : 'a t t -> 'a t
+    val ignore : 'a t -> unit t
+    val seq : 'a t list -> 'a list t
+    val seq_ignore : unit t list -> unit t
+    val do_when : bool -> unit t -> unit t
+    val do_unless : bool -> unit t -> unit t
+  end
+
+  module type MONADT = sig
+    include MONAD
+    type 'a ut
+    val hoist : 'a ut -> 'a t
+  end
+
+  module type MONADZERO = sig
+    include MONAD
+    (* mzero is a value of type α that is exemplified by Nothing for the box type Maybe α and by [] for the box type List α. It has the behavior that anything ¢ mzero == mzero == mzero ¢ anything == mzero >>= anything. In Haskell, this notion is called Control.Applicative.empty or Control.Monad.mzero. *)
+    val mzero : 'a t
+    val guard : bool -> unit t
+  end
+
+  module type MONADZEROT = sig
+    include MONADZERO
+    type 'a ut
+    val hoist : 'a ut -> 'a t
+  end
+
+  module type MAPPABLE2 = sig
+    type ('a,'d) t
+    val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t
+  end
+
+  module type APPLICATIVE2 = sig
+    include MAPPABLE2
+    val mid : 'a -> ('a,'d) t
+    val map2 : ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t
+    val mapply : ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t
+    val (>>) : ('a,'d) t -> ('b,'d) t -> ('b,'d) t
+    val (<<) : ('a,'d) t -> ('b,'d) t -> ('a,'d) t
+  end
+
+  module type MONAD2 = sig
+    include APPLICATIVE2
+    type ('a,'d) result
+    val run : ('a,'d) t -> ('a,'d) result
+    val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
+    val (>=>) : ('a -> ('b,'d) t) -> ('b -> ('c,'d) t) -> ('a -> ('c,'d) t)
+    val (<=<) : ('b -> ('c,'d) t) -> ('a -> ('b,'d) t) -> ('a -> ('c,'d) t)
+    val join : (('a,'d) t,'d) t -> ('a,'d) t
+    val ignore : ('a,'d) t -> (unit,'d) t
+    val seq : ('a,'d) t list -> ('a list,'d) t
+    val seq_ignore : (unit,'d) t list -> (unit,'d) t
+    val do_when : bool -> (unit,'d) t -> (unit,'d) t
+    val do_unless : bool -> (unit,'d) t -> (unit,'d) t
+  end
+
+  module type MONAD2T = sig
+    include MONAD2
+    type ('a,'d) ut
+    val hoist : ('a,'d) ut -> ('a,'d) t
+  end
+
+  module type MONADZERO2 = sig
+    include MONAD2
+    val mzero : ('a,'d) t
+    val guard : bool -> (unit,'d) t
+  end
+
+  module type MONADZERO2T = sig
+    include MONADZERO2
+    type ('a,'d) ut
+    val hoist : ('a,'d) ut -> ('a,'d) t
+  end
+
+  module Make = struct
+
+    module type MAP2 = sig
+      type 'a t
+      val mid : 'a -> 'a t
+      val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
+      val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
+      val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
+    end
+
+    module type MAPPLY = sig
+      type 'a t
+      val mid : 'a -> 'a t
+      val mapply : ('a -> 'b) t -> 'a t -> 'b t
+      val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
+    end
+
+    module type BIND = sig
+      type 'a t
+      type 'a result
+      val run : 'a t -> 'a result
+      val mid : 'a -> 'a t
+      val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+      val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
+      val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
+    end
+
+    module type COMP = sig
+      type 'a t
+      type 'a result
+      val run : 'a t -> 'a result
+      val mid : 'a -> 'a t
+      val (>=>) : ('a -> 'b t) -> ('b -> 'c t) -> ('a -> 'c t)
+      val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t]
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
+      val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
+    end
+
+    module type JOIN = sig
+      type 'a t
+      type 'a result
+      val run : 'a t -> 'a result
+      val mid : 'a -> 'a t
+      val join : 'a t t -> 'a t
+      val map : ('a -> 'b) -> 'a t -> 'b t
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t]
+      val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t]
+    end
+
+    module type TRANS = sig
+      module U : MONAD
+      type 'a t
+      type 'a result
+      val run : 'a t -> 'a result
+      (* Provide hoist, >>=; LAWS: 1. hoist U.(mid x) == mid x; 2. hoist U.(uu >>= k) == hoist uu >>= fun u -> hoist (k u) *)
+      val hoist : 'a U.t -> 'a t
+      val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+    end
+
+    module type TRANSUZ = sig
+      module U : MONADZERO
+      type 'a t
+      type 'a result
+      val run : 'a t -> 'a result
+      val hoist : 'a U.t -> 'a t
+      val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+    end
+
+    module type TRANSZ = sig
+      module U : MONAD
+      type 'a t
+      type 'a result
+      val run : 'a t -> 'a result
+      val hoist : 'a U.t -> 'a t
+      val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+      val mzero : 'a t
+    end
+
+    module ApplicativeFromBind(B : BIND) : APPLICATIVE with type 'a t = 'a B.t = struct
+      type 'a t = 'a B.t
+      let mid = B.mid
+      let (>>=) = B.(>>=)
+      let map = match B.map with
+      | `Custom map -> map
+      | `Generate -> fun f xx -> xx >>= fun x -> mid (f x)
+      let map2 = match B.map2 with
+      | `Custom map2 -> map2
+      | `Generate -> fun f xx yy -> xx >>= fun x -> yy >>= fun y -> mid (f x y)
+      let mapply = match B.map2 with
+      | `Custom map2 -> fun eta -> map2 ident eta
+      | `Generate -> fun ff xx -> ff >>= fun f -> map f xx
+      let (>>) xx yy = xx >>= fun _ -> yy
+      let (<<) xx yy = mapply (map const xx) yy
+    end
+
+    module ApplicativeFromMap2(B : MAP2) : APPLICATIVE with type 'a t = 'a B.t = struct
+      type 'a t = 'a B.t
+      let mid = B.mid
+      let map2 = B.map2
+      let mapply = match B.mapply with
+      | `Custom mapply -> mapply
+      | `Generate -> fun eta -> map2 ident eta
+      let map = match B.map with
+      | `Custom map -> map
+      | `Generate -> fun f xx -> mapply (mid f) xx
+      let (>>) xx yy = mapply (map (const ident) xx) yy
+      let (<<) xx yy = mapply (map const xx) yy
+    end
+
+    module ApplicativeFromApply(B : MAPPLY) : APPLICATIVE with type 'a t = 'a B.t = struct
+      type 'a t = 'a B.t
+      let mid = B.mid
+      let mapply = B.mapply
+      let map = match B.map with
+      | `Custom map -> map
+      | `Generate -> fun f xx -> mapply (mid f) xx
+      let map2 = match B.map2 with
+      | `Custom map2 -> map2
+      | `Generate -> fun f xx yy -> mapply (map f xx) yy
+      let (>>) xx yy = mapply (map (const ident) xx) yy
+      let (<<) xx yy = mapply (map const xx) yy
+    end
+
+    module MonadFromBind(B : BIND) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
+      let (>>=) = B.(>>=)
+      include ApplicativeFromBind(B)
+      type 'a result = 'a B.result
+      let run = B.run
+      let (>=>) j k = fun a -> j a >>= k
+      let (<=<) k j = fun a -> j a >>= k
+      let join xxx = xxx >>= ident
+      let ignore xx = map (fun _ -> ()) xx
+      (* seq xxs = let f xx zzf = (xx >>=) . flip ((zzf.).(:)) in foldr f (return $) xxs [] *)
+      (* 
+         foldr' f z xs = foldl (\g x z -> g (f x z)) id xs z  -- foldr but evaluating from left?
+         foldl'' f z xs = foldr (\x g z -> g (f z x)) id xs z -- foldl but evaluating from right? these don't work
+         -- with foldr, evaluates left->right; with foldl the reverse
+         seq xxs =
+           let f c xx ret xs = xx >>= ret . c xs in -- careful! isn't fmap (c xs) xx because ret isn't (always) return
+           reverse <$> foldr (f $ flip (:)) return xxs []
+           -- or simply: foldr (f snoc) return xxs []
+      *)
+      let seq =
+        let rec aux xs = function
+        | [] -> mid (List.rev xs)
+        | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
+        fun xxs -> aux [] xxs
+      let rec seq_ignore = function
+        | [] -> mid ()
+        | xx::xxs -> xx >>= fun () -> seq_ignore xxs
+      let do_when res xx = if res then xx else mid ()
+      let do_unless res xx = if res then mid () else xx
+    end
+
+    module MonadFromComp(B : COMP) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
+      let (>=>) = B.(>=>)
+      let (<=<) k j = j >=> k
+      let (>>=) xx k = (ident >=> k) xx
+      include ApplicativeFromBind(struct include B let (>>=) = (>>=) end)
+      type 'a result = 'a B.result
+      let run = B.run
+      let join xxx = xxx >>= ident
+      let ignore xx = map (fun _ -> ()) xx
+      let seq =
+        let rec aux xs = function
+        | [] -> mid (List.rev xs)
+        | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
+        fun xxs -> aux [] xxs
+      let rec seq_ignore = function
+        | [] -> mid ()
+        | xx::xxs -> xx >>= fun () -> seq_ignore xxs
+      let do_when res xx = if res then xx else mid ()
+      let do_unless res xx = if res then mid () else xx
+    end
+
+    module MonadFromJoin(B : JOIN) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct
+      let join = B.join
+      let (>>=) xx k = join (B.map k xx)
+      include ApplicativeFromBind(struct include B let (>>=) = (>>=) let map = `Custom B.map end)
+      type 'a result = 'a B.result
+      let run = B.run
+      let (>=>) j k = fun a -> j a >>= k
+      let (<=<) k j = fun a -> j a >>= k
+      let ignore xx = map (fun _ -> ()) xx
+      let seq =
+        let rec aux xs = function
+        | [] -> mid (List.rev xs)
+        | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
+        fun xxs -> aux [] xxs
+      let rec seq_ignore = function
+        | [] -> mid ()
+        | xx::xxs -> xx >>= fun () -> seq_ignore xxs
+      let do_when res xx = if res then xx else mid ()
+      let do_unless res xx = if res then mid () else xx
+    end
+
+    module MonadFromT(B : TRANS) : MONADT with type 'a t = 'a B.t and type 'a ut := 'a B.U.t and type 'a result = 'a B.result = struct
+      include MonadFromBind(struct
+        include B
+        let mid x = hoist U.(mid x)
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+      end)
+      let hoist = B.hoist
+    end
+
+    module MonadFromTUZ(B : TRANSUZ) : MONADZEROT with type 'a t = 'a B.t and type 'a ut := 'a B.U.t and type 'a result = 'a B.result = struct
+      let mzero = Obj.magic (B.hoist (B.U.mzero)) (* Obj.magic hack to generate enough polymorphism without having to thunk mzero *)
+      include MonadFromBind(struct
+        include B
+        let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero
+        let mid x = hoist U.(mid x)
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+      end)
+      let hoist = B.hoist
+      let guard res = if res then mid () else mzero
+    end
+
+    module MonadFromTZ(B : TRANSZ) : MONADZEROT with type 'a t = 'a B.t and type 'a ut := 'a B.U.t and type 'a result = 'a B.result = struct
+      include MonadFromBind(struct
+        include B
+        let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero
+        let mid x = hoist U.(mid x)
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+      end)
+      let hoist = B.hoist
+      let mzero = B.mzero
+      let guard res = if res then mid () else mzero
+    end
+
+    module type BIND2 = sig
+      type ('a,'d) t
+      type ('a,'d) result
+      val run : ('a,'d) t -> ('a,'d) result
+      val mid : 'a -> ('a,'d) t
+      val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
+      val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
+      val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
+    end
+
+    module type COMP2 = sig
+      type ('a,'d) t
+      type ('a,'d) result
+      val run : ('a,'d) t -> ('a,'d) result
+      val mid : 'a -> ('a,'d) t
+      val (>=>) : ('a -> ('b,'d) t) -> ('b -> ('c,'d) t) -> ('a -> ('c,'d) t)
+      val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
+      val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
+    end
+
+    module type JOIN2 = sig
+      type ('a,'d) t
+      type ('a,'d) result
+      val run : ('a,'d) t -> ('a,'d) result
+      val mid : 'a -> ('a,'d) t
+      val join : (('a,'d) t,'d) t -> ('a,'d) t
+      val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
+      val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
+    end
+
+    module type TRANS2 = sig
+      module U : MONAD2
+      type ('a,'d) t
+      type ('a,'d) result
+      val run : ('a,'d) t -> ('a,'d) result
+      val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
+      val hoist : ('a,'d) U.t -> ('a,'d) t
+    end
+
+    module type TRANSUZ2 = sig
+      module U : MONADZERO2
+      type ('a,'d) t
+      type ('a,'d) result
+      val run : ('a,'d) t -> ('a,'d) result
+      val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
+      val hoist : ('a,'d) U.t -> ('a,'d) t
+    end
+
+    module type TRANSZ2 = sig
+      module U : MONAD2
+      type ('a,'d) t
+      type ('a,'d) result
+      val run : ('a,'d) t -> ('a,'d) result
+      val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t
+      val hoist : ('a,'d) U.t -> ('a,'d) t
+      val mzero : ('a,'d) t
+    end
+
+    module type MAP22 = sig
+      type ('a,'d) t
+      val mid : 'a -> ('a,'d) t
+      val map2 : ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t
+      val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
+      val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t]
+    end
+
+    module type MAPPLY2 = sig
+      type ('a,'d) t
+      val mid : 'a -> ('a,'d) t
+      val mapply : ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t
+      val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t]
+      val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t]
+    end
+
+    module Applicative2FromBind(B : BIND2) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
+      type ('a,'d) t = ('a,'d) B.t
+      let mid = B.mid
+      let (>>=) = B.(>>=)
+      let map = match B.map with
+      | `Custom map -> map
+      | `Generate -> fun f xx -> xx >>= fun x -> mid (f x)
+      let map2 = match B.map2 with
+      | `Custom map2 -> map2
+      | `Generate -> fun f xx yy -> xx >>= fun x -> yy >>= fun y -> mid (f x y)
+      let mapply = match B.map2 with
+      | `Custom map2 -> fun eta -> map2 ident eta
+      | `Generate -> fun ff xx -> ff >>= fun f -> map f xx
+      let (>>) xx yy = xx >>= fun _ -> yy
+      let (<<) xx yy = mapply (map const xx) yy
+    end
+
+    module Applicative2FromMap2(B : MAP22) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
+      type ('a,'d) t = ('a,'d) B.t
+      let mid = B.mid
+      let map2 = B.map2
+      let mapply = match B.mapply with
+      | `Custom mapply -> mapply
+      | `Generate -> fun eta -> map2 ident eta
+      let map = match B.map with
+      | `Custom map -> map
+      | `Generate -> fun f xx -> mapply (mid f) xx
+      let (>>) xx yy = mapply (map (const ident) xx) yy
+      let (<<) xx yy = mapply (map const xx) yy
+    end
+
+    module Applicative2FromApply(B : MAPPLY2) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct
+      type ('a,'d) t = ('a,'d) B.t
+      let mid = B.mid
+      let mapply = B.mapply
+      let map = match B.map with
+      | `Custom map -> map
+      | `Generate -> fun f xx -> mapply (mid f) xx
+      let map2 = match B.map2 with
+      | `Custom map2 -> map2
+      | `Generate -> fun f xx yy -> mapply (map f xx) yy
+      let (>>) xx yy = mapply (map (const ident) xx) yy
+      let (<<) xx yy = mapply (map const xx) yy
+    end
+
+    module Monad2FromBind(B : BIND2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
+      let (>>=) = B.(>>=)
+      include Applicative2FromBind(B)
+      type ('a,'d) result = ('a,'d) B.result
+      let run = B.run
+      let (>=>) j k = fun a -> j a >>= k
+      let (<=<) k j = fun a -> j a >>= k
+      let join xxx = xxx >>= ident
+      let ignore xx = map (fun _ -> ()) xx
+      let seq =
+        let rec aux xs = function
+        | [] -> mid (List.rev xs)
+        | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
+        fun xxs -> aux [] xxs
+      let rec seq_ignore = function
+        | [] -> mid ()
+        | xx::xxs -> xx >>= fun () -> seq_ignore xxs
+      let do_when res xx = if res then xx else mid ()
+      let do_unless res xx = if res then mid () else xx
+    end
+
+    module Monad2FromComp(B : COMP2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
+      let (>=>) = B.(>=>)
+      let (<=<) k j = j >=> k
+      let (>>=) xx k = (ident >=> k) xx
+      include Applicative2FromBind(struct include B let (>>=) = (>>=) end)
+      type ('a,'d) result = ('a,'d) B.result
+      let run = B.run
+      let join xxx = xxx >>= ident
+      let ignore xx = map (fun _ -> ()) xx
+      let seq =
+        let rec aux xs = function
+        | [] -> mid (List.rev xs)
+        | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
+        fun xxs -> aux [] xxs
+      let rec seq_ignore = function
+        | [] -> mid ()
+        | xx::xxs -> xx >>= fun () -> seq_ignore xxs
+      let do_when res xx = if res then xx else mid ()
+      let do_unless res xx = if res then mid () else xx
+    end
+
+    module Monad2FromJoin(B : JOIN2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct
+      let join = B.join
+      let (>>=) xx k = join (B.map k xx)
+      include Applicative2FromBind(struct include B let (>>=) = (>>=) let map = `Custom B.map end)
+      type ('a,'d) result = ('a,'d) B.result
+      let run = B.run
+      let (>=>) j k = fun a -> j a >>= k
+      let (<=<) k j = fun a -> j a >>= k
+      let ignore xx = map (fun _ -> ()) xx
+      let seq =
+        let rec aux xs = function
+        | [] -> mid (List.rev xs)
+        | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in
+        fun xxs -> aux [] xxs
+      let rec seq_ignore = function
+        | [] -> mid ()
+        | xx::xxs -> xx >>= fun () -> seq_ignore xxs
+      let do_when res xx = if res then xx else mid ()
+      let do_unless res xx = if res then mid () else xx
+    end
+
+    module Monad2FromT(B : TRANS2) : MONAD2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct
+      include Monad2FromBind(struct
+        include B
+        let mid x = hoist U.(mid x)
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+      end)
+      let hoist = B.hoist
+    end
+
+    module Monad2FromTUZ(B : TRANSUZ2) : MONADZERO2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct
+      include Monad2FromBind(struct
+        include B
+        let mid x = hoist U.(mid x)
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+      end)
+      let hoist = B.hoist
+      let mzero = Obj.magic (B.hoist (B.U.mzero)) (* Obj.magic hack to generate enough polymorphism without having to thunk mzero *)
+      let guard res = if res then mid () else mzero
+    end
+
+    module Monad2FromTZ(B : TRANSZ2) : MONADZERO2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct
+      include Monad2FromBind(struct
+        include B
+        let mid x = hoist U.(mid x)
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+      end)
+      let hoist = B.hoist
+      let mzero = B.mzero
+      let guard res = if res then mid () else mzero
+    end
+
+  end (* Make *)
+
+
+
+  module Option = struct
+    include Juli8.Option
+    module type EXTRA = sig
+      type 'a t
+      val test : ('a option (* U.t *) -> bool) -> 'a t -> 'a t
+    end
+    module type EXTRA2 = sig
+      type ('a,'d) t
+      val test : ('a option -> bool) -> ('a,'d) t -> ('a,'d) t
+    end
+    module M : sig
+      include MONADZERO with type 'a result = 'a option
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = 'a option
+        type 'a result = 'a t let run xx = xx
+        let map = `Custom map let map2 = `Custom map2 let mapply = `Generate
+        let mid = some
+        (* val (>>=) : 'a option -> ('a -> 'b option) -> 'b option *)
+        let (>>=) xx k = match xx with Some x -> (try k x with Match_failure _ -> None) | None -> None
+      end)
+      let mzero = None
+      let guard res : unit t = if res then Some () else None
+      let test p xx = if p xx then xx else None
+    end (* Option.M *)
+    module M2 : sig
+      include MONADZERO2 with type ('a,'d) result = 'a option
+      include EXTRA2 with type ('a,'d) t := ('a,'d) t
+    end = struct
+      include Make.Monad2FromBind(struct
+        type ('a,'d) t = 'a option
+        type ('a,'d) result = ('a,'d) t let run xx = xx
+        let map = `Custom map let map2 = `Custom map2 let mapply = `Generate
+        let mid = some
+        let (>>=) xx k = match xx with Some x -> (try k x with Match_failure _ -> None) | None -> None
+      end)
+      let mzero = None
+      let guard res : (unit,'d) t = if res then Some () else None
+      let test p xx = if p xx then xx else None
+    end (* Option.M2 *)
+    module T(U : MONAD) : sig
+      include MONADZEROT with type 'a result = 'a option U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+      val test : ('a option U.t -> bool) -> 'a t -> 'a t
+    end = struct
+      include Make.MonadFromTZ(struct
+        module U = U
+        type 'a t = 'a option U.t
+        type 'a result = 'a option U.result let run xx = U.run xx
+        let hoist uu = U.(uu >>= fun u -> mid (Some u)) 
+        let (>>=) xx k = U.(xx >>= function Some x -> k x | None -> mid None)
+        let mzero = Obj.magic U.(mid None)
+      end)
+      let test p xx = if p xx then xx else U.mid None
+    end (* Option.T *)
+    module T2(U : MONAD2) : sig
+      include MONADZERO2T with type ('a,'d) result = ('a option, 'd) U.result and type ('a,'d) ut := ('a,'d) U.t
+      include EXTRA2 with type ('a,'d) t := ('a,'d) t
+      val test : (('a option,'d) U.t -> bool) -> ('a,'d) t -> ('a,'d) t
+    end = struct
+      include Make.Monad2FromTZ(struct
+        module U = U
+        type ('a,'d) t = ('a option,'d) U.t
+        type ('a,'d) result = ('a option,'d) U.result let run xx = U.run xx
+        let hoist uu = U.(uu >>= fun u -> mid (Some u)) 
+        let (>>=) xx k = U.(xx >>= function Some x -> k x | None -> mid None)
+        let mzero = Obj.magic U.(mid None)
+      end)
+      let test p xx = if p xx then xx else U.mid None
+    end (* Option.T2 *)
+  end (* Option *)
+
+  module List = struct
+    include Juli8.List
+    module type EXTRA = sig
+      type 'a t
+      val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
+      val pick : 'a t -> ('a * 'a t) t (* monadically pick each element *)
+      val test : ('a list (* U.t *) -> bool) -> 'a t -> 'a t
+    end
+    module type EXTRA2 = sig
+      type ('a,'d) t
+      val (++) : ('a,'d) t -> ('a,'d) t -> ('a,'d) t
+      val pick : ('a,'d) t -> ('a * ('a,'d) t,'d) t
+      val test : ('a list -> bool) -> ('a,'d) t -> ('a,'d) t
+    end
+    module M : sig
+      include MONADZERO with type 'a result = 'a list
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = 'a list
+        type 'a result = 'a t let run xx = xx
+        let map = `Custom (fun f xs -> map f xs) let map2 = `Custom (fun f xs -> map2 f xs) let mapply = `Generate
+        let mid = singleton
+        let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx
+      end)
+      let mzero = []
+      let guard res : unit t = if res then [()] else []
+      (* (++) has tighter precedence than (>>=) *)
+      let (++) = append
+      let rec pick = function [] -> mzero | x::xs -> mid (x,xs) ++ (pick xs >>= fun (y,ys) -> mid (y, x::ys))
+      let test p xx = if p xx then xx else []
+    end (* List.M *)
+    module M2 : sig
+      include MONADZERO2 with type ('a,'d) result = 'a list
+      include EXTRA2 with type ('a,'d) t := ('a,'d) t
+    end = struct
+      include Make.Monad2FromBind(struct
+        type ('a,'d) t = 'a list
+        type ('a,'d) result = ('a,'d) t let run xx = xx
+        let map = `Custom (fun f xs -> map f xs) let map2 = `Custom (fun f xs -> map2 f xs) let mapply = `Generate
+        let mid = singleton
+        let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx
+      end)
+      let mzero = []
+      let guard res : (unit,'d) t = if res then [()] else []
+      let (++) = append
+      let rec pick = function [] -> mzero | x::xs -> mid (x,xs) ++ (pick xs >>= fun (y,ys) -> mid (y, x::ys))
+      let test p xx = if p xx then xx else []
+    end (* List.M2 *)
+    module T(U : MONAD) : sig
+      include MONADZEROT with type 'a result = 'a list U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+      val test : ('a list U.t -> bool) -> 'a t -> 'a t
+      (*
+          Monadically seq k over box<a>.
+          OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running)
+          ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...]
+          TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly
+      *)
+      val distribute : ('a -> 'b U.t) -> 'a list -> 'b t
+    end = struct
+      let distribute k xs = U.seq (List.map k xs)
+      include Make.MonadFromTZ(struct
+        module U = U
+        type 'a t = 'a list U.t
+        type 'a result = 'a list U.result let run xx = U.run xx
+        let hoist uu = U.(uu >>= fun u -> mid [u]) 
+        let (>>=) xx k = U.(xx >>= fun xs -> distribute k xs >>= fun xss -> mid (concat xss))
+        let mzero = Obj.magic U.(mid [])
+      end)
+      let (++) xx yy = U.(xx >>= fun xs -> yy >>= fun ys -> mid (append xs ys))
+      let rec pick xx = U.(>>=) xx (function [] -> mzero | x::xs -> mid (x, U.(mid xs)) ++ (pick U.(mid xs) >>= fun (y,yy) -> mid (y, U.(yy >>= fun ys -> mid (x::ys)))))
+      let test p xx = if p xx then xx else U.mid []
+    end (* List.T *)
+    module T2(U : MONAD2) : sig
+      include MONADZERO2T with type ('a,'d) result = ('a list,'d) U.result and type ('a,'d) ut := ('a,'d) U.t
+      include EXTRA2 with type ('a,'d) t := ('a,'d) t
+      val test : (('a list,'d) U.t -> bool) -> ('a,'d) t -> ('a,'d) t
+      val distribute : ('a -> ('b,'d) U.t) -> 'a list -> ('b,'d) t
+    end = struct
+      let distribute k xs = U.seq (List.map k xs)
+      include Make.Monad2FromTZ(struct
+        module U = U
+        type ('a,'d) t = ('a list,'d) U.t
+        type ('a,'d) result = ('a list,'d) U.result let run xx = U.run xx
+        let hoist uu = U.(uu >>= fun u -> mid [u]) 
+        let (>>=) xx k = U.(xx >>= fun xs -> distribute k xs >>= fun xss -> mid (concat xss))
+        let mzero = Obj.magic U.(mid [])
+      end)
+      let (++) xx yy = U.(xx >>= fun xs -> yy >>= fun ys -> mid (append xs ys))
+      let rec pick xx = U.(>>=) xx (function [] -> mzero | x::xs -> mid (x, U.(mid xs)) ++ (pick U.(mid xs) >>= fun (y,yy) -> mid (y, U.(yy >>= fun ys -> mid (x::ys)))))
+      let test p xx = if p xx then xx else U.mid []
+    end (* List.T2 *)
+  end (* List *)
+
+
+  (* LTree, unit centers, has natural ++ *)
+  (* ITree, unit leaves, has natural mzero *)
+
+  module LTree = struct
+    type 'a tree = Leaf of 'a | Branch of 'a tree * 'a tree
+    let branch x y = Branch(x,y)
+    let leaf x = Leaf x
+    let traverse ((++) : 'b -> 'b -> 'b) (k : 'a -> 'b) (xt : 'a tree) : 'b =
+      let rec aux = function
+      | Leaf x -> k x
+      | Branch(l, r) -> (* recursive application of k may delete a branch? *) aux l ++ aux r in
+      aux xt
+    let map (f : 'a -> 'b) (xt : 'a tree) =
+      let rec aux = function
+      | Leaf x -> Leaf (f x)
+      | Branch(l, r) -> Branch(aux l, aux r) in
+      aux xt
+    module type EXTRA = sig
+      type 'a t
+      val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
+    end
+    module M : sig
+      include MONAD with type 'a result = 'a tree
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = 'a tree
+        type 'a result = 'a t let run xx = xx
+        let map = `Custom map let map2 = `Generate let mapply = `Generate
+        let mid = leaf
+        let (>>=) xx k = traverse branch k xx
+      end)
+      let (++) xx yy = Branch(xx, yy)
+    end (* Tree.M *)
+    module T(U : MONAD) : sig
+      include MONADT with type 'a result = 'a tree U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+      (*
+          Monadically seq k over box<a>.
+          OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running)
+          ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...]
+          TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly
+      *)
+      val distribute : ('a -> 'b U.t) -> 'a tree -> 'b t
+    end = struct
+      let hoist uu = U.(uu >>= fun u -> mid (Leaf u)) 
+      let distribute k xt = traverse (U.map2 branch) (fun x -> hoist (k x)) xt
+      include Make.MonadFromT(struct
+        module U = U
+        type 'a t = 'a tree U.t
+        type 'a result = 'a tree U.result let run xx = U.run xx
+        let hoist = hoist
+        let join xtt = traverse branch ident xtt
+        let (>>=) xx k = U.(>>=) xx (fun xt -> U.(>>=) (distribute k xt) (fun xtt -> U.mid (join xtt)))
+      end)
+      let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
+    end (* Tree.T *)
+    module Z(U : MONADZERO) : sig
+      include MONADZEROT with type 'a result = 'a tree U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+      val distribute : ('a -> 'b U.t) -> 'a tree -> 'b t
+    end = struct
+      let hoist uu = U.(uu >>= fun u -> mid (Leaf u)) 
+      let distribute k xt = traverse (U.map2 branch) (fun x -> hoist (k x)) xt
+      include Make.MonadFromTUZ(struct
+        module U = U
+        type 'a t = 'a tree U.t
+        type 'a result = 'a tree U.result let run xx = U.run xx
+        let hoist = hoist
+        let join xtt = traverse branch ident xtt
+        let (>>=) xx k = U.(>>=) xx (fun xt -> U.(>>=) (distribute k xt) (fun xtt -> U.mid (join xtt)))
+      end)
+      let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
+    end (* Tree.Z *)
+  end (* Tree *)
+
+
+  module Identity = struct
+    module M : sig
+      include MONAD with type 'a result = 'a
+    end = struct
+      include Make.MonadFromComp(struct
+        type 'a t = 'a
+        type 'a result = 'a t let run xx = xx
+        let map = `Custom (fun f x -> f x) let map2 = `Custom (fun f x y -> f x y) let mapply = `Custom (fun f x -> f x)
+        let mid = ident
+        let (>=>) j k = fun x -> k (j x)
+      end)
+    end
+  end
+
+  (* must be parameterized on `struct type env = ... end` *)
+  module Reader(E : sig type env end) = struct
+    type env = E.env
+    module type EXTRA = sig
+      type 'a t
+      val ask : env t
+      val asks : (env -> 'a) -> 'a t
+      val shift : (env -> env) -> 'a t -> 'a t
+    end
+    module M : sig
+      include MONAD with type 'a result = env -> 'a
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = env -> 'a
+        type 'a result = 'a t let run xx = fun e -> xx e
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+        let mid x = fun e -> x
+        let (>>=) xx k = fun e -> let x = xx e in let xx' = k x in xx' e
+      end)
+      let ask = fun e -> e
+      let asks selector = ask >>= (fun e -> mid (selector e)) (* may fail with Not_found *)
+      let shift modifier xx = fun e -> xx (modifier e)
+    end (* Reader.M *)
+    module T(U : MONAD) : sig
+      include MONADT with type 'a result = env -> 'a U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromT(struct
+        module U = U
+        type 'a t = env -> 'a U.t
+        type 'a result = env -> 'a U.result let run xx = fun e -> U.run (xx e)
+        let hoist uu = fun e -> uu
+        let (>>=) xx k = fun e -> U.(xx e >>= fun x -> k x e)
+      end)
+      let ask = U.mid
+      let asks selector = ask >>= (fun e -> mid (selector e)) (* may fail with Not_found *)
+      let shift modifier xx = fun e -> xx (modifier e)
+    end (* Reader.T *)
+    module Z(U : MONADZERO) : sig
+      include MONADZEROT with type 'a result = env -> 'a U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromTUZ(struct
+        module U = U
+        type 'a t = env -> 'a U.t
+        type 'a result = env -> 'a U.result let run xx = fun e -> U.run (xx e)
+        let hoist uu = fun e -> uu
+        let (>>=) xx k = fun e -> U.(xx e >>= fun x -> k x e)
+      end)
+      let ask = U.mid
+      let asks selector = ask >>= (fun e -> try mid (selector e) with Not_found -> mzero)
+      let shift modifier xx = fun e -> xx (modifier e)
+    end (* Reader.Z *)
+  end (* Reader *)
+
+  (* must be parameterized on `struct type store = ... end` *)
+  module State(S : sig type store end) = struct
+    type store = S.store
+    module type EXTRA = sig
+      type 'a t
+      val get : store t
+      val gets : (store -> 'a) -> 'a t
+      val put : store -> unit t
+      val modify : (store -> store) -> unit t
+    end
+    module M : sig
+      include MONAD with type 'a result = store -> 'a * store
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = store -> 'a * store
+        type 'a result = 'a t let run xx = fun s -> xx s
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+        let mid x = fun s -> x, s
+        let (>>=) xx k = fun s -> let (x,s') = xx s in let xx' = k x in xx' s'
+      end)
+      let get = fun s -> s,s
+      (* `gets viewer` is `map viewer get` *)
+      let gets viewer = fun s -> viewer s, s (* may fail with Not_found *)
+      let put s = fun _ -> (), s
+      let modify modifier = fun s -> (), modifier s
+    end (* State.M *)
+    module T(U : MONAD) : sig
+      include MONADT with type 'a result = store -> ('a * store) U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromT(struct
+        module U = U
+        type 'a t = store -> ('a * store) U.t
+        type 'a result = store -> ('a * store) U.result let run xx = fun s -> U.run (xx s)
+        let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
+        let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
+      end)
+      let get = fun s -> U.mid (s,s)
+      let gets viewer = fun s -> U.mid (viewer s, s) (* may fail with Not_found *)
+      let put s = fun _ -> U.mid ((), s)
+      let modify modifier = fun s -> U.mid ((), modifier s)
+    end (* State.T *)
+    module Z(U : MONADZERO) : sig
+      include MONADZEROT with type 'a result = store -> ('a * store) U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromTUZ(struct
+        module U = U
+        type 'a t = store -> ('a * store) U.t
+        type 'a result = store -> ('a * store) U.result let run xx = fun s -> U.run (xx s)
+        let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
+        let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
+      end)
+      let get = fun s -> U.mid (s,s)
+      let gets viewer = fun s -> try U.mid (viewer s, s) with Not_found -> mzero s
+      let put s = fun _ -> U.mid ((), s)
+      let modify modifier = fun s -> U.mid ((), modifier s)
+    end (* State.Z *)
+  end (* State *)
+
+  (* State with a different interface; must be parameterized on `struct type value = ... end` *)
+  module Ref(V : sig type value 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 v d = d.next, { next = succ d.next; tree = D.add d.next v d.tree}
+    let read (k : ref) d = D.find k d.tree
+    let write (k : ref) v d = { next = d.next; tree = D.add k v d.tree }
+    module type EXTRA = sig
+      type 'a t
+      val newref : value -> ref t
+      val deref : ref -> value t
+      val change : ref -> value -> unit t
+    end
+    module M : sig
+      include MONAD with type 'a result = 'a
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = dict -> 'a * dict
+        type 'a result = 'a let run xx = fst (xx empty)
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+        let mid x = fun s -> x, s
+        let (>>=) xx k = fun s -> let (x,s') = xx s in let xx' = k x in xx' s'
+      end)
+      let newref v = fun s -> alloc v s
+      let deref k = fun s -> read k s, s (* shouldn't fail because k will have an abstract type? and we never GC *)
+      let change k v = fun s -> (), write k v s (* shouldn't allocate because k will have an abstract type *)
+    end (* Ref.M *)
+    module T(U : MONAD) : sig
+      include MONADT with type 'a result = 'a U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromT(struct
+        module U = U
+        type 'a t = dict -> ('a * dict) U.t
+        type 'a result = 'a U.result let run xx = let uu = U.(xx empty >>= fun (x,s) -> mid x) in U.run uu
+        let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
+        let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
+      end)
+      let newref v = fun s -> U.mid (alloc v s)
+      let deref k = fun s -> U.mid (read k s, s)
+      let change k v = fun s -> U.mid ((), write k v s)
+    end (* Ref.T *)
+    module Z(U : MONADZERO) : sig
+      include MONADZEROT with type 'a result = 'a U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromTUZ(struct
+        module U = U
+        type 'a t = dict -> ('a * dict) U.t
+        type 'a result = 'a U.result let run xx = let uu = U.(xx empty >>= fun (x,s) -> mid x) in U.run uu
+        let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s))
+        let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s')
+      end)
+      let newref v = fun s -> U.mid (alloc v s)
+      let deref k = fun s -> U.mid (read k s, s)
+      let change k v = fun s -> U.mid ((), write k v s)
+    end (* Ref.Z *)
+  end (* Ref *)
+
+  (* must be parameterized on `struct type log = ... end` *)
+  module Writer(W : sig type log val empty : log val append : log -> log -> log end) = struct
+    type log = W.log
+    module type EXTRA = sig
+      type 'a t
+      val listen : 'a t -> ('a * log) t
+      val listens : (log -> 'b) -> 'a t -> ('a * 'b) t
+      val tell : log -> unit t
+      (* val pass : ('a * (log -> log)) t -> 'a t *)
+      val censor : (log -> log) -> 'a t -> 'a t
+    end
+    module M : sig
+      include MONAD with type 'a result = 'a * log
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = 'a * log
+        type 'a result = 'a t let run xx = xx
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+        let mid x = x, W.empty
+        let (>>=) (x,w) k = let (y,w') = k x in (y, W.append w w')
+      end)
+      let listen (x,w) = (x,w), w
+      let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w) (* filter listen through selector *)
+      let tell entries = (), entries (* add to log *)
+      let pass ((x,c),w) = (x, c w) (* usually use censor *)
+      let censor c xx = pass (xx >>= fun x -> mid (x,c)) (* ==> (x, c w) *)
+    end (* Writer.M *)
+    module T(U : MONAD) : sig
+      include MONADT with type 'a result = ('a * log) U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromT(struct
+        module U = U
+        type 'a t = ('a * log) U.t
+        type 'a result = ('a * log) U.result let run xx = U.run xx
+        let hoist uu = U.(uu >>= fun u -> mid (u, W.empty))
+        let (>>=) xx k = U.(xx >>= fun (x,w) -> k x >>= fun (y,w') -> mid (y, W.append w w'))
+      end)
+      let listen xx = U.(xx >>= fun (x,w) -> mid ((x,w),w))
+      let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w)
+      let tell entries = U.mid ((), entries)
+      let pass xx = U.(xx >>= fun ((x,c),w) -> mid (x, c w))
+      let censor c xx = pass (xx >>= fun x -> mid (x,c))
+    end (* Writer.T *)
+    module Z(U : MONADZERO) : sig
+      include MONADZEROT with type 'a result = ('a * log) U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromTUZ(struct
+        module U = U
+        type 'a t = ('a * log) U.t
+        type 'a result = ('a * log) U.result let run xx = U.run xx
+        let hoist uu = U.(uu >>= fun u -> mid (u, W.empty))
+        let (>>=) xx k = U.(xx >>= fun (x,w) -> k x >>= fun (y,w') -> mid (y, W.append w w'))
+      end)
+      let listen xx = U.(xx >>= fun (x,w) -> mid ((x,w),w))
+      let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w)
+      let tell entries = U.mid ((), entries)
+      let pass xx = U.(xx >>= fun ((x,c),w) -> mid (x, c w))
+      let censor c xx = pass (xx >>= fun x -> mid (x,c))
+    end (* Writer.Z *)
+  end (* Writer *)
+
+  (* must be parameterized on `struct type err = ... end` *)
+  module Error(E : sig type err exception Exc of err end) = struct
+    type err = E.err
+    type 'a error = Error of err | OK of 'a
+    module type EXTRA = sig
+      type 'a t
+      val throw : err -> 'a t
+      val catch : 'a t -> (err -> 'a t) -> 'a t
+    end
+    module M : sig
+      include MONAD with type 'a result = 'a error
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromBind(struct
+        type 'a t = 'a error
+        type 'a result = 'a t let run xx = xx
+        let map = `Generate let map2 = `Generate let mapply = `Generate
+        let mid x = OK x
+        let (>>=) xx k = match xx with OK x -> k x | Error e -> Error e
+      end)
+      let throw e = Error e
+      let catch xx handler = match xx with OK _ -> xx | Error e -> handler e
+    end (* Error.M *)
+    module T(U : MONAD) : sig
+      include MONADT with type 'a result = 'a U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromT(struct
+        module U = U
+        type 'a t = 'a error U.t
+        type 'a result = 'a U.result
+        let run xx = let uu = U.(xx >>= function OK x -> mid x | Error e -> raise (E.Exc e)) in U.run uu
+        let hoist uu = U.(uu >>= fun u -> mid (OK u)) 
+        let (>>=) xx k = U.(xx >>= function OK x -> k x | Error e -> mid (Error e))
+      end)
+      let throw e = U.mid (Error e)
+      let catch xx handler = U.(xx >>= function OK _ as x -> mid x | Error e -> handler e)
+    end (* Error.T *)
+    module Z(U : MONADZERO) : sig
+      include MONADZEROT with type 'a result = 'a U.result and type 'a ut := 'a U.t
+      include EXTRA with type 'a t := 'a t
+    end = struct
+      include Make.MonadFromTUZ(struct
+        module U = U
+        type 'a t = 'a error U.t
+        type 'a result = 'a U.result
+        (* we recover from error by using U's mzero; but this discards the error msg *)
+        let run xx = let uu = U.(xx >>= function OK x -> mid x | Error e -> mzero) in U.run uu
+        let hoist uu = U.(uu >>= fun u -> mid (OK u)) 
+        let (>>=) xx k = U.(xx >>= function OK x -> k x | Error e -> mid (Error e))
+      end)
+      let throw e = U.mid (Error e)
+      let catch xx handler = U.(xx >>= function OK _ as x -> mid x | Error e -> handler e)
+    end (* Error.Z *)
+  end (* Error *)
+
+  (* predefine some common instances *)
+
+  module Writer1 = Writer(struct type log = string let empty = "" let append s1 s2 = s1 ^ "\n" ^ s2 end)
+
+  module Writer2 = struct
+    include Writer(struct
+      type log = string list
+      let empty = []
+      let append s1 s2 = List.append s2 s1
+    end)
+    (* FIXME these aren't inside M *)
+    let tell_string s = M.tell [s]
+    let tell entries = M.tell (List.rev entries)
+    let run xx = let (x,w) = M.run xx in (x, List.rev w)
+  end
+
+  module Failure = Error(struct type err = string exception Exc = Failure end)
+
+end (* Monad *)
+
+module Option = Monad.Option
+module List = Monad.List
+