(* 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