Writing a discord library using Polysemy

Recently I’ve migrated my discord library from mtl/transformers to polysemy after reading as many blog posts as I could find on it. My main reasons for wanting to migrate were escaping from having to write newtypes and all N instances every time I had a more than one effect in my stack, and how little boilerplate polysemy requires to write new effects.

In this¹ and some upcoming blog post I’ll be writing about the challenges I faced and solved² while going about the conversion.

Logging

The first effect that I converted from mtl to Polysemy was logging, originally I was using simple-log because I liked being able have areas of code run inside logging ‘scopes’, at the time co-log-polysemy was the only existing logging framework for polysemy and I was planning to use it, but instead I found di and decided to write a Polysemy effect for it.

I’ve updated this post with how the Di effect is implemented now, and left the old one in for reference.

Current implementation

The current way I implement the logging effect is:

data Di level path msg m a where
  Log    :: level -> msg -> Di level path msg m ()
  Flush  :: Di level path msg m ()
  Local  :: (DC.Di level path msg -> DC.Di level path msg) -> m a -> Di level path msg m a
  Fetch  :: Di level path msg m (Maybe (DC.Di level path msg))

The Fetch action is used to retrieve the current Di value if there is one, an interpreter that doesn’t do anything may return Nothing.

The handler for the effect is defined as follows:

runDiToIOReader :: forall r a level msg. Members '[Embed IO, Reader (DC.Di level Df1.Path msg)] r
      => Sem (Di level Df1.Path msg ': r) a
      -> Sem r a
runDiToIOReader = interpretH $ \case
      Log level msg -> do
        di <- ask @(DC.Di level Df1.Path msg)
        (embed @IO $ DC.log di level msg) >>= pureT
      Flush         -> do
        di <- ask @(DC.Di level Df1.Path msg)
        (embed @IO $ DC.flush di) >>= pureT
      Local f m     -> do
        m' <- runDiToIOReader <$> runT m
        raise $ Polysemy.Reader.local @(DC.Di level Df1.Path msg) f m'
      Fetch -> do
        di <- Just <$> ask @(DC.Di level Df1.Path msg)
        pureT di

runDiToIO :: forall r level msg a. Member (Embed IO) r
  => DC.Di level Df1.Path msg
  -> Sem (Di level Df1.Path msg ': r) a
  -> Sem r a
runDiToIO di = runReader di . runDiToIOReader . raiseUnder

We make use of the existing Reader effect to manage holding the Di value for us.

Additionally an interpreter can be defined that does nothing at all:

runDiNoop :: forall r level msg a. Sem (Di level Df1.Path msg ': r) a -> Sem r a
runDiNoop = interpretH \case
      Log _level _msg -> pureT ()
      Flush           -> pureT ()
      Local _f  m     -> runDiNoop <$> runT m >>= raise
      Fetch           -> pureT Nothing

After writing the interpreter, some helper functions can be written, they’re fairly repetitive so I’ll only include the first few:

push :: forall level msg r a. Member (Di level Df1.Path msg) r => Df1.Segment -> Sem r a -> Sem r a
push s = local @level @Df1.Path @msg (Df1.push s)

attr_ :: forall level msg r a. Member (Di level Df1.Path msg) r => Df1.Key -> Df1.Value -> Sem r a -> Sem r a
attr_ k v = local @level @Df1.Path @msg (Df1.attr_ k v)

attr :: forall value level msg r a. (Df1.ToValue value, Member (Di level Df1.Path msg) r) => Df1.Key -> value -> Sem r a -> Sem r a
attr k v = attr_ @level @msg k (Df1.value v)

debug :: forall msg path r. (Df1.ToMessage msg, Member (Di Df1.Level path Df1.Message) r) => msg -> Sem r ()
debug = log @Df1.Level @path D.Debug . Df1.message

Old attempt

The effect definition is the following:

data Di level path msg m a where
  Log    :: level -> msg -> Di level path msg m ()
  Flush  :: Di level path msg m ()
  Push   :: D.Segment -> m a -> Di level D.Path msg m a
  Attr_  :: D.Key -> D.Value -> m a -> Di level D.Path msg m a

I went on to write an interpreter making use of the existing framework in Di for printing out the log, which I found simple to write as it mostly consisted of playing jigsaw with types:

go :: Member (Embed IO) r0 => DC.Di level D.Path msg -> Sem (Di level D.Path msg ': r0) a0 -> Sem r0 a0
go di m = (`interpretH` m) $ \case
  Log level msg -> do
    t <- embed @IO $ DC.log di level msg
    pureT t
  Flush         -> do
    t <- embed @IO $ DC.flush di
    pureT t
  Push s m'     -> do
    mm <- runT m'
    raise $ go (Df1.push s di) mm
  Attr_ k v m'  -> do
    mm <- runT m'
    raise $ go (Df1.attr_ k v di) mm

The handlers for Log and Flush are simple enough, just embed the IO action and wrap the result, and the handlers for Push and Attr consist of running the nested action with the modified logger state, this is pretty much Reader and I could probably rewrite this to just reinterpret the Di effect in terms of Reader.

However this interpreter needs to get a Di.Core.Di from somewhere, and the only place to do that³ is to use Di.Core.new which has the signature:

new
  :: forall m level path msg a
  .  (MonadIO m, Ex.MonadMask m)
  => (Log level path msg -> IO ())
  -> (Di level path msg -> m a)
  -> m a

That MonadMask constraint means that we can’t just use polysemy’s Sem r monad, my first resolution to this was to copy the source of new and replace Control.Exception.Safe.finally with polysemy’s Resource.finally⁴

This way required too much hackery for my liking, so I spent some time figuring out how to lower a Member (Embed IO) r => Sem r a to IO a, and luckily the Resource effect does pretty much what I want to do already, so my current solution is to create a higher order effect with a single operation:

data DiIOInner m a where
  RunDiIOInner :: (DC.Log level D.Path msg -> IO ()) -> (DC.Di level D.Path msg -> m a) -> DiIOInner m a

And define an interpreter:

diToIO :: forall r a. Member (Embed IO) r => Sem (DiIOInner ': r) a -> Sem r a
diToIO = interpretH
  (\case RunDiIOInner commit a -> do
           istate <- getInitialStateT
           ma <- bindT a

           withLowerToIO $ \lower finish -> do
             let done :: Sem (DiIOInner ': r) x -> IO x
                 done = lower . raise . diToIO

             DC.new commit (\di -> do
                               res <- done (ma $ istate $> di)
                               finish
                               pure res))

This effect is only ever used internally in the implementation of runDiToIO:

runDiToIO
  :: forall r level msg a.
  Member (Embed IO) r
  => (DC.Log level D.Path msg -> IO ())
  -> Sem (Di level D.Path msg ': r) a
  -> Sem r a
runDiToIO commit m = diToIO $ runDiIOInner commit (`go` raiseUnder m)
  where
    go :: -- ...

I’m not sure if this is the best way to perform the ritual of lowering the Sem monad to IO, but I can’t see any way to perform it without having the ad-hoc effect.

Anyway, after writing the interpreter, the helper functions can be written, they’re fairly repetitive so I’ll only include the first few:

runDiToStderrIO :: Member (Embed IO) r => Sem (Di D.Level D.Path D.Message ': r) a -> Sem r a
runDiToStderrIO m = do
  commit <- embed @IO $ DH.stderr Df1.df1
  runDiToIO commit m

attr :: forall value level msg r a. (D.ToValue value, Member (Di level D.Path msg) r) => D.Key -> value -> Sem r a -> Sem r a
attr k v = attr_ @level @msg k (D.value v)

debug :: forall msg path r. (D.ToMessage msg, Member (Di D.Level path D.Message) r) => msg -> Sem r ()
debug = log @D.Level @path D.Debug . D.message

info :: forall msg path r. (D.ToMessage msg, Member (Di D.Level path D.Message) r) => msg -> Sem r ()
info = log @D.Level @path D.Info . D.message

The manual type applications would normally not be necessary if you were to use Polysemy.Plugin, but haddock currently (GHC 8.6.5) dies when it tries to build docs with the plugin enabled.

Usage

Now that the logger effect is written, we can use it like so:

import qualified Df1
import           DiPolysemy
import           Polysemy
import           Prelude                     hiding ( error )

main :: IO ()
main = runM . runDiToStderrIO $ logTest

logTest :: Member (Di Df1.Level Df1.Path Df1.Message) r => Sem r ()
logTest = do
  info_ "hello"
  notice_ "this is a notice"
  push "some-scope" $ do
    warning_ "this is inside a scope"
    attr "x" (4 :: Int) $ do
      debug_ "this one has an attribute"
  emergency_ "and we're done"

Which produces the following:

2020-04-25T03:59:44.452126488Z INFO hello
2020-04-25T03:59:44.452136280Z NOTICE this is a notice
2020-04-25T03:59:44.452147183Z /some-scope WARNING this is inside a scope
2020-04-25T03:59:44.452156206Z /some-scope x=4 DEBUG this one has an attribute
2020-04-25T03:59:44.452162458Z EMERGENCY and we're done

This blog post was sponsored by theophile.choutri.eu/microfund ↩︎
Although some of my solutions I feel aren’t the best, and I’d love to be made aware of any alternate solutions ↩︎
Without writing my own logger ↩︎
Though this implementation probably doesn’t respect async exceptions correctly in some way. ↩︎

Writing a discord library using Polysemy

[Ben Simms]

2020/04/24

Logging

Current implementation

Old attempt

Usage