{-# OPTIONS -fglasgow-exts #-}
module MonadTrans2 where

-------------------------------------------------------------------
-- MonadTrans

-- A monad transformer `t' is a type constructor, which turns a
-- monad `m' (which we already have) into a new monad `t m'
-- (which provides new features to the old monad).

-- In the new monad `t m', we would still like to use all features
-- of the old monad `m'. That is why a monad transformer `t' has to
-- provide a "lifting" function: a function that turns operations
-- in `m' into operations in `t m'.

class MonadTrans t where
  lift :: Monad m => m a -> t m a


-------------------------------------------------------------------
-- EnvStateT

-- A state monad with an environment. (no liftings from
-- other monads are implemented).


class Monad m => MonadEnvState m e s where
  getES     :: m (e, s)
  getE      :: m e
  getS      :: m s
  -- setS      :: s -> m ()
  -- getSetRet :: (e -> s -> (r, s)) -> m r
  -- update    :: (e -> s -> s)      -> m ()

newtype EnvStateT e s m r = EnvStateT (e -> s -> m (r, s))

instance Monad m => Monad (EnvStateT e s m) where
  return x =
    EnvStateT $ \_ s -> return (x,s)
  
  EnvStateT m1 >>= k =
    EnvStateT $ \e s0 ->
      do (r1, s1) <- m1 e s0
         let EnvStateT m2 = k r1
         m2 e s1

instance MonadTrans (EnvStateT e s) where
  lift m =
    EnvStateT $ \e s ->
      do r <- m
         return (r, s)
         
instance Monad m => MonadEnvState (EnvStateT e s m) e s where
  getES       = EnvStateT $ \e s -> return ((e,s), s)
  getE        = EnvStateT $ \e s -> return (e, s)
  getS        = EnvStateT $ \_ s -> return (s, s)
  -- setS s      = EnvStateT $ \_ _ -> return ((), s)
  -- getSetRet f = EnvStateT $ \e s -> return (f e s)
  -- update f    = EnvStateT $ \e s -> return ((), f e s)
  
runEnvStateT :: Monad m => EnvStateT e s m r -> e -> s -> m r
runEnvStateT (EnvStateT f) e s = 
  f e s >>= return . fst


-------------------------------------------------------------------
-- IdM

-- We will use monad transformers to build complicated monads out
-- of simple ones. We start with a monad which has absolutely no
-- features: the "identity" monad.

newtype IdM a =
  IdM a
  deriving Show  

instance Monad IdM where
  return x =
    IdM x
  IdM a >>= k =
    k a

-- run

runIdM :: IdM a -> a
runIdM (IdM x) = x


-------------------------------------------------------------------
-- StateT

-- A state monad is a monad which supports the operations "get"
-- and "set".

class Monad m => MonadState m s where
  get       :: m s
  set       :: s -> m ()
  getSetRet :: (s -> (r, s)) -> m r
  
-- An example of a monad transformer is `StateT s'. It adds
-- the feature of being able to manipulate state of type `s' to
-- any existing monad.

newtype StateT s m a =
  StateT (s -> m (a, s))

-- If `m' is a monad, then so is `StateT s m'.

instance Monad m => Monad (StateT s m) where
  return x =
    StateT (\s -> return (x, s))
  
  StateT m1 >>= k =
    StateT
    (\s0 ->
      do (a, s1) <- m1 s0
         let StateT m2 = k a
         m2 s1
    )

-- And here is how we can reuse the features of the old monad `m'.

instance MonadTrans (StateT s) where
  lift m =
    StateT
    (\s ->
      do a <- m
         return (a, s)
    )

-- Finally, we show that, given that `m' is a monad, `StateT s m' is
-- in fact a state monad.

instance Monad m => MonadState (StateT s m) s where
  get    = StateT (\s -> return (s, s))
  set s' = StateT (\s -> return ((), s'))
  getSetRet f = StateT $ \s -> return $ f s  -- Magnus

-- run

runStateT :: Monad m => StateT s m a -> s -> m a
runStateT (StateT f) s =
  do (a, _) <- f s
     return a

-------------------------------------------------------------------
-- EnvT

-- An environment monad is a monad which supports the operation
-- "env".

class Monad m => MonadEnv m e where
  env :: m e

-- `EnvT e' is a monad transformer adding the capability of using
-- an environment to any monad.

newtype EnvT e m a =
  EnvT (e -> m a)

-- If `m' is a monad, then so is `EnvT e m'.

instance Monad m => Monad (EnvT s m) where
  return x =
    EnvT (\e -> return x)
  
  EnvT m1 >>= k =
    EnvT
    (\e ->
      do a <- m1 e
         let EnvT m2 = k a
         m2 e
    )

-- reusing operations from `m' in `EnvT e m'.

instance MonadTrans (EnvT e) where
  lift m =
    EnvT (\e -> m)

-- Given that `m' is a monad, `EnvT s m' is an environment monad.

instance Monad m => MonadEnv (EnvT e m) e where
  env = EnvT (\e -> return e)

-- run

runEnvT :: Monad m => EnvT e m a -> e -> m a
runEnvT (EnvT f) e = f e

-------------------------------------------------------------------
-- OutputT

-- An output monad is a monad which supports the operation
-- "output".

class Monad m => MonadOutput m o where
  output :: o -> m ()

-- `OutputT o' is a monad transformer adding the capability of producing
-- output to any monad.

newtype OutputT o m a =
  OutputT (m (a, [o]))

-- If `m' is a monad, then so is `OutputT o m'.

instance Monad m => Monad (OutputT o m) where
  return x =
    OutputT (return (x, []))
  
  OutputT m1 >>= k =
    OutputT
    ( do (a, o1) <- m1
         let OutputT m2 = k a
         (b, o2) <- m2
         return (b, o1++o2)
    )

-- reusing operations from `m' in `OutputT o m'.

instance MonadTrans (OutputT o) where
  lift m =
    OutputT
    ( do a <- m
         return (a, [])
    )

-- Given that `m' is a monad, `OutputT o m' is an output monad.

instance Monad m => MonadOutput (OutputT o m) o where
  output o = OutputT (return ((),[o]))

-- run

runOutputT :: Monad m => OutputT o m a -> m (a, [o])
runOutputT (OutputT m) = m

-------------------------------------------------------------------
-- ErrorT

-- An error monad is a monad which supports the operation
-- "wrong".

class Monad m => MonadError m where
  wrong :: m a

-- `ErrorT' is a monad transformer adding the capability of generating
-- errors to any monad.

newtype ErrorT m a =
  ErrorT (m (Maybe a))

-- If `m' is a monad, then so is `ErrorT m'.

instance Monad m => Monad (ErrorT m) where
  return x =
    ErrorT (return (Just x))
  
  ErrorT m1 >>= k =
    ErrorT
    ( do ma <- m1
         case ma of
           Nothing -> return Nothing
           Just a  -> let ErrorT m2 = k a in m2
    )

-- reusing operations from `m' in `ErrorT m'.

instance MonadTrans ErrorT where
  lift m =
    ErrorT
    ( do a <- m
         return (Just a)
    )

-- Given that `m' is a monad, `ErrorT m' is an error monad.

instance Monad m => MonadError (ErrorT m) where
  wrong = ErrorT (return Nothing)

-- run

runErrorT :: Monad m => ErrorT m a -> m (Maybe a)
runErrorT (ErrorT m) = m

-------------------------------------------------------------------
-- ContT

-- `ContT' is a monad transformer turning any monad into a monad
-- using continuation passing style. This is often more efficient,
-- especially when using shallow embeddings. (There are also other
-- operations supported on continuation monads, which we will not
-- discuss here.)

newtype ContT r m a =
  ContT ((a -> m r) -> m r)

-- If `m' is a monad, then so is `ContT r m'. (In fact, even if
-- `m' is not a monad, `ContT r m' still is.)

instance Monad m => Monad (ContT r m) where
  return x =
    ContT (\k -> k x)
  
  ContT m1 >>= k2 =
    ContT (\k3 -> m1 (\a -> let ContT m2 = k2 a in m2 k3))

-- reusing operations from `m' in `ContT r m'.

instance MonadTrans (ContT r) where
  lift m =
    ContT
    (\k -> do a <- m
              k a
    )

-- run

runContT :: Monad m => ContT r m r -> m r
runContT (ContT m) = m (\r -> return r)

-------------------------------------------------------------------
-- DeepT

-- `DeepT' is a monad transformer where all liftings are made
-- explicit. This can be used for several purposes. One is to
-- be able to implement a form of parallel composition on programs
-- in this monad.

data DeepT m a
  = Lift (m (DeepT m a))
  | Return a

-- If `m' is a monad, then so is `DeepT m'.

instance Monad m => Monad (DeepT m) where
  return x =
    Return x
  
  Lift m >>= k =
    Lift (do m' <- m
             return (m' >>= k)
         )

  Return a >>= k =
    k a

-- reusing operations from `m' in `DeepT m'.

instance MonadTrans DeepT where
  lift m =
    Lift (do a <- m
             return (Return a)
         )

-- parallel composition; we merge two programs into one.

(>|<) :: Monad m => DeepT m a -> DeepT m b -> DeepT m (a,b)
Lift ma >|< Lift mb =
  Lift (do ka <- ma
           kb <- mb
           return (ka >|< kb)
       )

Return a >|< Lift mb =
  Lift (do kb <- mb
           return (Return a >|< kb)
       )

Lift ma >|< Return b =
  Lift (do ka <- ma
           return (ka >|< Return b)
       )

Return a >|< Return b =
  Return (a,b)

-- run

runDeepT :: Monad m => DeepT m a -> m a
runDeepT (Lift mk) =
  do k <- mk
     runDeepT k

runDeepT (Return a) =
  do return a

-------------------------------------------------------------------
-- boring liftings

-- state

instance MonadState m s => MonadState (EnvT e m) s where
  get         = lift get
  set s       = lift (set s)
  getSetRet f = lift (getSetRet f)

instance MonadState m s => MonadState (OutputT o m) s where
  get         = lift get
  set s       = lift (set s)
  getSetRet f = lift (getSetRet f)

instance MonadState m s => MonadState (ErrorT m) s where
  get         = lift get
  set s       = lift (set s)
  getSetRet f = lift (getSetRet f)

instance MonadState m s => MonadState (ContT r m) s where
  get         = lift get
  set s       = lift (set s)
  getSetRet f = lift (getSetRet f)

instance MonadState m s => MonadState (DeepT m) s where
  get         = lift get
  set s       = lift (set s)
  getSetRet f = lift (getSetRet f)

-- env

instance MonadEnv m e => MonadEnv (StateT s m) e where
  env = lift env

instance MonadEnv m e => MonadEnv (OutputT o m) e where
  env = lift env

instance MonadEnv m e => MonadEnv (ErrorT m) e where
  env = lift env

instance MonadEnv m e => MonadEnv (ContT r m) e where
  env = lift env

instance MonadEnv m e => MonadEnv (DeepT m) e where
  env = lift env

-- output

instance MonadOutput m o => MonadOutput (StateT s m) o where
  output o = lift (output o)

instance MonadOutput m o => MonadOutput (EnvT s m) o where
  output o = lift (output o)

instance MonadOutput m o => MonadOutput (ErrorT m) o where
  output o = lift (output o)

instance MonadOutput m o => MonadOutput (ContT r m) o where
  output o = lift (output o)

instance MonadOutput m o => MonadOutput (DeepT m) o where
  output o = lift (output o)

-- error

instance MonadError m => MonadError (StateT s m) where
  wrong = lift wrong

instance MonadError m => MonadError (EnvT e m) where
  wrong = lift wrong

instance MonadError m => MonadError (OutputT o m) where
  wrong = lift wrong

instance MonadError m => MonadError (ContT r m) where
  wrong = lift wrong

instance MonadError m => MonadError (DeepT m) where
  wrong = lift wrong

-------------------------------------------------------------------
-- the end.