{-# LANGUAGE AllowAmbiguousTypes #-}
module Polysemy.Final.MTL
  (
    module Polysemy.Final
  , errorToFinal
  , readerToFinal
  , stateToEmbed
  , writerToFinal
  ) where

import Control.Monad.Error.Class hiding (Error)
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Writer.Class

import Polysemy
import Polysemy.Final
import Polysemy.Error hiding (throw, catch)
import Polysemy.Reader hiding (ask, local)
import Polysemy.State hiding (get, put)
import Polysemy.Writer hiding (tell, listen, pass)

-----------------------------------------------------------------------------
-- | Run an 'Error' effect through a final 'MonadError'
--
-- /Beware/: Effects that aren't interpreted in terms of the final
-- monad will have local state semantics in regards to 'Error' effects
-- interpreted this way. See 'Final'.
errorToFinal :: forall m e r a
              . (Member (Final m) r, MonadError e m)
             => Sem (Error e ': r) a
             -> Sem r a
errorToFinal :: Sem (Error e : r) a -> Sem r a
errorToFinal = forall (m :: * -> *) (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Final m) r =>
(forall x (rInitial :: EffectRow).
 e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Final m) r =>
(forall x (rInitial :: EffectRow).
 e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
interpretFinal @m ((forall x (rInitial :: EffectRow).
  Error e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
 -> Sem (Error e : r) a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
    Error e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (Error e : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Throw e   -> m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x)))
-> m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a b. (a -> b) -> a -> b
$ e -> m (f x)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
  Catch m h -> do
    m (f x)
m' <- Sem rInitial x -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial x
m
    f e -> m (f x)
h' <- (e -> Sem rInitial x)
-> Sem (WithStrategy m f (Sem rInitial)) (f e -> m (f x))
forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
bindS e -> Sem rInitial x
h
    f ()
s  <- Sem (WithStrategy m f (Sem rInitial)) (f ())
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
    m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x)))
-> m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a b. (a -> b) -> a -> b
$ m (f x)
m' m (f x) -> (e -> m (f x)) -> m (f x)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (f e -> m (f x)
h' (f e -> m (f x)) -> (e -> f e) -> e -> m (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> f () -> f e
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))
{-# INLINE errorToFinal #-}

-----------------------------------------------------------------------------
-- | Run a 'Reader' effect through a final 'MonadReader'
--
-- /Beware/: Effects that aren't interpreted in terms of the final
-- monad will have local state semantics in regards to 'Reader' effects
-- interpreted this way. See 'Final'.
readerToFinal :: forall m i r a
               . (Member (Final m) r, MonadReader i m)
              => Sem (Reader i ': r) a
              -> Sem r a
readerToFinal :: Sem (Reader i : r) a -> Sem r a
readerToFinal = forall (m :: * -> *) (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Final m) r =>
(forall x (rInitial :: EffectRow).
 e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Final m) r =>
(forall x (rInitial :: EffectRow).
 e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
interpretFinal @m ((forall x (rInitial :: EffectRow).
  Reader i (Sem rInitial) x -> Strategic m (Sem rInitial) x)
 -> Sem (Reader i : r) a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
    Reader i (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (Reader i : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Reader i (Sem rInitial) x
Ask       -> m x -> Strategic m (Sem rInitial) x
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS m x
forall r (m :: * -> *). MonadReader r m => m r
ask
  Local f m -> do
    m (f x)
m' <- Sem rInitial x -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial x
m
    m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x)))
-> m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a b. (a -> b) -> a -> b
$ (i -> i) -> m (f x) -> m (f x)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local i -> i
f m (f x)
m'
{-# INLINE readerToFinal #-}

-----------------------------------------------------------------------------
-- | Run a 'State' effect in terms of an underlying 'MonadState' instance
--
-- Although this is not a 'Final' interpreter, as the target monad need not
-- actually be the final monad, 'stateToEmbed' still possesses the
-- unusual semantics of interpreters that runs
-- effects by embedding them into another monad.
--
-- /Beware/: Effects that aren't interpreted in terms of the embedded
-- monad will have local state semantics in regards to 'State' effects
-- interpreted this way. See 'Final'.
stateToEmbed :: forall m s r a
              . (Member (Embed m) r, MonadState s m)
             => Sem (State s ': r) a
             -> Sem r a
stateToEmbed :: Sem (State s : r) a -> Sem r a
stateToEmbed = (forall (rInitial :: EffectRow) x.
 State s (Sem rInitial) x -> Sem r x)
-> Sem (State s : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  State s (Sem rInitial) x -> Sem r x)
 -> Sem (State s : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    State s (Sem rInitial) x -> Sem r x)
-> Sem (State s : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  State s (Sem rInitial) x
Get   -> m x -> Sem r x
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed @m m x
forall s (m :: * -> *). MonadState s m => m s
get
  Put s -> m () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed @m (s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
s)
{-# INLINE stateToEmbed #-}

-----------------------------------------------------------------------------
-- | Run a 'Writer' effect through a final 'MonadWriter'
--
-- /Beware/: Effects that aren't interpreted in terms of the final
-- monad will have local state semantics in regards to 'Writer' effects
-- interpreted this way. See 'Final'.
writerToFinal :: forall m o r a
               . (Member (Final m) r, MonadWriter o m)
              => Sem (Writer o ': r) a
              -> Sem r a
writerToFinal :: Sem (Writer o : r) a -> Sem r a
writerToFinal = forall (m :: * -> *) (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Final m) r =>
(forall x (rInitial :: EffectRow).
 e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Final m) r =>
(forall x (rInitial :: EffectRow).
 e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
interpretFinal @m ((forall x (rInitial :: EffectRow).
  Writer o (Sem rInitial) x -> Strategic m (Sem rInitial) x)
 -> Sem (Writer o : r) a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
    Writer o (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (Writer o : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Tell s    -> m () -> Strategic m (Sem rInitial) ()
forall (m :: * -> *) a (n :: * -> *).
Functor m =>
m a -> Strategic m n a
liftS (o -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell o
s)
  Listen m -> do
    m (f a1)
m' <- Sem rInitial a1 -> Sem (WithStrategy m f (Sem rInitial)) (m (f a1))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial a1
m
    m (f (o, a1))
-> Sem (WithStrategy m f (Sem rInitial)) (m (f (o, a1)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (f (o, a1))
 -> Sem (WithStrategy m f (Sem rInitial)) (m (f (o, a1))))
-> m (f (o, a1))
-> Sem (WithStrategy m f (Sem rInitial)) (m (f (o, a1)))
forall a b. (a -> b) -> a -> b
$
      (\ ~(f a1
s, o
o) -> (,) o
o (a1 -> (o, a1)) -> f a1 -> f (o, a1)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a1
s) ((f a1, o) -> f (o, a1)) -> m (f a1, o) -> m (f (o, a1))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (f a1) -> m (f a1, o)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen m (f a1)
m'
  Pass m -> do
    m (f (o -> o, x))
m'  <- Sem rInitial (o -> o, x)
-> Sem (WithStrategy m f (Sem rInitial)) (m (f (o -> o, x)))
forall (n :: * -> *) a (m :: * -> *) (f :: * -> *).
n a -> Sem (WithStrategy m f n) (m (f a))
runS Sem rInitial (o -> o, x)
m
    Inspector f
ins <- Sem (WithStrategy m f (Sem rInitial)) (Inspector f)
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (Inspector f)
getInspectorS
    m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x)))
-> m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a b. (a -> b) -> a -> b
$ m (f x, o -> o) -> m (f x)
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (m (f x, o -> o) -> m (f x)) -> m (f x, o -> o) -> m (f x)
forall a b. (a -> b) -> a -> b
$ do
      f (o -> o, x)
t <- m (f (o -> o, x))
m'
      let f :: o -> o
f = (o -> o) -> ((o -> o, x) -> o -> o) -> Maybe (o -> o, x) -> o -> o
forall b a. b -> (a -> b) -> Maybe a -> b
maybe o -> o
forall a. a -> a
id (o -> o, x) -> o -> o
forall a b. (a, b) -> a
fst (Inspector f -> f (o -> o, x) -> Maybe (o -> o, x)
forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins f (o -> o, x)
t)
      (f x, o -> o) -> m (f x, o -> o)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((o -> o, x) -> x) -> f (o -> o, x) -> f x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (o -> o, x) -> x
forall a b. (a, b) -> b
snd f (o -> o, x)
t, o -> o
f)
{-# INLINE writerToFinal #-}