module Polysemy.Final.MTL
(
module Polysemy.Final
, runErrorFinal
, runReaderFinal
, runStateFinal
, runWriterFinal
) 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)
runErrorFinal :: (Member (Final m) r, MonadError e m)
=> Sem (Error e ': r) a
-> Sem r a
runErrorFinal = interpretFinal $ \case
Throw e -> pure $ throwError e
Catch m h -> do
m' <- runS m
h' <- bindS h
s <- getInitialStateS
pure $ m' `catchError` (h' . (<$ s))
{-# INLINE runErrorFinal #-}
runReaderFinal :: (Member (Final m) r, MonadReader i m)
=> Sem (Reader i ': r) a
-> Sem r a
runReaderFinal = interpretFinal $ \case
Ask -> liftS ask
Local f m -> do
m' <- runS m
pure $ local f m'
{-# INLINE runReaderFinal #-}
runStateFinal :: (Member (Embed m) r, MonadState s m)
=> Sem (State s ': r) a
-> Sem r a
runStateFinal = interpret $ \case
Get -> embed get
Put s -> embed (put s)
{-# INLINE runStateFinal #-}
runWriterFinal :: (Member (Final m) r, MonadWriter o m)
=> Sem (Writer o ': r) a
-> Sem r a
runWriterFinal = interpretFinal $ \case
Tell s -> liftS (tell s)
Listen m -> do
m' <- runS m
pure $
(\ ~(s, o) -> (,) o <$> s) <$> listen m'
Pass m -> do
m' <- runS m
ins <- getInspectorS
pure $ pass $ do
t <- m'
let f = maybe id fst (inspect ins t)
pure (fmap snd t, f)
{-# INLINE runWriterFinal #-}