Skip to content

Instantly share code, notes, and snippets.

@KingoftheHomeless

KingoftheHomeless/NotQuiteWeave.hs

Last active October 31, 2020 10:11
Show Gist options
  • Save KingoftheHomeless/a79046a3e77d0660997423f21624dd6c to your computer and use it in GitHub Desktop.
Save KingoftheHomeless/a79046a3e77d0660997423f21624dd6c to your computer and use it in GitHub Desktop.
Download ZIP
interpretHGood
Raw
NotQuiteWeave.hs
-- Let Sem and Union be defined as they are in polysemy.
data Weaving e m a where
Weaving :: MonadTransControlish t
=> e q a
-> (forall x. q x -> t m x)
-> (forall z x. Monad z => t z x -> z (StT t x))
-> (StT t a -> b)
-> Weaving e m b
class ( MonadTrans t
, forall z. Monad z => Monad (t z)
, Traversable (StT t)
)
=> MonadTransControlish t where
type StT t :: * -> *
liftWith :: Monad m
=> ((forall z x. Monad z => t z x -> z (StT t x)) -> m a)
-> t m a
restoreT :: Monad m => m (StT t a) -> t m a
controlT :: (MonadTransControlish t, Monad m)
=> ((forall z x. Monad z => t z x -> z (StT t x)) -> m (StT t a))
-> t m a
controlT main = liftWith main >>= restoreT . pure
hoistT :: (MonadTransControlish t, Monad m, Monad n) => (forall x. m x -> n x) -> t m a -> t n a
hoistT n m = controlT $ \lower ->
n (lower m)
-- BEGIN BOILERPLATE
-- | Composition of monad transformers and MonadTransControlish. Vital
-- to define 'weave'.
newtype ComposeT t (u :: (* -> *) -> * -> *) m a = ComposeT {
getComposeT :: t (u m) a
}
deriving ( Functor, Applicative, Monad)
instance ( MonadTrans t
, MonadTrans u
, forall m. Monad m => Monad (u m)
)
=> MonadTrans (ComposeT t u) where
lift m = ComposeT (lift (lift m))
instance ( MonadTransControlish t
, MonadTransControlish u
)
=> MonadTransControlish (ComposeT t u) where
type StT (ComposeT t u) = Compose (StT u) (StT t)
liftWith main = ComposeT $
liftWith $ \lowerT ->
liftWith $ \lowerU ->
main (\(ComposeT m) -> Compose <$> lowerU (lowerT m))
restoreT m = ComposeT (restoreT (restoreT (fmap getCompose m)))
hoist :: (Monad m, Monad n) => (forall x. m x -> n x) -> Union r m a -> Union r n a
hoist n (Union pr (Weaving e to col ex)) = Union pr $ Weaving e (hoistT n . to) col ex
weave :: MonadTransControlish t
=> (forall z x. Monad z => t z x -> z (StT t x))
-> Union r (t m) a
-> Union r m (StT t a)
weave col' (Union pr (Weaving e to col ex)) =
Union pr $
Weaving
e
(ComposeT . to)
(\(ComposeT m) -> Compose <$> col' (col m))
(fmap ex . getCompose)
initState :: Monad (t Identity)
=> (t Identity () -> Identity (StT t ()))
-> StT t ()
initState run_it = runIdentity $ run_it (pure ())
-- END BOILERPLATE
-- interpretHGood's handler works on a Sem with some unknown effect q thrown into the mix.
-- Since q is polymorphic, Member constraints will get stuck on it. To fix this, we wrap the occurence of
-- q with Opaque, which is a newtype whose constructor we don't expose.
newtype Opaque e m a = Opaque (e m a)
-- The payoff.
interpretHGood :: forall e r a
. ( forall z q x
. (forall y. z y -> Sem (Opaque q ': r) y)
-> e z x
-> Sem (Opaque q ': r) x
)
-> Sem (e ': r) a
-> Sem r a
interpretHGood h sem =
runSem sem $ \u -> case decomp (hoist (interpretHGood h) u) of
Right (Weaving e (to :: forall x. q x -> t (Sem r) x) col ex) ->
let
go :: forall x. Sem (Opaque (Embed (t (Sem r))) ': r) x -> t (Sem r) x
go sem' = runSem sem' $ \u' -> case decomp (hoist go u') of
Right (Weaving (Opaque (Embed z)) _ col' ex') -> (ex' . (<$ initState col')) <$> z
Left g -> controlT $ \lower -> liftSem $ weave lower g
in
fmap ex $ col $ go (h (embed . to) e)
Left g -> liftSem g
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment