+ module T2(Wrapped : Monad.S2) = struct
+ module Trans = struct
+ module Wrapped = Wrapped
+ type ('x,'a) m = store -> ('x,'a * store) Wrapped.m
+ type ('x,'a) result = store -> ('x,'a * store) Wrapped.result
+ type ('x,'a) result_exn = store -> ('x,'a) Wrapped.result_exn
+ (* code repetition, ugh *)
+ let elevate w = fun s ->
+ Wrapped.bind w (fun a -> Wrapped.unit (a, s))
+ let bind u f = fun s ->
+ Wrapped.bind (u s) (fun (a, s') -> f a s')
+ let run u = fun s -> Wrapped.run (u s)
+ let run_exn u = fun s ->
+ let w = Wrapped.bind (u s) (fun (a,s) -> Wrapped.unit a)
+ in Wrapped.run_exn w
+ end
+ include Monad.MakeT2(Trans)
+ let get = fun s -> Wrapped.unit (s, s)
+ let gets viewer = fun s -> Wrapped.unit (viewer s, s) (* may fail *)
+ let put s = fun _ -> Wrapped.unit ((), s)
+ let puts modifier = fun s -> Wrapped.unit ((), modifier s)
+ end
+ module TP2(Wrapped : Monad.P2) = struct
+ module TransP = struct
+ include T2(Wrapped)
+ let plus u v = fun s -> Wrapped.plus (u s) (v s)
+ let zero () = elevate (Wrapped.zero ())
+ end
+ let gets viewer = fun s ->
+ try Wrapped.unit (viewer s, s)
+ with Not_found -> Wrapped.zero ()
+ include TransP
+ include (Monad.MakeDistrib2(TransP) : Monad.PLUS2 with type ('x,'a) m := ('x,'a) m)
+ end