Last active
July 6, 2019 18:32
-
-
Save KingoftheHomeless/3a099d01548f1b4f3635c0d3665447da to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment