{-# LANGUAGE DeriveFunctor, ExplicitForAll, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}

{- |
This module provides an 'InterposeC' carrier capable of "eavesdropping" on requests
made to other carriers. This is a useful capability for dynamism in deeply-nested
effect stacks, but can lead to complicated control flow. Be careful.
-}
module Control.Effect.Interpose
  ( InterposeC (..)
  , runInterpose
  ) where

import Control.Applicative
import Control.Effect.Carrier
import Control.Effect.Reader
import Control.Monad (MonadPlus (..))
import qualified Control.Monad.Fail as Fail
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class

-- | 'runInterpose' takes a handler for a given effect (such as 'State' or 'Reader')
-- and runs that handler whenever an effect of that type is encountered. Within a
-- handler you can use all the capabilities of the underlying monad stack, including
-- the intercepted effect, and you can pass the effect on to the original handler
-- using 'send'.
--
--   prop> run . evalState @Int a . runInterpose @(State Int) (\op -> modify @Int (+b) *> send op) $ modify @Int (+b) === a + b + b
--
runInterpose :: (forall x . eff m x -> m x) -> InterposeC eff m a -> m a
runInterpose :: (forall x. eff m x -> m x) -> InterposeC eff m a -> m a
runInterpose handler :: forall x. eff m x -> m x
handler = Handler eff m -> ReaderC (Handler eff m) m a -> m a
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader ((forall x. eff m x -> m x) -> Handler eff m
forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
(forall x. eff m x -> m x) -> Handler eff m
Handler forall x. eff m x -> m x
handler) (ReaderC (Handler eff m) m a -> m a)
-> (InterposeC eff m a -> ReaderC (Handler eff m) m a)
-> InterposeC eff m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterposeC eff m a -> ReaderC (Handler eff m) m a
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
InterposeC eff m a -> ReaderC (Handler eff m) m a
runInterposeC

newtype InterposeC eff m a = InterposeC { InterposeC eff m a -> ReaderC (Handler eff m) m a
runInterposeC :: ReaderC (Handler eff m) m a }
  deriving (Applicative (InterposeC eff m)
InterposeC eff m a
Applicative (InterposeC eff m) =>
(forall a. InterposeC eff m a)
-> (forall a.
    InterposeC eff m a -> InterposeC eff m a -> InterposeC eff m a)
-> (forall a. InterposeC eff m a -> InterposeC eff m [a])
-> (forall a. InterposeC eff m a -> InterposeC eff m [a])
-> Alternative (InterposeC eff m)
InterposeC eff m a -> InterposeC eff m a -> InterposeC eff m a
InterposeC eff m a -> InterposeC eff m [a]
InterposeC eff m a -> InterposeC eff m [a]
forall a. InterposeC eff m a
forall a. InterposeC eff m a -> InterposeC eff m [a]
forall a.
InterposeC eff m a -> InterposeC eff m a -> InterposeC eff m a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
Alternative m =>
Applicative (InterposeC eff m)
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
Alternative m =>
InterposeC eff m a
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
Alternative m =>
InterposeC eff m a -> InterposeC eff m [a]
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
Alternative m =>
InterposeC eff m a -> InterposeC eff m a -> InterposeC eff m a
many :: InterposeC eff m a -> InterposeC eff m [a]
$cmany :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
Alternative m =>
InterposeC eff m a -> InterposeC eff m [a]
some :: InterposeC eff m a -> InterposeC eff m [a]
$csome :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
Alternative m =>
InterposeC eff m a -> InterposeC eff m [a]
<|> :: InterposeC eff m a -> InterposeC eff m a -> InterposeC eff m a
$c<|> :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
Alternative m =>
InterposeC eff m a -> InterposeC eff m a -> InterposeC eff m a
empty :: InterposeC eff m a
$cempty :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
Alternative m =>
InterposeC eff m a
$cp1Alternative :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
Alternative m =>
Applicative (InterposeC eff m)
Alternative, Functor (InterposeC eff m)
a -> InterposeC eff m a
Functor (InterposeC eff m) =>
(forall a. a -> InterposeC eff m a)
-> (forall a b.
    InterposeC eff m (a -> b)
    -> InterposeC eff m a -> InterposeC eff m b)
-> (forall a b c.
    (a -> b -> c)
    -> InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m c)
-> (forall a b.
    InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m b)
-> (forall a b.
    InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m a)
-> Applicative (InterposeC eff m)
InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m b
InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m a
InterposeC eff m (a -> b)
-> InterposeC eff m a -> InterposeC eff m b
(a -> b -> c)
-> InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m c
forall a. a -> InterposeC eff m a
forall a b.
InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m a
forall a b.
InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m b
forall a b.
InterposeC eff m (a -> b)
-> InterposeC eff m a -> InterposeC eff m b
forall a b c.
(a -> b -> c)
-> InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
Applicative m =>
Functor (InterposeC eff m)
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
Applicative m =>
a -> InterposeC eff m a
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative m =>
InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m a
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative m =>
InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m b
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative m =>
InterposeC eff m (a -> b)
-> InterposeC eff m a -> InterposeC eff m b
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m c
<* :: InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m a
$c<* :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative m =>
InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m a
*> :: InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m b
$c*> :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative m =>
InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m b
liftA2 :: (a -> b -> c)
-> InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m c
$cliftA2 :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m c
<*> :: InterposeC eff m (a -> b)
-> InterposeC eff m a -> InterposeC eff m b
$c<*> :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative m =>
InterposeC eff m (a -> b)
-> InterposeC eff m a -> InterposeC eff m b
pure :: a -> InterposeC eff m a
$cpure :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
Applicative m =>
a -> InterposeC eff m a
$cp1Applicative :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
Applicative m =>
Functor (InterposeC eff m)
Applicative, a -> InterposeC eff m b -> InterposeC eff m a
(a -> b) -> InterposeC eff m a -> InterposeC eff m b
(forall a b. (a -> b) -> InterposeC eff m a -> InterposeC eff m b)
-> (forall a b. a -> InterposeC eff m b -> InterposeC eff m a)
-> Functor (InterposeC eff m)
forall a b. a -> InterposeC eff m b -> InterposeC eff m a
forall a b. (a -> b) -> InterposeC eff m a -> InterposeC eff m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor m =>
a -> InterposeC eff m b -> InterposeC eff m a
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor m =>
(a -> b) -> InterposeC eff m a -> InterposeC eff m b
<$ :: a -> InterposeC eff m b -> InterposeC eff m a
$c<$ :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor m =>
a -> InterposeC eff m b -> InterposeC eff m a
fmap :: (a -> b) -> InterposeC eff m a -> InterposeC eff m b
$cfmap :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor m =>
(a -> b) -> InterposeC eff m a -> InterposeC eff m b
Functor, Applicative (InterposeC eff m)
a -> InterposeC eff m a
Applicative (InterposeC eff m) =>
(forall a b.
 InterposeC eff m a
 -> (a -> InterposeC eff m b) -> InterposeC eff m b)
-> (forall a b.
    InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m b)
-> (forall a. a -> InterposeC eff m a)
-> Monad (InterposeC eff m)
InterposeC eff m a
-> (a -> InterposeC eff m b) -> InterposeC eff m b
InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m b
forall a. a -> InterposeC eff m a
forall a b.
InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m b
forall a b.
InterposeC eff m a
-> (a -> InterposeC eff m b) -> InterposeC eff m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
Monad m =>
Applicative (InterposeC eff m)
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
Monad m =>
a -> InterposeC eff m a
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad m =>
InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m b
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad m =>
InterposeC eff m a
-> (a -> InterposeC eff m b) -> InterposeC eff m b
return :: a -> InterposeC eff m a
$creturn :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
Monad m =>
a -> InterposeC eff m a
>> :: InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m b
$c>> :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad m =>
InterposeC eff m a -> InterposeC eff m b -> InterposeC eff m b
>>= :: InterposeC eff m a
-> (a -> InterposeC eff m b) -> InterposeC eff m b
$c>>= :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad m =>
InterposeC eff m a
-> (a -> InterposeC eff m b) -> InterposeC eff m b
$cp1Monad :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
Monad m =>
Applicative (InterposeC eff m)
Monad, Monad (InterposeC eff m)
Monad (InterposeC eff m) =>
(forall a. String -> InterposeC eff m a)
-> MonadFail (InterposeC eff m)
String -> InterposeC eff m a
forall a. String -> InterposeC eff m a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
MonadFail m =>
Monad (InterposeC eff m)
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadFail m =>
String -> InterposeC eff m a
fail :: String -> InterposeC eff m a
$cfail :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadFail m =>
String -> InterposeC eff m a
$cp1MonadFail :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
MonadFail m =>
Monad (InterposeC eff m)
Fail.MonadFail, Monad (InterposeC eff m)
Monad (InterposeC eff m) =>
(forall a. (a -> InterposeC eff m a) -> InterposeC eff m a)
-> MonadFix (InterposeC eff m)
(a -> InterposeC eff m a) -> InterposeC eff m a
forall a. (a -> InterposeC eff m a) -> InterposeC eff m a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
MonadFix m =>
Monad (InterposeC eff m)
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadFix m =>
(a -> InterposeC eff m a) -> InterposeC eff m a
mfix :: (a -> InterposeC eff m a) -> InterposeC eff m a
$cmfix :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadFix m =>
(a -> InterposeC eff m a) -> InterposeC eff m a
$cp1MonadFix :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
MonadFix m =>
Monad (InterposeC eff m)
MonadFix, Monad (InterposeC eff m)
Monad (InterposeC eff m) =>
(forall a. IO a -> InterposeC eff m a)
-> MonadIO (InterposeC eff m)
IO a -> InterposeC eff m a
forall a. IO a -> InterposeC eff m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
MonadIO m =>
Monad (InterposeC eff m)
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadIO m =>
IO a -> InterposeC eff m a
liftIO :: IO a -> InterposeC eff m a
$cliftIO :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadIO m =>
IO a -> InterposeC eff m a
$cp1MonadIO :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
MonadIO m =>
Monad (InterposeC eff m)
MonadIO, Monad (InterposeC eff m)
Alternative (InterposeC eff m)
InterposeC eff m a
(Alternative (InterposeC eff m), Monad (InterposeC eff m)) =>
(forall a. InterposeC eff m a)
-> (forall a.
    InterposeC eff m a -> InterposeC eff m a -> InterposeC eff m a)
-> MonadPlus (InterposeC eff m)
InterposeC eff m a -> InterposeC eff m a -> InterposeC eff m a
forall a. InterposeC eff m a
forall a.
InterposeC eff m a -> InterposeC eff m a -> InterposeC eff m a
forall (m :: * -> *).
(Alternative m, Monad m) =>
(forall a. m a) -> (forall a. m a -> m a -> m a) -> MonadPlus m
forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
(Alternative m, Monad m) =>
Monad (InterposeC eff m)
forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
(Alternative m, Monad m) =>
Alternative (InterposeC eff m)
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
(Alternative m, Monad m) =>
InterposeC eff m a
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
(Alternative m, Monad m) =>
InterposeC eff m a -> InterposeC eff m a -> InterposeC eff m a
mplus :: InterposeC eff m a -> InterposeC eff m a -> InterposeC eff m a
$cmplus :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
(Alternative m, Monad m) =>
InterposeC eff m a -> InterposeC eff m a -> InterposeC eff m a
mzero :: InterposeC eff m a
$cmzero :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
(Alternative m, Monad m) =>
InterposeC eff m a
$cp2MonadPlus :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
(Alternative m, Monad m) =>
Monad (InterposeC eff m)
$cp1MonadPlus :: forall (eff :: (* -> *) -> * -> *) (m :: * -> *).
(Alternative m, Monad m) =>
Alternative (InterposeC eff m)
MonadPlus)

instance MonadTrans (InterposeC eff) where
  lift :: m a -> InterposeC eff m a
lift = ReaderC (Handler eff m) m a -> InterposeC eff m a
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
ReaderC (Handler eff m) m a -> InterposeC eff m a
InterposeC (ReaderC (Handler eff m) m a -> InterposeC eff m a)
-> (m a -> ReaderC (Handler eff m) m a)
-> m a
-> InterposeC eff m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderC (Handler eff m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

newtype Handler eff m = Handler (forall x . eff m x -> m x)

runHandler :: (HFunctor eff, Functor m) => Handler eff m -> eff (ReaderC (Handler eff m) m) a -> m a
runHandler :: Handler eff m -> eff (ReaderC (Handler eff m) m) a -> m a
runHandler h :: Handler eff m
h@(Handler handler :: forall x. eff m x -> m x
handler) = eff m a -> m a
forall x. eff m x -> m x
handler (eff m a -> m a)
-> (eff (ReaderC (Handler eff m) m) a -> eff m a)
-> eff (ReaderC (Handler eff m) m) a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. ReaderC (Handler eff m) m x -> m x)
-> eff (ReaderC (Handler eff m) m) a -> eff m a
forall (h :: (* -> *) -> * -> *) (m :: * -> *) (n :: * -> *) a.
(HFunctor h, Functor m) =>
(forall x. m x -> n x) -> h m a -> h n a
hmap (Handler eff m -> ReaderC (Handler eff m) m x -> m x
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader Handler eff m
h)

instance (HFunctor eff, Carrier sig m, Member eff sig) => Carrier sig (InterposeC eff m) where
  eff :: sig (InterposeC eff m) a -> InterposeC eff m a
eff (sig (InterposeC eff m) a
op :: sig (InterposeC eff m) a)
    | Just (eff (InterposeC eff m) a
op' :: eff (InterposeC eff m) a) <- sig (InterposeC eff m) a -> Maybe (eff (InterposeC eff m) a)
forall (sub :: (* -> *) -> * -> *) (sup :: (* -> *) -> * -> *)
       (m :: * -> *) a.
Member sub sup =>
sup m a -> Maybe (sub m a)
prj sig (InterposeC eff m) a
op = do
      Handler eff m
handler <- ReaderC (Handler eff m) m (Handler eff m)
-> InterposeC eff m (Handler eff m)
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
ReaderC (Handler eff m) m a -> InterposeC eff m a
InterposeC ReaderC (Handler eff m) m (Handler eff m)
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Member (Reader r) sig, Carrier sig m) =>
m r
ask
      m a -> InterposeC eff m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Handler eff m -> eff (ReaderC (Handler eff m) m) a -> m a
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
(HFunctor eff, Functor m) =>
Handler eff m -> eff (ReaderC (Handler eff m) m) a -> m a
runHandler Handler eff m
handler (eff (InterposeC eff m) a -> eff (ReaderC (Handler eff m) m) a
forall (sig :: (* -> *) -> * -> *) (f :: * -> *) (g :: * -> *) a.
(HFunctor sig, Functor f, Coercible f g) =>
sig f a -> sig g a
handleCoercible eff (InterposeC eff m) a
op'))
    | Bool
otherwise = ReaderC (Handler eff m) m a -> InterposeC eff m a
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
ReaderC (Handler eff m) m a -> InterposeC eff m a
InterposeC ((Handler eff m -> m a) -> ReaderC (Handler eff m) m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderC r m a
ReaderC (\ handler :: Handler eff m
handler -> sig m a -> m a
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Carrier sig m =>
sig m a -> m a
eff ((forall x. InterposeC eff m x -> m x)
-> sig (InterposeC eff 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 (Handler eff m -> ReaderC (Handler eff m) m x -> m x
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader Handler eff m
handler (ReaderC (Handler eff m) m x -> m x)
-> (InterposeC eff m x -> ReaderC (Handler eff m) m x)
-> InterposeC eff m x
-> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterposeC eff m x -> ReaderC (Handler eff m) m x
forall (eff :: (* -> *) -> * -> *) (m :: * -> *) a.
InterposeC eff m a -> ReaderC (Handler eff m) m a
runInterposeC) sig (InterposeC eff m) a
op)))

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