../writing-a-discord-library-using-polysemy

By Ben

Writing a discord library using Polysemy

Logging is cool

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[^fn:1] and some upcoming blog post I’ll be writing about the challenges I faced and solved[^fn:2] 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:

haskell
1
data Di level path msg m a where
2
  Log    :: level -> msg -> Di level path msg m ()
3
  Flush  :: Di level path msg m ()
4
  Local  :: (DC.Di level path msg -> DC.Di level path msg) -> m a -> Di level path msg m a
5
  Fetch  :: Di level path msg m (Maybe (DC.Di level path msg))
haskell
1
data Di level path msg m a where
2
  Log    :: level -> msg -> Di level path msg m ()
3
  Flush  :: Di level path msg m ()
4
  Local  :: (DC.Di level path msg -> DC.Di level path msg) -> m a -> Di level path msg m a
5
  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:

haskell
1
runDiToIOReader :: forall r a level msg. Members '[Embed IO, Reader (DC.Di level Df1.Path msg)] r
2
      => Sem (Di level Df1.Path msg ': r) a
3
      -> Sem r a
4
runDiToIOReader = interpretH $ \case
5
      Log level msg -> do
6
        di <- ask @(DC.Di level Df1.Path msg)
7
        (embed @IO $ DC.log di level msg) >>= pureT
8
      Flush         -> do
9
        di <- ask @(DC.Di level Df1.Path msg)
10
        (embed @IO $ DC.flush di) >>= pureT
11
      Local f m     -> do
12
        m' <- runDiToIOReader <$> runT m
13
        raise $ Polysemy.Reader.local @(DC.Di level Df1.Path msg) f m'
14
      Fetch -> do
15
        di <- Just <$> ask @(DC.Di level Df1.Path msg)
16
        pureT di
17
18
runDiToIO :: forall r level msg a. Member (Embed IO) r
19
  => DC.Di level Df1.Path msg
20
  -> Sem (Di level Df1.Path msg ': r) a
21
  -> Sem r a
22
runDiToIO di = runReader di . runDiToIOReader . raiseUnder
haskell
1
runDiToIOReader :: forall r a level msg. Members '[Embed IO, Reader (DC.Di level Df1.Path msg)] r
2
      => Sem (Di level Df1.Path msg ': r) a
3
      -> Sem r a
4
runDiToIOReader = interpretH $ \case
5
      Log level msg -> do
6
        di <- ask @(DC.Di level Df1.Path msg)
7
        (embed @IO $ DC.log di level msg) >>= pureT
8
      Flush         -> do
9
        di <- ask @(DC.Di level Df1.Path msg)
10
        (embed @IO $ DC.flush di) >>= pureT
11
      Local f m     -> do
12
        m' <- runDiToIOReader <$> runT m
13
        raise $ Polysemy.Reader.local @(DC.Di level Df1.Path msg) f m'
14
      Fetch -> do
15
        di <- Just <$> ask @(DC.Di level Df1.Path msg)
16
        pureT di
17
18
runDiToIO :: forall r level msg a. Member (Embed IO) r
19
  => DC.Di level Df1.Path msg
20
  -> Sem (Di level Df1.Path msg ': r) a
21
  -> Sem r a
22
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:

haskell
1
runDiNoop :: forall r level msg a. Sem (Di level Df1.Path msg ': r) a -> Sem r a
2
runDiNoop = interpretH \case
3
      Log _level _msg -> pureT ()
4
      Flush           -> pureT ()
5
      Local _f  m     -> runDiNoop <$> runT m >>= raise
6
      Fetch           -> pureT Nothing
haskell
1
runDiNoop :: forall r level msg a. Sem (Di level Df1.Path msg ': r) a -> Sem r a
2
runDiNoop = interpretH \case
3
      Log _level _msg -> pureT ()
4
      Flush           -> pureT ()
5
      Local _f  m     -> runDiNoop <$> runT m >>= raise
6
      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:

haskell
1
push :: forall level msg r a. Member (Di level Df1.Path msg) r => Df1.Segment -> Sem r a -> Sem r a
2
push s = local @level @Df1.Path @msg (Df1.push s)
3
4
attr_ :: forall level msg r a. Member (Di level Df1.Path msg) r => Df1.Key -> Df1.Value -> Sem r a -> Sem r a
5
attr_ k v = local @level @Df1.Path @msg (Df1.attr_ k v)
6
7
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
8
attr k v = attr_ @level @msg k (Df1.value v)
9
10
debug :: forall msg path r. (Df1.ToMessage msg, Member (Di Df1.Level path Df1.Message) r) => msg -> Sem r ()
11
debug = log @Df1.Level @path D.Debug . Df1.message
haskell
1
push :: forall level msg r a. Member (Di level Df1.Path msg) r => Df1.Segment -> Sem r a -> Sem r a
2
push s = local @level @Df1.Path @msg (Df1.push s)
3
4
attr_ :: forall level msg r a. Member (Di level Df1.Path msg) r => Df1.Key -> Df1.Value -> Sem r a -> Sem r a
5
attr_ k v = local @level @Df1.Path @msg (Df1.attr_ k v)
6
7
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
8
attr k v = attr_ @level @msg k (Df1.value v)
9
10
debug :: forall msg path r. (Df1.ToMessage msg, Member (Di Df1.Level path Df1.Message) r) => msg -> Sem r ()
11
debug = log @Df1.Level @path D.Debug . Df1.message

Old attempt

The effect definition is the following:

haskell
1
data Di level path msg m a where
2
  Log    :: level -> msg -> Di level path msg m ()
3
  Flush  :: Di level path msg m ()
4
  Push   :: D.Segment -> m a -> Di level D.Path msg m a
5
  Attr_  :: D.Key -> D.Value -> m a -> Di level D.Path msg m a
haskell
1
data Di level path msg m a where
2
  Log    :: level -> msg -> Di level path msg m ()
3
  Flush  :: Di level path msg m ()
4
  Push   :: D.Segment -> m a -> Di level D.Path msg m a
5
  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:

haskell
1
go :: Member (Embed IO) r0 => DC.Di level D.Path msg -> Sem (Di level D.Path msg ': r0) a0 -> Sem r0 a0
2
go di m = (`interpretH` m) $ \case
3
  Log level msg -> do
4
    t <- embed @IO $ DC.log di level msg
5
    pureT t
6
  Flush         -> do
7
    t <- embed @IO $ DC.flush di
8
    pureT t
9
  Push s m'     -> do
10
    mm <- runT m'
11
    raise $ go (Df1.push s di) mm
12
  Attr_ k v m'  -> do
13
    mm <- runT m'
14
    raise $ go (Df1.attr_ k v di) mm
haskell
1
go :: Member (Embed IO) r0 => DC.Di level D.Path msg -> Sem (Di level D.Path msg ': r0) a0 -> Sem r0 a0
2
go di m = (`interpretH` m) $ \case
3
  Log level msg -> do
4
    t <- embed @IO $ DC.log di level msg
5
    pureT t
6
  Flush         -> do
7
    t <- embed @IO $ DC.flush di
8
    pureT t
9
  Push s m'     -> do
10
    mm <- runT m'
11
    raise $ go (Df1.push s di) mm
12
  Attr_ k v m'  -> do
13
    mm <- runT m'
14
    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[^fn:3] is to use Di.Core.new which has the signature:

haskell
1
new
2
  :: forall m level path msg a
3
  .  (MonadIO m, Ex.MonadMask m)
4
  => (Log level path msg -> IO ())
5
  -> (Di level path msg -> m a)
6
  -> m a
haskell
1
new
2
  :: forall m level path msg a
3
  .  (MonadIO m, Ex.MonadMask m)
4
  => (Log level path msg -> IO ())
5
  -> (Di level path msg -> m a)
6
  -> 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[^fn:4]

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:

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

And define an interpreter:

haskell
1
diToIO :: forall r a. Member (Embed IO) r => Sem (DiIOInner ': r) a -> Sem r a
2
diToIO = interpretH
3
  (\case RunDiIOInner commit a -> do
4
           istate <- getInitialStateT
5
           ma <- bindT a
6
7
           withLowerToIO $ \lower finish -> do
8
             let done :: Sem (DiIOInner ': r) x -> IO x
9
                 done = lower . raise . diToIO
10
11
             DC.new commit (\di -> do
12
                               res <- done (ma $ istate $> di)
13
                               finish
14
                               pure res))
haskell
1
diToIO :: forall r a. Member (Embed IO) r => Sem (DiIOInner ': r) a -> Sem r a
2
diToIO = interpretH
3
  (\case RunDiIOInner commit a -> do
4
           istate <- getInitialStateT
5
           ma <- bindT a
6
7
           withLowerToIO $ \lower finish -> do
8
             let done :: Sem (DiIOInner ': r) x -> IO x
9
                 done = lower . raise . diToIO
10
11
             DC.new commit (\di -> do
12
                               res <- done (ma $ istate $> di)
13
                               finish
14
                               pure res))

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

haskell
1
runDiToIO
2
  :: forall r level msg a.
3
  Member (Embed IO) r
4
  => (DC.Log level D.Path msg -> IO ())
5
  -> Sem (Di level D.Path msg ': r) a
6
  -> Sem r a
7
runDiToIO commit m = diToIO $ runDiIOInner commit (`go` raiseUnder m)
8
  where
9
    go :: -- ...
haskell
1
runDiToIO
2
  :: forall r level msg a.
3
  Member (Embed IO) r
4
  => (DC.Log level D.Path msg -> IO ())
5
  -> Sem (Di level D.Path msg ': r) a
6
  -> Sem r a
7
runDiToIO commit m = diToIO $ runDiIOInner commit (`go` raiseUnder m)
8
  where
9
    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:

haskell
1
runDiToStderrIO :: Member (Embed IO) r => Sem (Di D.Level D.Path D.Message ': r) a -> Sem r a
2
runDiToStderrIO m = do
3
  commit <- embed @IO $ DH.stderr Df1.df1
4
  runDiToIO commit m
5
6
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
7
attr k v = attr_ @level @msg k (D.value v)
8
9
debug :: forall msg path r. (D.ToMessage msg, Member (Di D.Level path D.Message) r) => msg -> Sem r ()
10
debug = log @D.Level @path D.Debug . D.message
11
12
info :: forall msg path r. (D.ToMessage msg, Member (Di D.Level path D.Message) r) => msg -> Sem r ()
13
info = log @D.Level @path D.Info . D.message
haskell
1
runDiToStderrIO :: Member (Embed IO) r => Sem (Di D.Level D.Path D.Message ': r) a -> Sem r a
2
runDiToStderrIO m = do
3
  commit <- embed @IO $ DH.stderr Df1.df1
4
  runDiToIO commit m
5
6
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
7
attr k v = attr_ @level @msg k (D.value v)
8
9
debug :: forall msg path r. (D.ToMessage msg, Member (Di D.Level path D.Message) r) => msg -> Sem r ()
10
debug = log @D.Level @path D.Debug . D.message
11
12
info :: forall msg path r. (D.ToMessage msg, Member (Di D.Level path D.Message) r) => msg -> Sem r ()
13
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:

haskell
1
import qualified Df1
2
import           DiPolysemy
3
import           Polysemy
4
import           Prelude                     hiding ( error )
5
6
main :: IO ()
7
main = runM . runDiToStderrIO $ logTest
8
9
logTest :: Member (Di Df1.Level Df1.Path Df1.Message) r => Sem r ()
10
logTest = do
11
  info_ "hello"
12
  notice_ "this is a notice"
13
  push "some-scope" $ do
14
    warning_ "this is inside a scope"
15
    attr "x" (4 :: Int) $ do
16
      debug_ "this one has an attribute"
17
  emergency_ "and we're done"
haskell
1
import qualified Df1
2
import           DiPolysemy
3
import           Polysemy
4
import           Prelude                     hiding ( error )
5
6
main :: IO ()
7
main = runM . runDiToStderrIO $ logTest
8
9
logTest :: Member (Di Df1.Level Df1.Path Df1.Message) r => Sem r ()
10
logTest = do
11
  info_ "hello"
12
  notice_ "this is a notice"
13
  push "some-scope" $ do
14
    warning_ "this is inside a scope"
15
    attr "x" (4 :: Int) $ do
16
      debug_ "this one has an attribute"
17
  emergency_ "and we're done"

Which produces the following:

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

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