How to incorporate MTL-style, CPS-style higher-order effect into polysemy?

Question

I am converting a codebase to use polysemy, and have run into trouble converting my uses of the LFresh typeclass from unbound-generics. The two operations I need have signatures

avoid :: LFresh m => [AnyName] -> m a -> m a
lunbind :: (LFresh m, Alpha p, Alpha t) => Bind p t -> ((p, t) -> m c) -> m c

which are clearly higher-order. I want to create an effect corresponding to the LFresh class, and run it via the LFreshM monad provided by unbound-generics. Here's what I have tried so far, making use of Final since that seemed to get me father than Embed (and I am fine with having LFreshM always be the last thing in the effect stack):

import           Polysemy
import           Polysemy.Final
import qualified Unbound.Generics.LocallyNameless as U

data LFresh m a where
  Avoid   :: [U.AnyName] -> m a -> LFresh m a
  LUnbind :: (U.Alpha p, U.Alpha t) => U.Bind p t -> ((p,t) -> m c) -> LFresh m c

makeSem ''LFresh

runLFresh :: Member (Final U.LFreshM) r => Sem (LFresh ': r) a -> Sem r a
runLFresh = interpretFinal @U.LFreshM $ \case
  Avoid xs m  -> do
    m' <- runS m
    pure (U.avoid xs m')
  LUnbind b k -> do
    k' <- bindS k
    pure (U.lunbind b k')

However, the case for LUnbind does not type check since k' :: f (p, t) -> U.LFreshM (f x) but it is expecting something of type (p, t) -> U.LFreshM (f x) as the second argument to U.lunbind; note the extra f in the type of k'.

I have other vague thoughts but I will leave it there for now, happy to clarify further. Not even sure if I'm on the right track. Ultimately, my real goal is just to "get polysemy to work with LFresh from unbound-generics", so if there's a better, completely different way to accomplish that I'm happy to hear about it too.

The reason I said "CPS-style" in the subject is the way that `lunbind` takes a `Bind` and a *continuation* specifying what to do with the destructured binding. The problem seems to be that `bindS` assumes that the input to the Kleisli arrow will be the result of another monadic action, which will end up wrapped in `f` after calling `runS`. However, that is not the case here. — Brent Yorgey, Jul 15 '21 at 00:36

score 2 · Accepted Answer · answered Jul 15 '21 at 16:17

After reading some blog posts like https://reasonablypolymorphic.com/blog/freer-higher-order-effects/index.html and https://reasonablypolymorphic.com/blog/tactics/index.html I think I figured it out. I just have to use getInitialStateS to get an f (), then use the ice-cream operator <$ to inject the (p,t) value into the f context before passing it to the result of bindT. I was scared off by commments implying that using something like getInitialStateS is more advanced and should be avoided, but now that I understand better what is going on I think it's exactly the right tool for this situation. Here's the resulting code. It typechecks, though I haven't been able to actually test it yet.

import           Polysemy
import           Polysemy.Final
import qualified Unbound.Generics.LocallyNameless as U

data LFresh m a where
  Avoid   :: [U.AnyName] -> m a -> LFresh m a
  LUnbind :: (U.Alpha p, U.Alpha t) => U.Bind p t -> ((p,t) -> m c) -> LFresh m c

makeSem ''LFresh

runLFresh :: Member (Final U.LFreshM) r => Sem (LFresh ': r) a -> Sem r a
runLFresh = interpretFinal @U.LFreshM $ \case
  Avoid xs m  -> do
    m' <- runS m
    pure (U.avoid xs m')
  LUnbind b k -> do
    s <- getInitialStateS
    k' <- bindS k
    pure (U.lunbind b (k' . (<$ s)))

How to incorporate MTL-style, CPS-style higher-order effect into polysemy?

1 Answers1