# Polysemy: Chasing Performance in Free Monads

# Polysemy

## Chasing Performance in Free Monads

**Sandy Maguire**sandy@sandymaguire.me

reasonablypolymorphic.com

github.com/isovector

Today’s slides:

- reasonablypolymorphic.com/polysemy-talk

Our codebase was written by contractors.

Big ball o’ IO spaghetti.

Impossible to test.

*Free monads* are what I think programming will look like in 30 years.

Write your applications in *domain specific language* designed for your exact problem.

*Run a series of transformations* to compile your high-level specification into lower-level DSLs.

Most programs are easy to describe.

The majority of a codebase is spent dealing with nitty-gritty details.

This is where most of the bugs are.

Let’s turn implementation details into library code!

# Example

Data ingestion service that:

- reads encrypted CSV files
- emits them in batches to a streaming HTTP service
- records statistics in Redis

```
ingest
:: ( Member (Input Record) r
, Member (Output Record) r
, Member (Output Stat) r
)
=> Eff r ()
ingest = input >>= \case
Nothing -> pure ()
Just record -> do
output record
output ProcessedRecordStat
ingest
```

Open Effects:

{ Input Record, Output Record, Output Stat }

Open Effects:

{ FileProvider, Output Record, Output Stat }

Open Effects:

{ FileProvider, Output Record, Output Stat, Encryption }

Open Effects:

{ FTP, Output Record, Output Stat, Encryption }

Open Effects:

{ FTP, Output [Record], Output Stat, Encryption }

```
main = ingest
& csvInput "file.csv"
& decryptFileProvider
& ftpFileProvider
& batch @Record 500
& postOutput @Record mkApiCall
```

Open Effects:

{ FTP, HTTP, Output Stat, Encryption }

```
main = ingest
& csvInput "file.csv"
& decryptFileProvider
& ftpFileProvider
& batch @Record 500
& postOutput @Record mkApiCall
& redisOuput @Stat mkRedisKey
```

Open Effects:

{FTP, HTTP, Encryption, Redis}

```
main = ingest
& csvInput "file.csv"
& decryptFileProvider
& ftpFileProvider
& batch @Record 500
& postOutput @Record mkApiCall
& redisOuput @Stat mkRedisKey
& runEncryption
```

Open Effects:

{ FTP, HTTP, Redis}

```
main = ingest
& csvInput "file.csv"
& decryptFileProvider
& ftpFileProvider
& batch @Record 500
& postOutput @Record mkApiCall
& redisOuput @Stat mkRedisKey
& runEncryption
& runHTTP
```

Open Effects:

{ FTP, Redis }

```
main = ingest
& csvInput "file.csv"
& decryptFileProvider
& ftpFileProvider
& batch @Record 500
& postOutput @Record mkApiCall
& redisOuput @Stat mkRedisKey
& runEncryption
& runHTTP
& runFTP
```

Open Effects:

{ Redis }

```
main = ingest
& csvInput "file.csv"
& decryptFileProvider
& ftpFileProvider
& batch @Record 500
& postOutput @Record mkApiCall
& redisOuput @Stat mkRedisKey
& runEncryption
& runHTTP
& runFTP
& runRedis
```

Open Effects:

{ }

```
main = ingest
& csvInput "file.csv"
& decryptFileProvider
& ftpFileProvider
& batch @Record 500
& postOutput @Record mkApiCall
& redisOuput @Stat mkRedisKey
& runEncryption
& runHTTP
& runFTP
& runRedis
& runM
```

But maybe we want to test this without a million mocked services?

```
test :: ([Stat], ([Record], ()))
test = ingest
& runInput [record1, record2]
& runPureOuput @Recor
& runPureOuput @Stat
& run
```

If both a test and real interpreter are correct,

And the program is correct under the test,

Then the program is correct under the real interpreter!

**Correctness composes!**

Two major players in the free monad space:

## freer-simple

- No boilerplate!
- Friendly to use!
- 35x slower than theoretically possible.
- Incapable of expressing lots of desirable effects.

## fused-effects

- SO MUCH BOILERPLATE.
- Not very friendly.
- As fast as possible!
- All effects are expressible!

**Neither of these is a good trade-off!**

My new library:

## polysemy

- No boilerplate!
- Friendly to use!
- As fast as possible!
- All effects are expressible!

*The best of both worlds!*

We’ll discuss how this was possible!

But first, let’s get you up to speed on naive free monads.

```
instance Monad Teletype where
return = Done
Done k >>= f = f k
WriteLine msg k >>= f = WriteLine msg $ k >>= f
ReadLine k >>= f = ReadLine $ \str -> k str >>= f
```

Because it’s a monad, we can write this more idiomatically.

… and define evaluation semantics for it.

The `Done`

constructor and the recursion are only necessary to make this a `Monad`

.

We can factor them out.

Before:

After:

```
data Free f k
= Pure k
| Impure (f (Free f k))
data Teletype a
= WriteLine String a
| ReadLine (String -> a)
```

`Free f`

is a `Monad`

whenever `f`

is a `Functor`

!

```
instance Functor f => Monad (Free f) where
return = Pure
Pure k >>= f = f k
Impure z >>= f = Impure $ fmap (\x -> x >>= f) z
```

Let’s write some helper functions:

`echo`

is no longer conspicuous:

We can also factor out the evaluation plumbing:

# Combining Multiple Effects

Before:

After:

```
writeLine :: String -> Free TeletypeWithBell ()
writeLine msg = Impure $ L $ WriteLine msg $ pure ()
ringBell :: Free TeletypeWithBell ()
ringBell = Impure $ R $ RingBell $ pure ()
```

We can interleave actions from both effects.

```
ringItSingIt :: Free TeletypeWithBell ()
ringItSingIt = do
msg <- readLine
when (msg == "ring the bell!") ringBell
```

We can nest effects as deeply as we want inside of `Sum`

!

# Effects a la Carte

`Union r`

is a `Functor`

iff every type inside of `r`

is.

We can get in and out of a `Union`

.

Before:

```
writeLine :: String -> Free TeletypeWithBell ()
writeLine msg = Impure $ L $ WriteLine msg $ pure ()
```

After:

Now we are **polymorphic in our capabilities**.

This is where `freer-simple`

and `fused-effects`

start to differ.

`freer-simple`

diverges to get rid of the boilerplate.

`fused-effects`

diverges to get more speed and expressiveness.

Unfortunately, it’s unclear how to merge the two differences.

# How Does `freer-simple`

eliminate the boilerplate?

Insight: because we can’t embed our effects, we can just keep them in a queue.

(plus a little magic to thread the output of `ReadLine`

to the input of `WriteLine`

)

With this encoding, we no longer need to have continuations in our effects.

Doesn’t require

`Functor`

instances

Exactly parallels the types of the actions

This is a great change, and is \(O(n)\) faster than the naive encoding!

Unfortunately it has extremely high constant factors, due to needing to allocate the intermediary queue of actions.

## Too Fast, Too Free

Two months ago, Li-Yao Xia:

I bet if you used the final encoding of

`Freer`

, it would be much faster.

What the heck is this thing??

`Free`

is uniquely determined by its interpretation function:

We can reshuffle the `Free`

argument first, and use this function as our definition of `Freer`

.

Reshuffled:

Put a newtype constructor around it:

It took me a few days to work through the implications of this encoding.

To my surprise, it improved the constant factors of `freer-simple`

by 35x.

But why?

Consider the humble `ReaderT`

:

`ReaderT`

lets you read a single, constant value of type `r`

.

It is a zero-cost abstraction.

Anything look familiar?

`Freer`

is just `ReaderT`

in disguise!

The proof:

```
instance Monad (Freer f) where
return a = Freer $ \nt -> pure a
m >>= f = Freer $ \nt -> do
a <- runFreer m nt
runFreer (f a) nt
instance (Monad m) => Monad (ReaderT r m) where
return a = ReaderT $ \r -> pure a
m >>= f = ReaderT $ \r -> do
a <- runReaderT m r
runReaderT (f a) r
```

Identical `Monad`

instances!

We can use the natural transformation to make effects zero cost.

# Even freer freer monads

```
echo :: Member Teletype r => Freer r ()
echo = do
msg <- readLine
writeLine msg
echoIO :: IO ()
echoIO = runFreer runTeletypeInIO echo
```

```
echoIO :: IO ()
echoIO = runFreer runTeletypeInIO $ do
msg <- liftFreer ReadLine
liftFreer $ WriteLine msg
```

```
echoIO :: IO ()
echoIO = runFreer runTeletypeInIO $ do
msg <- Freer $ \nt -> nt ReadLine
Freer $ \nt -> nt $ WriteLine msg
```

```
echoIO :: IO ()
echoIO = do
msg <- case ReadLine of
ReadLine -> getLine
WriteLine s -> putStrLn s
case WriteLine msg of
ReadLine -> getLine
WriteLine s -> putStrLn s
```

```
echoIO :: IO ()
echoIO = do
msg <- case ReadLine of
ReadLine -> getLine
-- WriteLine s -> putStrLn msg
case WriteLine msg of
-- ReadLine -> getLine
WriteLine s -> putStrLn s
```

```
echoIO :: IO ()
echoIO = do
msg <- case ReadLine of
ReadLine -> getLine
case WriteLine msg of
WriteLine s -> putStrLn s
```

So free!

We’ve now shown how to solve the boilerplate and performance problems.

## Lets rewind and look at the changes `fused-effects`

makes.

# Down the other trouser (where we left off)

```
data Free r k
= Pure k
| Impure (Union r (Free r k))
data Teletype a
= WriteLine String a
| ReadLine (String -> a)
deriving Functor
writeLine :: Member Teletype r => String -> Free r ()
writeLine msg = Impure $ inj $ WriteLine msg $ pure ()
```

An effect we’d like, but can’t have:

```
throw
:: Member (Error e) r
=> e
-> Free r a
catch
:: Member (Error e) r
=> Free r a
-> (e -> Free r a)
-> Free r a
```

`catch`

contains an embedded `Free`

.

What we’d like:

Maybe

?

Unfortunately this type cannot be embedded inside a `Union`

:(

Instead:

Just force `m`

to be `Free r`

:

```
data Free r a
= Pure a
| Impure (Union r (Free r) a)
liftFree :: Member f r => f (Free r) (Free r a) -> Free r a
```

Effects don’t need to use `m`

if they don’t want to.

## The Problem

How do `State`

and `Error`

interact?

How can we thread state changes through a `Catch`

action?

## The Solution: Functors!

What is a functor, really?

Just a value in some sort of context.

In particular, a value of `f ()`

is *only* a context!

We can abuse this fact, and wrap up the state of the world as some functor.

`tk ()`

is the state of the world when the effect starts`(∀ x. tk (m x) -> n (tk x))`

is a distribution law for describing how to run effects in a context.

`weave`

allows an effect to have other effects “pushed through it.”

Weaving through `Error`

:

The “ice-cream cone” operator replaces the contents of a `Functor`

:

The `State`

effect needs to push its state through other effects’ subcomputations.

It can call `weave`

to do this.

`decomp`

can extract a single effect out of a `Union`

; or prove that it was never there to begin with.

But it’s slow.

Because `runState`

is recursive, GHC won’t perform any optimizations on it :(

We can “break the recursion” by hand.

Now GHC is happy and will make our program **fast**!

Lots of the boilerplate in `fused-effects`

comes from needing to write `Effect`

instances.

But these instances are necessary for higher-order effects!

Are we cursed to always have this boilerplate?

No!

```
data Yo e m a where
Yo :: Functor tk
=> e m a
-> tk ()
-> (forall x. tk (m x) -> n (tk x))
-> (tk a -> b)
-> Yo e n b
```

`Yo`

is the free `Effect`

!

```
instance Effect (Yo e) where
weave tk' distrib' (Yo e tk distrib f) =
Yo e (Compose $ tk <$ tk')
(fmap Compose . distrib' . fmap distrib . getCompose)
(fmap f . getCompose)
```

And we can get into a `Yo`

by using an `Identity`

functor as our initial state.

```
liftYo :: Functor m => e m a -> Yo e m a
liftYo e = Yo e (Identity ())
(fmap Identity . runIdentity)
runIdentity
```

Somewhat amazingly, this works!

But all it means is we’ve delayed giving a meaning for `Effect`

until we need to interpret it.

A problem:

The type of `runFree`

doesn’t allow us to change the return type.

It seems like maybe we could just stick a functor in here.

**Unfortunately this is no longer a Monad!**

Recall that we’re allowed to pick *any* `Monad`

for the result of `runFree`

.

Instead of evaluating to the final monad `m`

…

Just transform it into `StateT s m`

and immediately evaluate *that*!

```
import qualified Control.Monad.Trans.State as S
runState
:: s
-> Free (e ': r) a
-> Free r (s, a)
runState s (Free m) = Free $ \nt ->
S.runStateT s $ m $ \u ->
case decomp u of
Left x -> S.StateT $ \s' ->
nt . weave (s', ()) (uncurry $ runState f)
$ x
Right (Yo Get _ f) -> fmap f $ S.get
Right (Yo (Put s') _ f) -> fmap f $ S.put s'
```

We’ve solved all of the problems! We now have solutions for

*performance**expressiveness**boilerplate*

all of which work together!

But what we’ve built isn’t yet a joyful experience.

In particular, dealing with `Yo`

is painful.

We can clean up the mess of writing effect handlers…

…

…with an effect-handler effect!

Instead of this:

```
instance Effect (Error e) where
weave _ _ (Throw e) = Throw e
weave tk distrib (Catch try handle k) =
Catch (distrib $ try <$ tk)
(\e -> distrib $ handle e <$ tk)
(fmap k)
```

We can just write this:

```
runError = interpretH $ \case
Catch try handle -> do
t <- runT try
tried <- runError t
case tried of
Right a -> pure $ Right a
Left e -> do
h <- bindT handle
handled <- h e
case handled of
Right a -> pure $ Right a
Left e2 -> pure $ Left e2
```

The magic is in `runT`

and `bindT`

.

These combinators come from the `Tactics`

effect:

`GetInitialState`

is the`tk ()`

parameter

This is where we stop.

We’ve now simultaneously solved the boilerplate and performance problems, as well as put a friendly UX around the whole thing.

I’d like to leave you with a comparison.

First, the implementation of `bracket`

in `fused-effects`

:

```
data Resource m k
= forall resource any output.
Resource (m resource)
(resource -> m any)
(resource -> m output)
(output -> k)
deriving instance Functor (Resource m)
instance HFunctor Resource where
hmap f (Resource acquire release use k) =
Resource (f acquire) (f . release) (f . use) k
instance Effect Resource where
handle state handler (Resource acquire release use k)
= Resource (handler (acquire <$ state))
(handler . fmap release)
(handler . fmap use)
(handler . fmap k)
bracket :: (Member Resource sig, Carrier sig m)
=> m resource
-> (resource -> m any)
-> (resource -> m a)
-> m a
bracket acquire release use =
send (Resource acquire release use pure)
runResource :: (forall x . m x -> IO x)
-> ResourceC m a
-> m a
runResource handler = runReader (Handler handler) . runResourceC
newtype ResourceC m a = ResourceC
{ runResourceC :: ReaderC (Handler m) m a
}
deriving ( Alternative, Applicative, Functor, Monad, MonadFail, MonadIO, MonadPlus)
instance MonadTrans ResourceC where
lift = ResourceC . lift
newtype Handler m = Handler (forall x . m x -> IO x)
runHandler :: Handler m -> ResourceC m a -> IO a
runHandler h@(Handler handler) = handler . runReader h . runResourceC
instance (Carrier sig m, MonadIO m) =>
Carrier (Resource :+: sig) (ResourceC m) where
eff (L (Resource acquire release use k)) = do
handler <- ResourceC ask
a <- liftIO (Exc.bracket
(runHandler handler acquire)
(runHandler handler . release)
(runHandler handler . use))
k a
eff (R other) = ResourceC (eff (R (handleCoercible other)))
```

Compare to `polysemy`

:

```
data Resource m a where
Bracket :: m a -> (a -> m ()) -> (a -> m b) -> Resource m b
makeSemantic ''Resource
runResource
:: Member (Lift IO) r
=> (∀ x. Semantic r x -> IO x)
-> Semantic (Resource ': r) a
-> Semantic r a
runResource finish = interpretH $ \case
Bracket alloc dealloc use -> do
a <- runT alloc
d <- bindT dealloc
u <- bindT use
let runIt = finish .@ runResource
sendM $ X.bracket (runIt a) (runIt . d) (runIt . u)
```

## Shoutouts

My girlfriend Virginie for putting up with me talking about free monads for two months.

Li-Yao Xia for showing me the final encoding of

`Freer`

.

Rob Rix for sitting down with me and explaining how the heck

`fused-effects`

is so fast.

# Thanks for listening!

Questions?