content: {-# 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 = interpretFinal @m $ \case
    Throw e   -> pure $ throwError e
    Catch m h -> do
      m' <- runS m
      h' <- bindS h
      s  <- getInitialStateS
      pure $ m' `catchError` (h' . (<$ 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 = interpretFinal @m $ \case
    Ask       -> liftS ask
    Local f m -> do
      m' <- runS m
      pure $ local f 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 = interpret $ \case
    Get   -> embed @m get
    Put s -> embed @m (put 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 = interpretFinal @m $ \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 writerToFinal #-}
  