CPS.hs

{-# LANGUAGE Trustworthy, Rank2Types, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances #-}
module Control.Monad.Reader.CPS (ReaderT(..)
    , runReaderT
    , mapReaderT
    , Reader
    , runReader
    , module Control.Monad.Reader.Class) where
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Applicative
import Control.Monad.Identity
import Control.Monad.Trans
import Control.Monad.IO.Class
import Control.Monad.Error.Class
import Control.Monad.Writer.Class

newtype ReaderT r m a = ReaderT { unReaderT :: forall b. r -> (a -> m b) -> m b }

runReaderT :: Monad m => ReaderT r m a -> r -> m a
runReaderT m r = unReaderT m r return
{-# INLINABLE runReaderT #-}

mapReaderT :: (Monad m, Monad n) => (m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT t m = ReaderT $ \r c -> t (unReaderT m r return) >>= c

instance Functor (ReaderT r m) where
    fmap f m = ReaderT $ \r c -> unReaderT m r (c . f)
    {-# INLINABLE fmap #-}

instance Applicative (ReaderT r m) where
    pure x = ReaderT $ \_ c -> c x
    {-# INLINABLE pure #-}
    mf <*> ma = ReaderT $ \r c -> unReaderT mf r $ \f -> unReaderT ma r (c . f)
    {-# INLINABLE (<*>) #-}
    m *> n = ReaderT $ \r c -> unReaderT m r (\_ -> unReaderT n r c)
    {-# INLINABLE (*>) #-}

instance Monad (ReaderT r m) where
    return x = ReaderT $ \_ c -> c x
    {-# INLINABLE return #-}
    m >>= k = ReaderT $ \r c -> unReaderT m r (\a -> unReaderT (k a) r c)
    {-# INLINABLE (>>=) #-}
    (>>) = (*>)
    {-# INLINE (>>) #-}

instance MonadReader r (ReaderT r m) where
    ask = ReaderT $ \r c -> c r
    {-# INLINABLE ask #-}
    local f m = ReaderT $ \r c -> unReaderT m (f r) c
    {-# INLINABLE local #-}
    reader f = ReaderT $ \r c -> c (f r)
    {-# INLINABLE reader #-}

instance MonadIO m => MonadIO (ReaderT r m) where
    liftIO = lift . liftIO
    {-# INLINABLE liftIO #-}

instance MonadState s m => MonadState s (ReaderT r m) where
    get = lift get
    {-# INLINABLE get #-}
    put = lift . put
    {-# INLINABLE put #-}

instance MonadTrans (ReaderT r) where
    lift m = ReaderT $ const (m >>=)
    {-# INLINABLE lift #-}

instance MonadError e m => MonadError e (ReaderT r m) where
    throwError = lift . throwError
    {-# INLINABLE throwError #-}

    catchError m h = ReaderT $ \r c -> catchError (unReaderT m r return) (\e -> runReaderT (h e) r) >>= c
    {-# INLINABLE catchError #-}

instance MonadWriter w m => MonadWriter w (ReaderT r m) where
    tell = lift . tell
    listen m = ReaderT $ \r c -> listen (runReaderT m r) >>= c
    pass m = ReaderT $ \r c -> pass (runReaderT m r) >>= c

type Reader r = ReaderT r Identity

runReader :: Reader r a -> r -> a
runReader m r = runIdentity (runReaderT m r)
{-# INLINE runReader #-}