Merge branch 'working'

[lambda.git] / code / monad.ml

diff --git a/code/monad.ml b/code/monad.ml
index 79dbf4f..f17d953 100644 (file)
--- a/code/monad.ml
+++ b/code/monad.ml
@@ -33,24 +33,28 @@ module Monad = struct
   end
 
   module type MONADT = sig
   end
 
   module type MONADT = sig

-    include MONAD

     type 'a ut
     type 'a ut

+    include MONAD

     val hoist : 'a ut -> 'a t
   end
 
     val hoist : 'a ut -> 'a t
   end
 

-  module type MONADZERO = sig
-    include MONAD
+  module type ZERO = sig
+    type 'a t

     (* 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
     (* 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 MONADZERO = sig
+    include MONAD
+    include ZERO with type 'a t := 'a t

   end
 
   module type MONADZEROT = sig
   end
 
   module type MONADZEROT = sig

-    include MONADZERO
-    type 'a ut
-    val hoist : 'a ut -> 'a t
+    include MONADT
+    include ZERO with type 'a t := 'a t

   end
   end

-
+    

   module type MAPPABLE2 = sig
     type ('a,'d) t
     val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t
   module type MAPPABLE2 = sig
     type ('a,'d) t
     val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t


@@ -296,7 +300,7 @@ module Monad = struct
       let do_unless res xx = if res then mid () else xx
     end
 
       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
+    module MonadFromT(B : TRANS) : MONADT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = struct

       include MonadFromBind(struct
         include B
         let mid x = hoist U.(mid x)
       include MonadFromBind(struct
         include B
         let mid x = hoist U.(mid x)


@@ -305,7 +309,7 @@ module Monad = struct
       let hoist = B.hoist
     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
+    module MonadFromTUZ(B : TRANSUZ) : MONADZEROT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = 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 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


@@ -317,7 +321,7 @@ module Monad = struct
       let guard res = if res then mid () else mzero
     end
 
       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
+    module MonadFromTZ(B : TRANSZ) : MONADZEROT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = struct

       include MonadFromBind(struct
         include B
         let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero
       include MonadFromBind(struct
         include B
         let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero


@@ -548,7 +552,17 @@ module Monad = struct
   end (* Make *)
 
 
   end (* Make *)
 
 

+  module type OPTION = sig
+    include MONADZERO with type 'a result = 'a option
+    val test : ('a option -> bool) -> 'a t -> 'a t
+  end

 
 

+  module type OPTIONT = sig
+    type 'a uresult
+    include MONADT with type 'a result = 'a option uresult
+    val test : ('a option ut -> bool) -> 'a t -> 'a t
+  end
+    

   module Option = struct
     include Juli8.Option
     module type EXTRA = sig
   module Option = struct
     include Juli8.Option
     module type EXTRA = sig


@@ -559,10 +573,7 @@ module Monad = struct
       type ('a,'d) t
       val test : ('a option -> bool) -> ('a,'d) t -> ('a,'d) t
     end
       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
+    module M : OPTION = struct

       include Make.MonadFromBind(struct
         type 'a t = 'a option
         type 'a result = 'a t let run xx = xx
       include Make.MonadFromBind(struct
         type 'a t = 'a option
         type 'a result = 'a t let run xx = xx


@@ -590,11 +601,7 @@ module Monad = struct
       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 *)
       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
+    module T(U : MONAD) : OPTIONT with type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct

       include Make.MonadFromTZ(struct
         module U = U
         type 'a t = 'a option U.t
       include Make.MonadFromTZ(struct
         module U = U
         type 'a t = 'a option U.t


@@ -622,24 +629,38 @@ module Monad = struct
     end (* Option.T2 *)
   end (* Option *)
 
     end (* Option.T2 *)
   end (* Option *)
 

+
+  module type LIST = sig
+    include MONADZERO with type 'a result = 'a list
+    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 -> bool) -> 'a t -> 'a t
+  end
+
+  module type LISTT = sig
+    type 'a uresult
+    include MONADZEROT with type 'a result = 'a list uresult
+    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 ut -> 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 ut) -> 'a list -> 'b t
+  end
+    

   module List = struct
     include Juli8.List
   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 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
+    module M : LIST = struct

       include Make.MonadFromBind(struct
         type 'a t = 'a list
         type 'a result = 'a t let run xx = xx
       include Make.MonadFromBind(struct
         type 'a t = 'a list
         type 'a result = 'a t let run xx = xx


@@ -671,18 +692,7 @@ module Monad = struct
       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 *)
       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
+    module T(U : MONAD) : LISTT with type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct

       let distribute k xs = U.seq (List.map k xs)
       include Make.MonadFromTZ(struct
         module U = U
       let distribute k xs = U.seq (List.map k xs)
       include Make.MonadFromTZ(struct
         module U = U


@@ -721,6 +731,26 @@ module Monad = struct
   (* LTree, unit centers, has natural ++ *)
   (* ITree, unit leaves, has natural mzero *)
 
   (* LTree, unit centers, has natural ++ *)
   (* ITree, unit leaves, has natural mzero *)
 

+  module type TREE = sig
+    type 'a tree
+    include MONAD with type 'a result = 'a tree
+    val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
+  end
+
+  module type TREET = sig
+    type 'a tree
+    type 'a uresult
+    include MONADT with type 'a result = 'a tree uresult
+    val (++) : 'a t -> 'a t -> 'a t (* monadically append *)
+    (*
+        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 ut) -> 'a tree -> 'b t
+  end
+

   module LTree = struct
     type 'a tree = Leaf of 'a | Branch of 'a tree * 'a tree
     let branch x y = Branch(x,y)
   module LTree = struct
     type 'a tree = Leaf of 'a | Branch of 'a tree * 'a tree
     let branch x y = Branch(x,y)


@@ -735,14 +765,7 @@ module Monad = struct
       | Leaf x -> Leaf (f x)
       | Branch(l, r) -> Branch(aux l, aux r) in
       aux xt
       | 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
+    module M : TREE with type 'a tree := 'a tree = struct

       include Make.MonadFromBind(struct
         type 'a t = 'a tree
         type 'a result = 'a t let run xx = xx
       include Make.MonadFromBind(struct
         type 'a t = 'a tree
         type 'a result = 'a t let run xx = xx


@@ -752,17 +775,7 @@ module Monad = struct
       end)
       let (++) xx yy = Branch(xx, yy)
     end (* Tree.M *)
       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
+    module T(U : MONAD) : TREET with type 'a tree := 'a tree and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = 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
       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


@@ -776,9 +789,8 @@ module Monad = struct
       let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt)))
     end (* Tree.T *)
     module Z(U : MONADZERO) : sig
       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
+      include TREET with type 'a tree := 'a tree and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
+      include ZERO with type 'a t := 'a 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
     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


@@ -809,19 +821,28 @@ module Monad = struct
     end
   end
 
     end
   end
 

+
+  module type READER = sig
+    type env
+    include MONAD with type 'a result = env -> 'a
+    val ask : env t
+    val asks : (env -> 'a) -> 'a t
+    val shift : (env -> env) -> 'a t -> 'a t
+  end
+
+  module type READERT = sig
+    type env
+    type 'a uresult
+    include MONADT with type 'a result = env -> 'a uresult
+    val ask : env t
+    val asks : (env -> 'a) -> 'a t
+    val shift : (env -> env) -> 'a t -> 'a t
+  end
+

   (* must be parameterized on `struct type env = ... end` *)
   module Reader(E : sig type env end) = struct
     type env = E.env
   (* 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
+    module M : READER with type env := env = struct

       include Make.MonadFromBind(struct
         type 'a t = env -> 'a
         type 'a result = 'a t let run xx = fun e -> xx e
       include Make.MonadFromBind(struct
         type 'a t = env -> 'a
         type 'a result = 'a t let run xx = fun e -> xx e


@@ -833,10 +854,7 @@ module Monad = struct
       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 *)
       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
+    module T(U : MONAD) : READERT with type env := env and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct

       include Make.MonadFromT(struct
         module U = U
         type 'a t = env -> 'a U.t
       include Make.MonadFromT(struct
         module U = U
         type 'a t = env -> 'a U.t


@@ -849,8 +867,8 @@ module Monad = struct
       let shift modifier xx = fun e -> xx (modifier e)
     end (* Reader.T *)
     module Z(U : MONADZERO) : sig
       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
+      include READERT with type env := env and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
+      include ZERO with type 'a t := 'a t

     end = struct
       include Make.MonadFromTUZ(struct
         module U = U
     end = struct
       include Make.MonadFromTUZ(struct
         module U = U


@@ -865,20 +883,30 @@ module Monad = struct
     end (* Reader.Z *)
   end (* Reader *)
 
     end (* Reader.Z *)
   end (* Reader *)
 

+
+  module type STATE = sig
+    type store
+    include MONAD with type 'a result = store -> 'a * store
+    val get : store t
+    val gets : (store -> 'a) -> 'a t
+    val put : store -> unit t
+    val modify : (store -> store) -> unit t
+  end
+
+  module type STATET = sig
+    type store
+    type 'a uresult
+    include MONADT with type 'a result = store -> ('a * store) uresult
+    val get : store t
+    val gets : (store -> 'a) -> 'a t
+    val put : store -> unit t
+    val modify : (store -> store) -> unit t
+  end
+

   (* must be parameterized on `struct type store = ... end` *)
   module State(S : sig type store end) = struct
     type store = S.store
   (* 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
+    module M : STATE with type store := store = struct

       include Make.MonadFromBind(struct
         type 'a t = store -> 'a * store
         type 'a result = 'a t let run xx = fun s -> xx s
       include Make.MonadFromBind(struct
         type 'a t = store -> 'a * store
         type 'a result = 'a t let run xx = fun s -> xx s


@@ -892,10 +920,7 @@ module Monad = struct
       let put s = fun _ -> (), s
       let modify modifier = fun s -> (), modifier s
     end (* State.M *)
       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
+    module T(U : MONAD) : STATET with type store := store and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct

       include Make.MonadFromT(struct
         module U = U
         type 'a t = store -> ('a * store) U.t
       include Make.MonadFromT(struct
         module U = U
         type 'a t = store -> ('a * store) U.t


@@ -909,8 +934,8 @@ module Monad = struct
       let modify modifier = fun s -> U.mid ((), modifier s)
     end (* State.T *)
     module Z(U : MONADZERO) : sig
       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
+      include STATET with type store := store and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
+      include ZERO with type 'a t := 'a t

     end = struct
       include Make.MonadFromTUZ(struct
         module U = U
     end = struct
       include Make.MonadFromTUZ(struct
         module U = U


@@ -926,6 +951,26 @@ module Monad = struct
     end (* State.Z *)
   end (* State *)
 
     end (* State.Z *)
   end (* State *)
 

+
+  module type REF = sig
+    type ref
+    type value
+    include MONAD with type 'a result = 'a
+    val newref : value -> ref t
+    val deref : ref -> value t
+    val change : ref -> value -> unit t
+  end
+
+  module type REFT = sig
+    type ref
+    type value
+    type 'a uresult
+    include MONADT with type 'a result = 'a uresult
+    val newref : value -> ref t
+    val deref : ref -> value t
+    val change : ref -> value -> unit t
+  end
+

   (* State with a different interface; must be parameterized on `struct type value = ... end` *)
   module Ref(V : sig type value end) = struct
     type ref = int
   (* State with a different interface; must be parameterized on `struct type value = ... end` *)
   module Ref(V : sig type value end) = struct
     type ref = int


@@ -936,16 +981,7 @@ module Monad = struct
     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 }
     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
+    module M : REF with type value := value and type ref := ref = struct

       include Make.MonadFromBind(struct
         type 'a t = dict -> 'a * dict
         type 'a result = 'a let run xx = fst (xx empty)
       include Make.MonadFromBind(struct
         type 'a t = dict -> 'a * dict
         type 'a result = 'a let run xx = fst (xx empty)


@@ -957,10 +993,7 @@ module Monad = struct
       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 *)
       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
+    module T(U : MONAD) : REFT with type value := value and type ref := ref and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct

       include Make.MonadFromT(struct
         module U = U
         type 'a t = dict -> ('a * dict) U.t
       include Make.MonadFromT(struct
         module U = U
         type 'a t = dict -> ('a * dict) U.t


@@ -973,8 +1006,8 @@ module Monad = struct
       let change k v = fun s -> U.mid ((), write k v s)
     end (* Ref.T *)
     module Z(U : MONADZERO) : sig
       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
+      include REFT with type value := value and type ref := ref and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
+      include ZERO with type 'a t := 'a t

     end = struct
       include Make.MonadFromTUZ(struct
         module U = U
     end = struct
       include Make.MonadFromTUZ(struct
         module U = U


@@ -989,21 +1022,32 @@ module Monad = struct
     end (* Ref.Z *)
   end (* Ref *)
 
     end (* Ref.Z *)
   end (* Ref *)
 

+
+  module type WRITER = sig
+    type log
+    include MONAD with type 'a result = 'a * log
+    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 type WRITERT = sig
+    type log
+    type 'a uresult
+    include MONADT with type 'a result = ('a * log) uresult
+    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
+

   (* 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
   (* 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
+    module M : WRITER with type log := log = struct

       include Make.MonadFromBind(struct
         type 'a t = 'a * log
         type 'a result = 'a t let run xx = xx
       include Make.MonadFromBind(struct
         type 'a t = 'a * log
         type 'a result = 'a t let run xx = xx


@@ -1017,10 +1061,7 @@ module Monad = struct
       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 *)
       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
+    module T(U : MONAD) : WRITERT with type log := log and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct

       include Make.MonadFromT(struct
         module U = U
         type 'a t = ('a * log) U.t
       include Make.MonadFromT(struct
         module U = U
         type 'a t = ('a * log) U.t


@@ -1035,8 +1076,8 @@ module Monad = struct
       let censor c xx = pass (xx >>= fun x -> mid (x,c))
     end (* Writer.T *)
     module Z(U : MONADZERO) : sig
       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
+      include WRITERT with type log := log and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
+      include ZERO with type 'a t := 'a t

     end = struct
       include Make.MonadFromTUZ(struct
         module U = U
     end = struct
       include Make.MonadFromTUZ(struct
         module U = U


@@ -1053,22 +1094,34 @@ module Monad = struct
     end (* Writer.Z *)
   end (* Writer *)
 
     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
+
+  module type ERROR = sig
+    type msg
+    type 'a error
+    include MONAD with type 'a result = 'a error
+    val throw : msg -> 'a t
+    val catch : 'a t -> (msg -> 'a t) -> 'a t
+  end
+
+  module type ERRORT = sig
+    type msg
+    type 'a error
+    type 'a uresult
+    include MONADT with type 'a result = 'a uresult (* note the difference from ERROR *)
+    val throw : msg -> 'a t
+    val catch : 'a t -> (msg -> 'a t) -> 'a t
+  end
+
+  (* must be parameterized on `struct type msg = ... end` *)
+  module Error(E : sig type msg exception Exc of msg (* Exc used only by T *) end) = struct
+    type msg = E.msg
+    type 'a error = Error of msg | OK of 'a
+    module M : ERROR with type msg := msg and type 'a error := 'a error = struct

       include Make.MonadFromBind(struct
         type 'a t = 'a error
       include Make.MonadFromBind(struct
         type 'a t = 'a error

-        type 'a result = 'a t let run xx = xx
+        type 'a result = 'a t
+        (* note that M.run doesn't raise *)
+        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
         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


@@ -1076,14 +1129,12 @@ module Monad = struct
       let throw e = Error e
       let catch xx handler = match xx with OK _ -> xx | Error e -> handler e
     end (* Error.M *)
       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
+    module T(U : MONAD) : ERRORT with type msg := msg and type 'a error := 'a error and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct

       include Make.MonadFromT(struct
         module U = U
         type 'a t = 'a error U.t
         type 'a result = 'a U.result
       include Make.MonadFromT(struct
         module U = U
         type 'a t = 'a error U.t
         type 'a result = 'a U.result

+        (* note that T.run does raise *)

         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))
         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))


@@ -1092,8 +1143,8 @@ module Monad = struct
       let catch xx handler = U.(xx >>= function OK _ as x -> mid x | Error e -> handler e)
     end (* Error.T *)
     module Z(U : MONADZERO) : sig
       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
+      include ERRORT with type msg := msg and type 'a error := 'a error and type 'a uresult := 'a U.result and type 'a ut := 'a U.t
+      include ZERO with type 'a t := 'a t

     end = struct
       include Make.MonadFromTUZ(struct
         module U = U
     end = struct
       include Make.MonadFromTUZ(struct
         module U = U


@@ -1109,9 +1160,10 @@ module Monad = struct
     end (* Error.Z *)
   end (* Error *)
 
     end (* Error.Z *)
   end (* Error *)
 

+

   (* predefine some common instances *)
 
   (* predefine some common instances *)
 

-  module Writer1 = Writer(struct type log = string let empty = "" let append s1 s2 = s1 ^ "\n" ^ s2 end)
+  module Writer1 = Writer(struct type log = string let empty = "" let append s1 s2 = if s2 = "" then s1 else if s1 = "" then s2 else s1 ^ "\n" ^ s2 end)

 
   module Writer2 = struct
     include Writer(struct
 
   module Writer2 = struct
     include Writer(struct


@@ -1125,7 +1177,7 @@ module Monad = struct
     let run xx = let (x,w) = M.run xx in (x, List.rev w)
   end
 
     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)
+  module Failure = Error(struct type msg = string exception Exc = Failure end)

 
 end (* Monad *)
 
 
 end (* Monad *)