-- |
-- The Reader monad transformer.
--
-- This is useful to keep a non-modifiable value
-- in a context
{-# LANGUAGE ConstraintKinds #-}
module Foundation.Monad.Reader
    ( -- * MonadReader
      MonadReader(..)
    , -- * ReaderT
      ReaderT
    , runReaderT
    ) where

import Basement.Compat.Base (($), (.), const)
import Basement.Compat.AMP
import Foundation.Monad.Base
import Foundation.Monad.Exception

class AMPMonad m => MonadReader m where
    type ReaderContext m
    ask :: m (ReaderContext m)

-- | Reader Transformer
newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }

instance Functor m => Functor (ReaderT r m) where
    fmap f m = ReaderT $ fmap f . runReaderT m
    {-# INLINE fmap #-}

instance Applicative m => Applicative (ReaderT r m) where
    pure a     = ReaderT $ const (pure a)
    {-# INLINE pure #-}
    fab <*> fa = ReaderT $ \r -> runReaderT fab r <*> runReaderT fa r
    {-# INLINE (<*>) #-}

instance AMPMonad m => Monad (ReaderT r m) where
    return a = ReaderT $ const (return a)
    {-# INLINE return #-}
    ma >>= mab = ReaderT $ \r -> runReaderT ma r >>= \a -> runReaderT (mab a) r
    {-# INLINE (>>=) #-}

instance (AMPMonad m, MonadFix m) => MonadFix (ReaderT s m) where
    mfix f = ReaderT $ \r -> mfix $ \a -> runReaderT (f a) r
    {-# INLINE mfix #-}

instance MonadTrans (ReaderT r) where
    lift f = ReaderT $ const f
    {-# INLINE lift #-}

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

instance MonadFailure m => MonadFailure (ReaderT r m) where
    type Failure (ReaderT r m) = Failure m
    mFail e = ReaderT $ \_ -> mFail e

instance MonadThrow m => MonadThrow (ReaderT r m) where
    throw e = ReaderT $ \_ -> throw e

instance MonadCatch m => MonadCatch (ReaderT r m) where
    catch (ReaderT m) c = ReaderT $ \r -> m r `catch` (\e -> runReaderT (c e) r)

instance MonadBracket m => MonadBracket (ReaderT r m) where
    generalBracket acq cleanup cleanupExcept innerAction = do
        c <- ask
        lift $ generalBracket (runReaderT acq c)
                              (\a b -> runReaderT (cleanup a b) c)
                              (\a exn -> runReaderT (cleanupExcept a exn) c)
                              (\a -> runReaderT (innerAction a) c)

instance AMPMonad m => MonadReader (ReaderT r m) where
    type ReaderContext (ReaderT r m) = r
    ask = ReaderT return