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) ----------------------------------------------------------------------------- -- | 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 'interpretFinal'. 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)) ----------------------------------------------------------------------------- -- | 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 'interpretFinal'. 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' ----------------------------------------------------------------------------- -- | Run a 'State' effect through a 'MonadState' -- -- Despite the name, the target monad need not actually be the final -- monad. The "-Final" suffix reflects that this interpreter -- has the unusual semantics of interpreters that runs -- effects by embedding them into another monad. -- -- /Beware/: Effects that aren't interpreted in terms of the final -- monad will have local state semantics in regards to 'State' effects -- interpreted this way. See 'interpretFinal'. runStateFinal :: (Member (Lift m) r, MonadState s m) => Sem (State s ': r) a -> Sem r a runStateFinal = interpret $ \case Get -> sendM get Put s -> sendM (put s) ----------------------------------------------------------------------------- -- | 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 'interpretFinal'. 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)