{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | A carrier for 'Reader' effects.
--
-- @since 1.0.0.0
module Control.Carrier.Reader
( -- * Reader carrier
  runReader
, ReaderC(..)
  -- * Reader effect
, module Control.Effect.Reader
) where

import Control.Algebra
import Control.Applicative (Alternative(..), liftA2)
import Control.Effect.Reader
import Control.Monad (MonadPlus)
import Control.Monad.Fail as Fail
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.IO.Unlift

-- | Run a 'Reader' effect with the passed environment value.
--
-- @
-- 'runReader' a 'ask' = 'pure' a
-- @
-- @
-- 'runReader' a ('pure' b) = 'pure' b
-- @
-- @
-- 'runReader' a ('local' f m) = 'runReader' (f a) m
-- @
--
-- @since 1.0.0.0
runReader :: r -> ReaderC r m a -> m a
runReader :: forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader r
r (ReaderC r -> m a
runReaderC) = r -> m a
runReaderC r
r
{-# INLINE runReader #-}

-- | @since 1.0.0.0
newtype ReaderC r m a = ReaderC (r -> m a)
  deriving (forall a b. a -> ReaderC r m b -> ReaderC r m a
forall a b. (a -> b) -> ReaderC r m a -> ReaderC r m b
forall r (m :: * -> *) a b.
Functor m =>
a -> ReaderC r m b -> ReaderC r m a
forall r (m :: * -> *) a b.
Functor m =>
(a -> b) -> ReaderC r m a -> ReaderC r m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ReaderC r m b -> ReaderC r m a
$c<$ :: forall r (m :: * -> *) a b.
Functor m =>
a -> ReaderC r m b -> ReaderC r m a
fmap :: forall a b. (a -> b) -> ReaderC r m a -> ReaderC r m b
$cfmap :: forall r (m :: * -> *) a b.
Functor m =>
(a -> b) -> ReaderC r m a -> ReaderC r m b
Functor)

instance Applicative m => Applicative (ReaderC r m) where
  pure :: forall a. a -> ReaderC r m a
pure = forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}

  ReaderC r -> m (a -> b)
f <*> :: forall a b. ReaderC r m (a -> b) -> ReaderC r m a -> ReaderC r m b
<*> ReaderC r -> m a
a = forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) r -> m (a -> b)
f r -> m a
a)
  {-# INLINE (<*>) #-}

  liftA2 :: forall a b c.
(a -> b -> c) -> ReaderC r m a -> ReaderC r m b -> ReaderC r m c
liftA2 a -> b -> c
f (ReaderC r -> m a
a) (ReaderC r -> m b
b) = forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC forall a b. (a -> b) -> a -> b
$ \ r
r ->
    forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f (r -> m a
a r
r) (r -> m b
b r
r)
  {-# INLINE liftA2 #-}

  ReaderC r -> m a
u *> :: forall a b. ReaderC r m a -> ReaderC r m b -> ReaderC r m b
*> ReaderC r -> m b
v = forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC forall a b. (a -> b) -> a -> b
$ \ r
r -> r -> m a
u r
r forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> r -> m b
v r
r
  {-# INLINE (*>) #-}

  ReaderC r -> m a
u <* :: forall a b. ReaderC r m a -> ReaderC r m b -> ReaderC r m a
<* ReaderC r -> m b
v = forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC forall a b. (a -> b) -> a -> b
$ \ r
r -> r -> m a
u r
r forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* r -> m b
v r
r
  {-# INLINE (<*) #-}

instance Alternative m => Alternative (ReaderC r m) where
  empty :: forall a. ReaderC r m a
empty = forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC (forall a b. a -> b -> a
const forall (f :: * -> *) a. Alternative f => f a
empty)
  {-# INLINE empty #-}

  ReaderC r -> m a
l <|> :: forall a. ReaderC r m a -> ReaderC r m a -> ReaderC r m a
<|> ReaderC r -> m a
r = forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) r -> m a
l r -> m a
r)
  {-# INLINE (<|>) #-}

instance Monad m => Monad (ReaderC r m) where
  ReaderC r -> m a
a >>= :: forall a b. ReaderC r m a -> (a -> ReaderC r m b) -> ReaderC r m b
>>= a -> ReaderC r m b
f = forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC (\ r
r -> r -> m a
a r
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader r
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReaderC r m b
f)
  {-# INLINE (>>=) #-}

instance Fail.MonadFail m => Fail.MonadFail (ReaderC r m) where
  fail :: forall a. String -> ReaderC r m a
fail = forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail
  {-# INLINE fail #-}

instance MonadFix m => MonadFix (ReaderC s m) where
  mfix :: forall a. (a -> ReaderC s m a) -> ReaderC s m a
mfix a -> ReaderC s m a
f = forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC (\ s
r -> forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader s
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReaderC s m a
f))
  {-# INLINE mfix #-}

instance MonadIO m => MonadIO (ReaderC r m) where
  liftIO :: forall a. IO a -> ReaderC r m a
liftIO = forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
  {-# INLINE liftIO #-}

instance (Alternative m, Monad m) => MonadPlus (ReaderC r m)

instance MonadTrans (ReaderC r) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> ReaderC r m a
lift = forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
  {-# INLINE lift #-}

instance Algebra sig m => Algebra (Reader r :+: sig) (ReaderC r m) where
  alg :: forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n (ReaderC r m)
-> (:+:) (Reader r) sig n a -> ctx () -> ReaderC r m (ctx a)
alg Handler ctx n (ReaderC r m)
hdl (:+:) (Reader r) sig n a
sig ctx ()
ctx = forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC forall a b. (a -> b) -> a -> b
$ \ r
r -> case (:+:) (Reader r) sig n a
sig of
    L Reader r n a
Ask         -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (r
r forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx)
    L (Local r -> r
f n a
m) -> forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader (r -> r
f r
r) (Handler ctx n (ReaderC r m)
hdl (n a
m forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx))
    R sig n a
other       -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (ctx :: * -> *)
       (n :: * -> *) a.
(Algebra sig m, Functor ctx) =>
Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
alg (forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader r
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handler ctx n (ReaderC r m)
hdl) sig n a
other ctx ()
ctx
  {-# INLINE alg #-}

instance MonadUnliftIO m => MonadUnliftIO (ReaderC r m) where
  withRunInIO :: forall b.
((forall a. ReaderC r m a -> IO a) -> IO b) -> ReaderC r m b
withRunInIO (forall a. ReaderC r m a -> IO a) -> IO b
inner = forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC forall a b. (a -> b) -> a -> b
$ \ r
r -> forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \ forall a. m a -> IO a
run -> (forall a. ReaderC r m a -> IO a) -> IO b
inner (forall a. m a -> IO a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader r
r)
  {-# INLINE withRunInIO #-}