WithWeaving.hs

module WithWeaving where

import Polysemy
import Polysemy.Internal
import Polysemy.Internal.Union
import Polysemy.Reader
import Control.Monad.Reader (MonadReader)
import qualified Control.Monad.Reader as MTL

data Lift' m z a where
  WithWeaving :: (forall f.
                      Functor f
                   => f ()
                   -> (forall x. f (z x) -> m (f x))
                   -> (forall x. f x -> Maybe x)
                   -> m (f a)
                 )
              -> Lift' m z a

withWeaving :: Member (Lift' m) r
            => (forall f.
                   Functor f
                => f ()
                -> (forall x. f (Sem r x) -> m (f x))
                -> (forall x. f x -> Maybe x)
                -> m (f a)
              )
           -> Sem r a
withWeaving wa = send $ WithWeaving wa

sendM' :: Monad m => Member (Lift' m) r => m a -> Sem r a
sendM' m = withWeaving $ \s _ _ -> fmap (<$ s) m

runM' :: Monad m => Sem [Lift' m, Lift m] a -> m a
runM' (Sem m) = m $ \u -> case decomp u of
  Right (Weaving (WithWeaving wav) s wv ex ins) ->
    ex <$> wav s (runM' . wv) ins
  Left g -> case extract g of
    Weaving (Lift m) s _ ex _ -> fmap (ex . (<$ s)) m

-- This interpreter is not possible to implement with 'Lift' alone.
runReaderInMonadReader :: (Member (Lift' m) r, MonadReader i m)
                       => Sem (Reader i ': r) a
                       -> Sem r a
runReaderInMonadReader (Sem sem) = sem $ \u -> case decomp u of
  Right (Weaving e s wv ex _) -> case e of
    Ask -> ex . (<$ s) <$> sendM' MTL.ask
    Local f m -> fmap ex $ withWeaving $ \s' wv' _ ->
      MTL.local
        f
        (wv' ( runReaderInMonadReader (wv (m <$ s)) <$ s'))
  Left g -> liftSem $ hoist runReaderInMonadReader g