{-# LANGUAGE FlexibleInstances           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving  #-}
{-# LANGUAGE MultiParamTypeClasses       #-}
{-# LANGUAGE UndecidableInstances        #-}

module Polysemy.ConstraintAbsorber.MonadReader
  ( absorbReader
  ) where

import qualified Control.Monad.Reader.Class as S
import           Polysemy
import           Polysemy.ConstraintAbsorber
import           Polysemy.Reader


------------------------------------------------------------------------------
-- | Introduce a local 'S.MonadReader' constraint on 'Sem' --- allowing it to
-- interop nicely with MTL.
--
-- @since 0.3.0.0
absorbReader
    :: Member (Reader i) r
    => (S.MonadReader i (Sem r) => Sem r a)
       -- ^ A computation that requires an instance of 'S.MonadReader' for
       -- 'Sem'. This might be something with type @'S.MonadReader' r m => m a@.
    -> Sem r a
absorbReader :: (MonadReader i (Sem r) => Sem r a) -> Sem r a
absorbReader = ReaderDict i (Sem r)
-> (forall s.
    Reifies s (ReaderDict i (Sem r))
    :- MonadReader i (Action (Sem r) s))
-> (MonadReader i (Sem r) => Sem r a)
-> Sem r a
forall (p :: (* -> *) -> Constraint) (x :: (* -> *) -> * -> * -> *)
       d (r :: EffectRow) a.
d
-> (forall s. Reifies s d :- p (x (Sem r) s))
-> (p (Sem r) => Sem r a)
-> Sem r a
absorbWithSem @(S.MonadReader _) @Action
  (Sem r i
-> (forall a. (i -> i) -> Sem r a -> Sem r a)
-> ReaderDict i (Sem r)
forall i (m :: * -> *).
m i -> (forall a. (i -> i) -> m a -> m a) -> ReaderDict i m
ReaderDict Sem r i
forall i (r :: EffectRow). Member (Reader i) r => Sem r i
ask forall a. (i -> i) -> Sem r a -> Sem r a
forall i (r :: EffectRow) a.
Member (Reader i) r =>
(i -> i) -> Sem r a -> Sem r a
local)
  ((Reifies s (ReaderDict i (Sem r)) =>
 Dict (MonadReader i (Action (Sem r) s)))
-> Reifies s (ReaderDict i (Sem r))
   :- MonadReader i (Action (Sem r) s)
forall (a :: Constraint) (b :: Constraint). (a => Dict b) -> a :- b
Sub Reifies s (ReaderDict i (Sem r)) =>
Dict (MonadReader i (Action (Sem r) s))
forall (a :: Constraint). a => Dict a
Dict)
{-# INLINEABLE absorbReader #-}


------------------------------------------------------------------------------
-- | A dictionary of the functions we need to supply
-- to make an instance of Reader
data ReaderDict i m = ReaderDict
  { ReaderDict i m -> m i
ask_ :: m i
  , ReaderDict i m -> forall a. (i -> i) -> m a -> m a
local_ :: forall a. (i -> i) -> m a -> m a
  }


------------------------------------------------------------------------------
-- | Wrapper for a monadic action with phantom
-- type parameter for reflection.
-- Locally defined so that the instance we are going
-- to build with reflection must be coherent, that is
-- there cannot be orphans.
newtype Action m s a = Action { Action m s a -> m a
action :: m a }
  deriving (a -> Action m s b -> Action m s a
(a -> b) -> Action m s a -> Action m s b
(forall a b. (a -> b) -> Action m s a -> Action m s b)
-> (forall a b. a -> Action m s b -> Action m s a)
-> Functor (Action m s)
forall a b. a -> Action m s b -> Action m s a
forall a b. (a -> b) -> Action m s a -> Action m s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) k (s :: k) a b.
Functor m =>
a -> Action m s b -> Action m s a
forall (m :: * -> *) k (s :: k) a b.
Functor m =>
(a -> b) -> Action m s a -> Action m s b
<$ :: a -> Action m s b -> Action m s a
$c<$ :: forall (m :: * -> *) k (s :: k) a b.
Functor m =>
a -> Action m s b -> Action m s a
fmap :: (a -> b) -> Action m s a -> Action m s b
$cfmap :: forall (m :: * -> *) k (s :: k) a b.
Functor m =>
(a -> b) -> Action m s a -> Action m s b
Functor, Functor (Action m s)
a -> Action m s a
Functor (Action m s)
-> (forall a. a -> Action m s a)
-> (forall a b.
    Action m s (a -> b) -> Action m s a -> Action m s b)
-> (forall a b c.
    (a -> b -> c) -> Action m s a -> Action m s b -> Action m s c)
-> (forall a b. Action m s a -> Action m s b -> Action m s b)
-> (forall a b. Action m s a -> Action m s b -> Action m s a)
-> Applicative (Action m s)
Action m s a -> Action m s b -> Action m s b
Action m s a -> Action m s b -> Action m s a
Action m s (a -> b) -> Action m s a -> Action m s b
(a -> b -> c) -> Action m s a -> Action m s b -> Action m s c
forall a. a -> Action m s a
forall a b. Action m s a -> Action m s b -> Action m s a
forall a b. Action m s a -> Action m s b -> Action m s b
forall a b. Action m s (a -> b) -> Action m s a -> Action m s b
forall a b c.
(a -> b -> c) -> Action m s a -> Action m s b -> Action m s 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 (m :: * -> *) k (s :: k).
Applicative m =>
Functor (Action m s)
forall (m :: * -> *) k (s :: k) a.
Applicative m =>
a -> Action m s a
forall (m :: * -> *) k (s :: k) a b.
Applicative m =>
Action m s a -> Action m s b -> Action m s a
forall (m :: * -> *) k (s :: k) a b.
Applicative m =>
Action m s a -> Action m s b -> Action m s b
forall (m :: * -> *) k (s :: k) a b.
Applicative m =>
Action m s (a -> b) -> Action m s a -> Action m s b
forall (m :: * -> *) k (s :: k) a b c.
Applicative m =>
(a -> b -> c) -> Action m s a -> Action m s b -> Action m s c
<* :: Action m s a -> Action m s b -> Action m s a
$c<* :: forall (m :: * -> *) k (s :: k) a b.
Applicative m =>
Action m s a -> Action m s b -> Action m s a
*> :: Action m s a -> Action m s b -> Action m s b
$c*> :: forall (m :: * -> *) k (s :: k) a b.
Applicative m =>
Action m s a -> Action m s b -> Action m s b
liftA2 :: (a -> b -> c) -> Action m s a -> Action m s b -> Action m s c
$cliftA2 :: forall (m :: * -> *) k (s :: k) a b c.
Applicative m =>
(a -> b -> c) -> Action m s a -> Action m s b -> Action m s c
<*> :: Action m s (a -> b) -> Action m s a -> Action m s b
$c<*> :: forall (m :: * -> *) k (s :: k) a b.
Applicative m =>
Action m s (a -> b) -> Action m s a -> Action m s b
pure :: a -> Action m s a
$cpure :: forall (m :: * -> *) k (s :: k) a.
Applicative m =>
a -> Action m s a
$cp1Applicative :: forall (m :: * -> *) k (s :: k).
Applicative m =>
Functor (Action m s)
Applicative, Applicative (Action m s)
a -> Action m s a
Applicative (Action m s)
-> (forall a b.
    Action m s a -> (a -> Action m s b) -> Action m s b)
-> (forall a b. Action m s a -> Action m s b -> Action m s b)
-> (forall a. a -> Action m s a)
-> Monad (Action m s)
Action m s a -> (a -> Action m s b) -> Action m s b
Action m s a -> Action m s b -> Action m s b
forall a. a -> Action m s a
forall a b. Action m s a -> Action m s b -> Action m s b
forall a b. Action m s a -> (a -> Action m s b) -> Action m s 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 (m :: * -> *) k (s :: k).
Monad m =>
Applicative (Action m s)
forall (m :: * -> *) k (s :: k) a. Monad m => a -> Action m s a
forall (m :: * -> *) k (s :: k) a b.
Monad m =>
Action m s a -> Action m s b -> Action m s b
forall (m :: * -> *) k (s :: k) a b.
Monad m =>
Action m s a -> (a -> Action m s b) -> Action m s b
return :: a -> Action m s a
$creturn :: forall (m :: * -> *) k (s :: k) a. Monad m => a -> Action m s a
>> :: Action m s a -> Action m s b -> Action m s b
$c>> :: forall (m :: * -> *) k (s :: k) a b.
Monad m =>
Action m s a -> Action m s b -> Action m s b
>>= :: Action m s a -> (a -> Action m s b) -> Action m s b
$c>>= :: forall (m :: * -> *) k (s :: k) a b.
Monad m =>
Action m s a -> (a -> Action m s b) -> Action m s b
$cp1Monad :: forall (m :: * -> *) k (s :: k).
Monad m =>
Applicative (Action m s)
Monad)


------------------------------------------------------------------------------
-- | Given a reifiable mtl Reader dictionary,
-- we can make an instance of @MonadReader@ for the action
-- wrapped in @Action@.
instance ( Monad m
         , Reifies s' (ReaderDict i m)
         ) => S.MonadReader i (Action m s') where
  ask :: Action m s' i
ask = m i -> Action m s' i
forall k k (m :: k -> *) (s :: k) (a :: k). m a -> Action m s a
Action (m i -> Action m s' i) -> m i -> Action m s' i
forall a b. (a -> b) -> a -> b
$ ReaderDict i m -> m i
forall i (m :: * -> *). ReaderDict i m -> m i
ask_ (ReaderDict i m -> m i) -> ReaderDict i m -> m i
forall a b. (a -> b) -> a -> b
$ Proxy s' -> ReaderDict i m
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect (Proxy s' -> ReaderDict i m) -> Proxy s' -> ReaderDict i m
forall a b. (a -> b) -> a -> b
$ Proxy s'
forall k (t :: k). Proxy t
Proxy @s'
  {-# INLINEABLE ask #-}
  local :: (i -> i) -> Action m s' a -> Action m s' a
local i -> i
f Action m s' a
m = m a -> Action m s' a
forall k k (m :: k -> *) (s :: k) (a :: k). m a -> Action m s a
Action (m a -> Action m s' a) -> m a -> Action m s' a
forall a b. (a -> b) -> a -> b
$ ReaderDict i m -> (i -> i) -> m a -> m a
forall i (m :: * -> *).
ReaderDict i m -> forall a. (i -> i) -> m a -> m a
local_ (Proxy s' -> ReaderDict i m
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect (Proxy s' -> ReaderDict i m) -> Proxy s' -> ReaderDict i m
forall a b. (a -> b) -> a -> b
$ Proxy s'
forall k (t :: k). Proxy t
Proxy @s') i -> i
f (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ Action m s' a -> m a
forall k (m :: k -> *) k (s :: k) (a :: k). Action m s a -> m a
action Action m s' a
m
  {-# INLINEABLE local #-}