{-# 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 :: 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 (a -> ReaderC r m b -> ReaderC r m a
(a -> b) -> ReaderC r m a -> ReaderC r m b
(forall a b. (a -> b) -> ReaderC r m a -> ReaderC r m b)
-> (forall a b. a -> ReaderC r m b -> ReaderC r m a)
-> Functor (ReaderC r m)
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
<$ :: 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 :: (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 :: a -> ReaderC r m a
pure = (r -> m a) -> ReaderC r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC ((r -> m a) -> ReaderC r m a)
-> (a -> r -> m a) -> a -> ReaderC r m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> r -> m a
forall a b. a -> b -> a
const (m a -> r -> m a) -> (a -> m a) -> a -> r -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE pure #-}

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

  liftA2 :: (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) = (r -> m c) -> ReaderC r m c
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC ((r -> m c) -> ReaderC r m c) -> (r -> m c) -> ReaderC r m c
forall a b. (a -> b) -> a -> b
$ \ r
r ->
    (a -> b -> c) -> m a -> m b -> m c
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 *> :: ReaderC r m a -> ReaderC r m b -> ReaderC r m b
*> ReaderC r -> m b
v = (r -> m b) -> ReaderC r m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC ((r -> m b) -> ReaderC r m b) -> (r -> m b) -> ReaderC r m b
forall a b. (a -> b) -> a -> b
$ \ r
r -> r -> m a
u r
r m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> r -> m b
v r
r
  {-# INLINE (*>) #-}

  ReaderC r -> m a
u <* :: ReaderC r m a -> ReaderC r m b -> ReaderC r m a
<* ReaderC r -> m b
v = (r -> m a) -> ReaderC r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC ((r -> m a) -> ReaderC r m a) -> (r -> m a) -> ReaderC r m a
forall a b. (a -> b) -> a -> b
$ \ r
r -> r -> m a
u r
r m a -> m b -> m a
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 :: ReaderC r m a
empty = (r -> m a) -> ReaderC r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC (m a -> r -> m a
forall a b. a -> b -> a
const m a
forall (f :: * -> *) a. Alternative f => f a
empty)
  {-# INLINE empty #-}

  ReaderC r -> m a
l <|> :: ReaderC r m a -> ReaderC r m a -> ReaderC r m a
<|> ReaderC r -> m a
r = (r -> m a) -> ReaderC r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC ((m a -> m a -> m a) -> (r -> m a) -> (r -> m a) -> r -> m a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 m a -> m a -> m a
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 >>= :: ReaderC r m a -> (a -> ReaderC r m b) -> ReaderC r m b
>>= a -> ReaderC r m b
f = (r -> m b) -> ReaderC r m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC (\ r
r -> r -> m a
a r
r m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= r -> ReaderC r m b -> m b
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader r
r (ReaderC r m b -> m b) -> (a -> ReaderC r m b) -> a -> m b
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 :: String -> ReaderC r m a
fail = (r -> m a) -> ReaderC r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC ((r -> m a) -> ReaderC r m a)
-> (String -> r -> m a) -> String -> ReaderC r m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> r -> m a
forall a b. a -> b -> a
const (m a -> r -> m a) -> (String -> m a) -> String -> r -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail
  {-# INLINE fail #-}

instance MonadFix m => MonadFix (ReaderC s m) where
  mfix :: (a -> ReaderC s m a) -> ReaderC s m a
mfix a -> ReaderC s m a
f = (s -> m a) -> ReaderC s m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC (\ s
r -> (a -> m a) -> m a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (s -> ReaderC s m a -> m a
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader s
r (ReaderC s m a -> m a) -> (a -> ReaderC s m a) -> a -> m a
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 :: IO a -> ReaderC r m a
liftIO = (r -> m a) -> ReaderC r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC ((r -> m a) -> ReaderC r m a)
-> (IO a -> r -> m a) -> IO a -> ReaderC r m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> r -> m a
forall a b. a -> b -> a
const (m a -> r -> m a) -> (IO a -> m a) -> IO a -> r -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
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 :: m a -> ReaderC r m a
lift = (r -> m a) -> ReaderC r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC ((r -> m a) -> ReaderC r m a)
-> (m a -> r -> m a) -> m a -> ReaderC r m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> r -> m a
forall a b. a -> b -> a
const
  {-# INLINE lift #-}

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