-- <pre>


data Mon m = Mon (forall a . a -> m a)
                 (forall a b . m a -> (a -> m b) -> m b)


type Transformer s t = Mon s -> Mon t

-------------------------------
-- Three Monads

--Id
data Id x = Id x

--Env
data Env e x = Env (e -> x)

--State
data State s x = State (s -> (x,s))

---------------------------------------------

--data Id x = Id x

idMon = let bind x f = case x of {(Id y) -> f y }
        in Mon Id bind

runId (Id x) = x


--data Env e x = Env (e -> x)

envMon =
  let unit x = Env(\ _ -> x)
      bind (Env g) f = Env(\ e -> case f(g e) of { Env h -> h e })
  in Mon unit bind

readEnv = Env(\ e -> e)
inEnv e (Env f) = Env(\ e2 -> f e)


--data State s x = State (s -> (x,s))

stateMon =
  let unit x = State(\ s -> (x,s))
      bind (State g) f =
        State(\ s -> let (a,s') = g s
                         State h = f a
                     in h s')
  in Mon unit bind

readSt = State(\ s -> (s,s))
writeSt x = State(\ s -> ((),x))

--------------------------------------------

data WithEnv env m a = WithEnv (env -> m a)

data Fenv m = Fenv
   (forall a e . m a -> WithEnv e m a)
   (forall e . WithEnv e m e)
   (forall a e . e -> WithEnv e m a -> WithEnv e m a)

-----------------------------------------------------

transEnv (Mon unitM bindM) =
  let unitEnv x = WithEnv(\ rho -> unitM x)
      bindEnv x f =
        WithEnv(\ rho ->
                let (WithEnv h) = x
                in bindM (h rho)
                      (\ a -> let (WithEnv g) = f a
                              in g rho))
      lift2 x = WithEnv(\ rho -> x)
      rdEnv = WithEnv(\ rho -> unitM rho)
      inEnv rho (WithEnv x) = WithEnv(\ _ -> x rho)
  in (Mon unitEnv bindEnv,Fenv lift2 rdEnv inEnv)


------------------------------------------------------------

data WithStore s m a = WithStore (s -> m (a,s))

data Fstore m = Fstore
   (forall a s . m a -> WithStore s m a)
   (forall s . (s -> s) -> WithStore s m ())
   (forall s . WithStore s m s)

------------------------------------------------------

transStore (Mon unitM bindM) =
  let unitStore x = WithStore(\sigma -> unitM(x,sigma))
      bindStore x f =
        WithStore(\ sigma0 ->
                    let (WithStore h) = x
                    in bindM (h sigma0)
                       (\ (a,sigma1) ->
                          let (WithStore g) = f a
                          in g sigma1 ) )
      lift2 x = WithStore(\ sigma -> bindM x (\ y -> unitM(y,sigma)))
      update f = WithStore(\ sigma -> unitM((),f sigma))
      get = WithStore(\sigma -> unitM(sigma,sigma))
  in (Mon unitStore bindStore,Fstore lift2 update get)

----------------------------------------------------------
-- an example

ex1 :: (Mon (WithStore a (WithEnv b Id))
       ,Fenv Id
       ,Fstore (WithEnv c Id))
ex1 = let (mon1,funs1) = transEnv idMon
          (mon2,funs2) = transStore mon1
      in (mon2,funs1,funs2)


-- </pre>