{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, UndecidableInstances #-}
module Control.Effect.Reader
( -- * Reader effect
  Reader(..)
, ask
, asks
, local
  -- * Reader carrier
, runReader
, ReaderC(..)
  -- * Re-exports
, Carrier
, Member
, run
) where

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

data Reader r m k
  = Ask (r -> m k)
  | forall b . Local (r -> r) (m b) (b -> m k)

deriving instance Functor m => Functor (Reader r m)

instance HFunctor (Reader r) where
  hmap :: (forall x. m x -> n x) -> Reader r m a -> Reader r n a
hmap f :: forall x. m x -> n x
f (Ask k :: r -> m a
k)       = (r -> n a) -> Reader r n a
forall r (m :: * -> *) k. (r -> m k) -> Reader r m k
Ask           (m a -> n a
forall x. m x -> n x
f (m a -> n a) -> (r -> m a) -> r -> n a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> m a
k)
  hmap f :: forall x. m x -> n x
f (Local g :: r -> r
g m :: m b
m k :: b -> m a
k) = (r -> r) -> n b -> (b -> n a) -> Reader r n a
forall r (m :: * -> *) k b.
(r -> r) -> m b -> (b -> m k) -> Reader r m k
Local r -> r
g (m b -> n b
forall x. m x -> n x
f m b
m) (m a -> n a
forall x. m x -> n x
f (m a -> n a) -> (b -> m a) -> b -> n a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> m a
k)

instance Effect (Reader r) where
  handle :: f ()
-> (forall x. f (m x) -> n (f x))
-> Reader r m a
-> Reader r n (f a)
handle state :: f ()
state handler :: forall x. f (m x) -> n (f x)
handler (Ask k :: r -> m a
k)       = (r -> n (f a)) -> Reader r n (f a)
forall r (m :: * -> *) k. (r -> m k) -> Reader r m k
Ask (f (m a) -> n (f a)
forall x. f (m x) -> n (f x)
handler (f (m a) -> n (f a)) -> (r -> f (m a)) -> r -> n (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m a -> f () -> f (m a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
state) (m a -> f (m a)) -> (r -> m a) -> r -> f (m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> m a
k)
  handle state :: f ()
state handler :: forall x. f (m x) -> n (f x)
handler (Local f :: r -> r
f m :: m b
m k :: b -> m a
k) = (r -> r) -> n (f b) -> (f b -> n (f a)) -> Reader r n (f a)
forall r (m :: * -> *) k b.
(r -> r) -> m b -> (b -> m k) -> Reader r m k
Local r -> r
f (f (m b) -> n (f b)
forall x. f (m x) -> n (f x)
handler (m b
m m b -> f () -> f (m b)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
state)) (f (m a) -> n (f a)
forall x. f (m x) -> n (f x)
handler (f (m a) -> n (f a)) -> (f b -> f (m a)) -> f b -> n (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> m a) -> f b -> f (m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> m a
k)

-- | Retrieve the environment value.
--
--   prop> run (runReader a ask) === a
ask :: (Member (Reader r) sig, Carrier sig m) => m r
ask :: m r
ask = Reader r m r -> m r
forall (effect :: (* -> *) -> * -> *) (sig :: (* -> *) -> * -> *)
       (m :: * -> *) a.
(Member effect sig, Carrier sig m) =>
effect m a -> m a
send ((r -> m r) -> Reader r m r
forall r (m :: * -> *) k. (r -> m k) -> Reader r m k
Ask r -> m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure)

-- | Project a function out of the current environment value.
--
--   prop> snd (run (runReader a (asks (applyFun f)))) === applyFun f a
asks :: (Member (Reader r) sig, Carrier sig m) => (r -> a) -> m a
asks :: (r -> a) -> m a
asks f :: r -> a
f = Reader r m a -> m a
forall (effect :: (* -> *) -> * -> *) (sig :: (* -> *) -> * -> *)
       (m :: * -> *) a.
(Member effect sig, Carrier sig m) =>
effect m a -> m a
send ((r -> m a) -> Reader r m a
forall r (m :: * -> *) k. (r -> m k) -> Reader r m k
Ask (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> (r -> a) -> r -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> a
f))

-- | Run a computation with an environment value locally modified by the passed function.
--
--   prop> run (runReader a (local (applyFun f) ask)) === applyFun f a
--   prop> run (runReader a ((,,) <$> ask <*> local (applyFun f) ask <*> ask)) === (a, applyFun f a, a)
local :: (Member (Reader r) sig, Carrier sig m) => (r -> r) -> m a -> m a
local :: (r -> r) -> m a -> m a
local f :: r -> r
f m :: m a
m = Reader r m a -> m a
forall (effect :: (* -> *) -> * -> *) (sig :: (* -> *) -> * -> *)
       (m :: * -> *) a.
(Member effect sig, Carrier sig m) =>
effect m a -> m a
send ((r -> r) -> m a -> (a -> m a) -> Reader r m a
forall r (m :: * -> *) k b.
(r -> r) -> m b -> (b -> m k) -> Reader r m k
Local r -> r
f m a
m a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)


-- | Run a 'Reader' effect with the passed environment value.
--
--   prop> run (runReader a (pure b)) === b
runReader :: r -> ReaderC r m a -> m a
runReader :: r -> ReaderC r m a -> m a
runReader r :: r
r c :: ReaderC r m a
c = ReaderC r m a -> r -> m a
forall r (m :: * -> *) a. ReaderC r m a -> r -> m a
runReaderC ReaderC r m a
c r
r
{-# INLINE runReader #-}

newtype ReaderC r m a = ReaderC { ReaderC r m a -> r -> m a
runReaderC :: 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 f :: r -> m (a -> b)
f <*> :: ReaderC r m (a -> b) -> ReaderC r m a -> ReaderC r m b
<*> ReaderC a :: 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 (<*>) #-}
  ReaderC u :: r -> m a
u *> :: ReaderC r m a -> ReaderC r m b -> ReaderC r m b
*> ReaderC v :: 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 -> 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 u :: r -> m a
u <* :: ReaderC r m a -> ReaderC r m b -> ReaderC r m a
<* ReaderC v :: 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 -> 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 l :: r -> m a
l <|> :: ReaderC r m a -> ReaderC r m a -> ReaderC r m a
<|> ReaderC r :: 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 a :: r -> m a
a >>= :: ReaderC r m a -> (a -> ReaderC r m b) -> ReaderC r m b
>>= f :: 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 -> 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 f :: 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 (\ r :: 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 MonadUnliftIO m => MonadUnliftIO (ReaderC r m) where
  askUnliftIO :: ReaderC r m (UnliftIO (ReaderC r m))
askUnliftIO = (r -> m (UnliftIO (ReaderC r m)))
-> ReaderC r m (UnliftIO (ReaderC r m))
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC ((r -> m (UnliftIO (ReaderC r m)))
 -> ReaderC r m (UnliftIO (ReaderC r m)))
-> (r -> m (UnliftIO (ReaderC r m)))
-> ReaderC r m (UnliftIO (ReaderC r m))
forall a b. (a -> b) -> a -> b
$ \r :: r
r -> (UnliftIO m -> IO (UnliftIO (ReaderC r m)))
-> m (UnliftIO (ReaderC r m))
forall (m :: * -> *) a.
MonadUnliftIO m =>
(UnliftIO m -> IO a) -> m a
withUnliftIO ((UnliftIO m -> IO (UnliftIO (ReaderC r m)))
 -> m (UnliftIO (ReaderC r m)))
-> (UnliftIO m -> IO (UnliftIO (ReaderC r m)))
-> m (UnliftIO (ReaderC r m))
forall a b. (a -> b) -> a -> b
$ \u :: UnliftIO m
u -> UnliftIO (ReaderC r m) -> IO (UnliftIO (ReaderC r m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall a. ReaderC r m a -> IO a) -> UnliftIO (ReaderC r m)
forall (m :: * -> *). (forall a. m a -> IO a) -> UnliftIO m
UnliftIO (\(ReaderC x) -> UnliftIO m -> m a -> IO a
forall (m :: * -> *). UnliftIO m -> forall a. m a -> IO a
unliftIO UnliftIO m
u (r -> m a
x r
r)))
  {-# INLINE askUnliftIO #-}
  withRunInIO :: ((forall a. ReaderC r m a -> IO a) -> IO b) -> ReaderC r m b
withRunInIO inner :: (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
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
$ \go :: forall a. m a -> IO a
go -> (forall a. ReaderC r m a -> IO a) -> IO b
inner (m a -> IO a
forall a. m a -> IO a
go (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 #-}

instance Carrier sig m => Carrier (Reader r :+: sig) (ReaderC r m) where
  eff :: (:+:) (Reader r) sig (ReaderC r m) a -> ReaderC r m a
eff (L (Ask       k :: r -> ReaderC r m a
k)) = (r -> m a) -> ReaderC r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC (\ r :: r
r -> r -> ReaderC r m a -> m a
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader r
r (r -> ReaderC r m a
k r
r))
  eff (L (Local f :: r -> r
f m :: ReaderC r m b
m k :: b -> ReaderC r m a
k)) = (r -> m b) -> ReaderC r m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC (\ r :: r
r -> r -> ReaderC r m b -> m b
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader (r -> r
f r
r) ReaderC r m b
m) ReaderC r m b -> (b -> ReaderC r m a) -> ReaderC r m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> ReaderC r m a
k
  eff (R other :: sig (ReaderC r m) a
other)         = (r -> m a) -> ReaderC r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC (\ r :: r
r -> sig m a -> m a
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Carrier sig m =>
sig m a -> m a
eff ((forall x. ReaderC r m x -> m x) -> sig (ReaderC r m) a -> sig m a
forall (h :: (* -> *) -> * -> *) (m :: * -> *) (n :: * -> *) a.
(HFunctor h, Functor m) =>
(forall x. m x -> n x) -> h m a -> h n a
hmap (r -> ReaderC r m x -> m x
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader r
r) sig (ReaderC r m) a
other))
  {-# INLINE eff #-}


-- $setup
-- >>> :seti -XFlexibleContexts
-- >>> import Test.QuickCheck
-- >>> import Control.Effect.Pure