Monads are a convenient way to to sequence computation with effects. Different monads can provide different kinds of effects:

• `IO` allows world-changing side effects
• `Identity` is a "fake" monad: it allows no side effects
• `Reader` lets you access some environment value
• `State` mocks a mutable variable
• `Maybe` allows for early exit
• `Either` allows for early exit with a value

This has nothing to do with a monad transformer, just review. Let's talk about something totally different.

## Folds with early termination

The typical left fold we've seen requires you to consume the entire list. However, in some cases, we may want to stop computation early. As a made up example: let's write a `sum` function that adds up all numbers until the first negative value:

``````{-# LANGUAGE BangPatterns #-}
sumTillNegative :: [Int] -> Int
sumTillNegative =
go 0
where
go !total rest =
case rest of
[] -> total
x:xs
| x < 0     -> total
| otherwise -> go (total + x) xs

main :: IO ()
main = print \$ sumTillNegative [1, 2, 3, -1, 4]
``````

This works, but it violates all of our engineering principles of non code duplication. If we had to write a `productTillNegative`, the body would be almost exactly the same. We should instead factor our some helper function.

``````{-# LANGUAGE BangPatterns #-}
foldTerminate :: (b -> a -> Either b b) -> b -> [a] -> b
foldTerminate f =
go
where
go !accum rest =
case rest of
[] -> accum
x:xs ->
case f accum x of
Left accum' -> accum' -- early termination
Right accum' -> go accum' xs

sumTillNegative :: [Int] -> Int
sumTillNegative =
foldTerminate go 0
where
go total x
| x < 0 = Left total
| otherwise = Right (total + x)

main :: IO ()
main = print \$ sumTillNegative [1, 2, 3, -1, 4]
``````

## Using Either as a monad

Our implementation internally uses the `Either` data type, and does explicit pattern matching on it. But we can take advantage of `Either`'s monad instance, using `do`-notation, and come up with something arguably slicker:

``````foldTerminate :: (b -> a -> Either b b) -> b -> [a] -> b
foldTerminate f accum0 list0 =
either id id (go accum0 list0)
where
go !accum rest = do
(x, xs) <-
case rest of
[] -> Left accum
x:xs -> Right (x, xs)
accum' <- f accum x
go accum' xs
``````

We no longer have to explicitly deal with an exit case: binding with a `Left` value automatically terminates the loop. Cool!

Previously, we saw that you could implement a left fold using a `State` monad. This was the non-terminating variety of left fold. It looked like this:

``````foldState :: (b -> a -> b) -> b -> [a] -> b
foldState f accum0 list0 =
execState (mapM_ go list0) accum0
where
go x = modify' (\accum -> f accum x)
``````

We've seen a way to clean up a left fold using `State`, and a way to clean up terminating loop with `Either`. Can we do both at the same time? Try as we might, we won't be able to come up with a way to do this elegantly. The two monads simply don't compose nicely together.

We can fix this problem though! Let's define a new monad, `StateEither`, which combines the functionality of both `State` and `Either` together. We can define the type pretty easily:

``````newtype StateEither s e a = StateEither
{ runStateEither :: s -> (s, Either e a)
}
deriving Functor
``````

This says we take an initial state value, and return an updated state value, plus an `Either` result value. The expected functionality is that, when the result is `Left`, we stop processing. But when the result is `Right`, we continue. Let's write our `Applicative` and `Monad` instances:

``````instance Applicative (StateEither s e) where
pure a = StateEither (\s -> (s, Right a))
StateEither ff <*> StateEither fa = StateEither \$ \s0 ->
case ff s0 of
(s1, Left e) -> (s1, Left e)
(s1, Right f) ->
case fa s1 of
(s2, Left e) -> (s2, Left e)
(s2, Right a) -> (s2, Right (f a))

instance Monad (StateEither s e) where
return = pure
StateEither f >>= g = StateEither \$ \s0 ->
case f s0 of
(s1, Left e) -> (s1, Left e)
(s1, Right x) -> runStateEither (g x) s1
``````

Plus some helper functions we were using from `State` before:

``````execStateEither :: StateEither s e a -> s -> s
execStateEither m = fst . runStateEither m

modify' :: (s -> Either e s) -> StateEither s e ()
modify' f = StateEither \$ \s0 ->
case f s0 of
Left e -> (s0, Left e)
Right !s1 -> (s1, Right ())
``````

With all of tha work in place, it becomes almost trivial to write our terminating fold:

``````foldTerminate :: (b -> a -> Either b b) -> b -> [a] -> b
foldTerminate f accum0 list0 =
execStateEither (mapM_ go list0) accum0
where
go x = modify' (\accum -> f accum x)
``````

We've established three things:

• Monads can make it easier to implement some functions
• But manually defining the compositions is possible

Besides the tediousness of it all, this works great. Homework exercise: go implement all possible combinations of:

• `Reader`
• `State`
• `Either`
• `IO`

Have fun :)

(Just kidding.)

## Reformulating `StateEither`

Let's play a little rewrite game. Remember, Haskell is a pure language, so you can always substitue expressions. Turns out you can also play this game at the type level, using type synonyms. Let's start with our original type, stripped down a bit:

``````newtype StateEither s e a = StateEither (s -> (s, Either e a))
``````

Let's also remember the type of `State`:

``````newtype State s a = State (s -> (s, a))
``````

If you stare at those a bit, you'll see that they're almost identical, except we replace `a` with `Either e a` in `StateEither`. In fact, we can get away with this small rewrite:

``````newtype StateEither s e a = StateEither (State s (Either e a))
``````

You should convince yourself that this definition is isomorphic to the previous definition of `StateEither`. Now we're going to reimplement our previous example, but we're going to get to take a few shortcuts. Let's start with the data type and the `Applicative` instance:

``````newtype StateEither s e a = StateEither
{ unStateEither :: State s (Either e a)
}
deriving Functor

instance Applicative (StateEither s e) where
pure a = StateEither \$ return \$ Right a
StateEither ff <*> StateEither fa = StateEither \$ do
ef <- ff
case ef of
Left e -> return \$ Left e
Right f -> do
ea <- fa
case ea of
Left e -> return \$ Left e
Right a -> return \$ Right \$ f a
``````

Notice how we never touch the state value. Instead, we reuse the underlying `State`'s `Monad` instance via `do`-notation and `return` to implement our `Applicative` instance. All we worry about here is implementing the `Either` shortcut logic. Let's see if this translates into the `Monad` instance as well:

``````instance Monad (StateEither s e) where
return = pure
StateEither f >>= g = StateEither \$ do
ex <- f
case ex of
Left e -> return \$ Left e
Right x -> unStateEither \$ g x
``````

Sure enough it does! Finally, we get some help when implementing our `execStateEither` and `modify'` helper functions:

``````execStateEither :: StateEither s e a -> s -> s
execStateEither (StateEither m) s = execState m s

modify' :: (s -> Either e s) -> StateEither s e ()
modify' f = StateEither \$ do
s0 <- get
case f s0 of
Left e -> return \$ Left e
Right s1 -> do
put \$! s1
return \$ Right ()
``````

And our program works exactly as it did before. Sweet.

## Just State?

I'll repeat: in our instances above, we never made direct reference to the fact that we were using the `State` monad in particular. We just needed some monad instance. And then our `StateEither` thing comes along and transforms it into something with a bit more power: the ability to short-circuit. So... we have a monad... and then we transform it. I wonder what we'll call this thing...

I know! A monad transformer! We just invented something which transforms an existing monad (`State` for now) with the `Either` monad's functionality.

Again, let's look at our data type:

``````newtype StateEither s e a = StateEither
(State s (Either e a))
``````

And instead of hardcoding `State` and `s`, let's take a type variable, called `m`, to represent whatever monad we're transforming:

``````newtype EitherT e m a = EitherT
m (Either e a)
``````

Convince yourself that, if you replace `m` with `State s`, these two types are isomorphic. We've called this `EitherT` because it's the either transformer. (NOTE: for hysterical raisins, in the actual libraries this is called `ExceptT`, which is a terrible name. Sorry about that.)

We can still keep our special helper function `execStateEither`:

``````execStateEither :: EitherT e (State s) a -> s -> s
execStateEither (EitherT m) s = execState m s
``````

We can also implement our `modify'` function:

``````modify' :: (s -> Either e s) -> EitherT e (State s) ()
modify' f = EitherT \$ do
s0 <- get
case f s0 of
Left e -> return \$ Left e
Right s1 -> do
put \$! s1
return \$ Right ()
``````

NOTE When we get to mtl, we'll see that we didn't actual need to write this function, but never mind that for now.

And now, besides changing the type name, our `Applicative` and `Monad` instances are the same as before, thanks to only using the `Monad` interface of `State`.

``````instance Monad m => Applicative (EitherT e m) where
pure a = EitherT \$ return \$ Right a
EitherT ff <*> EitherT fa = EitherT \$ do
ef <- ff
case ef of
Left e -> return \$ Left e
Right f -> do
ea <- fa
case ea of
Left e -> return \$ Left e
Right a -> return \$ Right \$ f a

return = pure
EitherT f >>= g = EitherT \$ do
ex <- f
case ex of
Left e -> return \$ Left e
Right x -> runEitherT \$ g x
``````

In `EitherT e m a`, we call the `m` parameter the base monad. For very good reasons we'll get to later, we always make the base monad type variable (`m`) the second-to-last variable in defining our type. We consider `EitherT` a transformer which is layered on top of the base monad.

## Helper functions

Our previous implementation of `modify'` involved explicitly wrapping things up with the `EitherT` data constructor. That's not a pleasant way of interacting with transformers. Instead, we'll want to provide helper functions. There are two things we need to be able to do for implementing `modify'`:

• Perform actions from the base monad, namely the `State` monad in this case. We call this lifting the action.
• Cause a `Left` value to be returned, triggering an early exit.

We can easily write such helper functions:

``````exitEarly :: Monad m => e -> EitherT e m a
exitEarly e = EitherT \$ return \$ Left e

lift :: Monad m => m a -> EitherT e m a
lift action = EitherT \$ fmap Right \$ action
``````

Then our `modify'` function turns into:

``````modify' :: (s -> Either e s) -> EitherT e (State s) ()
modify' f = do
s0 <- lift get
case f s0 of
Left e -> exitEarly e
Right s1 -> lift \$ put \$! s1
``````

Which is significantly simpler.

## Generalizing `lift`

As you've probably guessed, we're going to ultimately implement more transformers than just `EitherT`. Since lifting actions is the basic operation of all monad transformers, we want an easy way to do this across all transformers. To make this work, we're going to define a typeclass, `MonadTrans`, which provides the `lift` method:

``````class MonadTrans t where
lift :: Monad m => m a -> t m a
-- lift :: Monad m => m a -> EitherT e m a
lift action = EitherT \$ fmap Right \$ action
``````

Our definition of `lift` for `EitherT` remains unchanged. All we've done is generalize the type signature by replacing the concrete `EitherT e` with a type variable `t`. This is also why we always keep the last type variable the result type, and the second-to-last the base monad: it allows us to define this helper typeclass.

The `MonadTrans` typeclass is defined in `Control.Monad.Trans.Class`, in the `transformers` package.

## Generalizing modify'

Obviously the `modify'` function needs to know about the `State` monad, since it's explicitly using `get` and `put` actions. And currently, it's explicitly taking advantage of `EitherT` functionality as well. But let's try to generalize anyway, and get into the "type astronaut" world that quickly occurs when overusing monad transformers.

The monad instance of `EitherT` already handles the short-circuit logic we're building into our `modify'`. We can generalize by, instead of returning an `Either e s` value from the provided helper function, letting the helper function simply run a monadic action. Let's see the implementation I have in mind first:

``````modifyM f = do
s0 <- lift get
s1 <- f s0
lift \$ put \$! s1
``````

Very elegant: we lift our base monad actions, and allow `f` to perform actions of its own. Now let's look at the crazy type signature:

``````modifyM
=> (s -> t (State s) s)
-> t (State s) ()
``````

In order to use the `lift` function, we need to ensure that the `t` is, in fact, a monad transformer. Therefore, we say `MonadTrans t`. In order to use `do`-notation, we need to ensure that our transformer on top of our base monad (specifically `State` here) is a monad, so we say `Monad (t (State s))`. And then `t (State s)` in the rest of the signature is simply how we reference our monad.

Then, in our call site, we replace `modify'` with `modifyM`, and instead of just an `Either` value, we wrap it up into an `EitherT` value. We'll define a helper function for that wrapping up:

``````liftEither :: Monad m => Either e a -> EitherT e m a
liftEither = EitherT . return
``````

And then rewrite `foldTerminate` to:

``````foldTerminate :: (b -> a -> Either b b) -> b -> [a] -> b
foldTerminate f accum0 list0 =
execStateEither (mapM_ go list0) accum0
where
go x = modifyM (\accum -> liftEither \$ f accum x)
``````

This certainly shows how powerful and general monad transformers can be. It's also starting to show some cognitive overhead. So let's make it one step more general.

## mtl style typeclasses

We've established that not only can the `State` monad itself perform `get` and `put` actions, but any transformer layered on top of it can do so as well. The monad transformer library, or mtl, has a philosophy around generalizing this idea using typeclasses. Let's define a typeclass, called `MonadState`, for monad stacks which can perform state-like actions:

``````class Monad m => MonadState s m | m -> s where
get :: m s
put :: s -> m ()
``````

This uses a new language extension we haven't seen before, called functional dependencies. This means that the type of the monad, `m`, determines the type of the state, `s`. We use this so that type inference continues to work nicely, and so that we can't define crazy things like "this monad allows you to get and put both type `A` and type `B`."

Anyway, defining an instance for `State` itself is trivial:

``````instance MonadState s (State s) where
get = State.get
put = State.put
``````

But we can also define an instance for `EitherT` over `State`:

``````instance MonadState s (EitherT e (State s)) where
get = lift State.get
put = lift . State.put
``````

Or, we can be even more general, and define an instance for `EitherT` over any monad which is, itself, a `MonadState`:

``````instance MonadState s m => MonadState s (EitherT e m) where
get = lift get
put = lift . put
``````

With this typeclass and these instances in hand, we can now simplify our `modifyM` function significantly:

``````modifyM :: MonadState s m => (s -> m s) -> m ()
modifyM f = do
s0 <- get
s1 <- f s0
put \$! s1
``````

Sweet! Also, as you can probably guess, the `MonadState` typeclass is already defined for us, in `Control.Monad.State.Class` from the `mtl` library.

## State is a transformer

Well, sort of. The `State` monad we've been working with until now is, under the surface, defined as:

``````type State s = StateT s Identity
``````

By defining all of our concrete, pure monads in terms of transformers over the `Identity` monad, we get to implement the functionality only once.

This is also why the `EitherT` transformer is instead called `ExceptT`. The author of the library was concerned that it would be confusing that `type State s = StateT s Identity`, `type Reader r = ReaderT r Identity`, but the same didn't apply for `Either`.

## No IO transformer

Unlike most (if not all) of the other monads we've talked about, `IO` does not have a transformer variant. It must always be the base monad, with other capabilities layered on top of it. For example, `ReaderT AppConfig IO` is a common way to structure an application: you can perform `IO` actions, and you can get access to some app-wide config value.

There is an mtl-style typeclass for `IO`, called creatively `MonadIO`. It's used quite a bit in the ecosystem, and looks like:

``````class Monad m => MonadIO m where
liftIO :: IO a -> m a
liftIO = id
liftIO = lift . liftIO
``````

You can generalize many `IO`-specific functions to `MonadIO`, e.g.:

``````readFileGeneral :: MonadIO m => FilePath -> m B.ByteString
``````

`MonadIO` is defined in the `transformers` package in `Control.Monad.IO.Class`.

WARNING Next topic is significantly more advanced.

One thing you can't automatically lift using `MonadIO` is functions that take an `IO` action as input, also known as contravariant on `IO` or having `IO` in negative position. For example:

``````catchAny :: IO a -> (SomeException -> IO a) -> IO a
``````

This function cannot be generalized using `MonadIO`. Instead, something more powerful needs to come into play. This is a more advanced topic, but an example of this more powerful entity is `MonadUnliftIO`, which simplified looks like:

``````class MonadIO m => MonadUnliftIO m where
askRunInIO :: m (m a -> IO a)
``````

This says "I'm going to ask for a function which can convert an action in this monad stack into a simple `IO` action." Then I can use that to "knock down" the stacked actions to simple `IO` actions. This is why it's called unlifting: it does the opposite of the lift action. A simple implementation of `IO` is:

``````instance MonadUnliftIO IO where
``````

Then we can generalize our `catchAny` function:

``````catchAnyGeneral :: MonadUnliftIO m => m a -> (SomeException -> m a) -> m a
catchAnyGeneral action onExc = do
liftIO \$ run action `catchAny` \e -> run (onExc e)
``````

Two things to point out:

1. Notice how `MonadUnliftIO` has `MonadIO` as a superclass. We can build this subclassing hierarchies, just like we do with `Functor`/`Applicative`/`Monad`, where we continuously add more restrictions and get more power.
2. Try as you might, you won't be able to define an instance of `MonadUnliftIO` for `EitherT`, or a (valid) one for `StateT`. It's extremely limited in what it allows, by design. For a long explanation: slides and video.

`MonadUnliftIO` is defined in the `unliftio-core` package in `Control.Monad.IO.Unlift`. The sister package `unliftio` provides an `UnliftIO` module with lots of built in functionality, like exception handling, concurrency, and STM, all already generalized to either `MonadIO` or `MonadUnliftIO`.

## Exercises

You'll want to refer to the documentation for transformers and mtl for these exercises:

### Exercise 1

Define a monad transformer `ReaderT`, such that the following works:

``````-- Does not compile
#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE DeriveFunctor #-}
import Data.Functor.Identity

main :: IO ()
main = runReaderT main' "Hello World"

main' :: ReaderT String IO ()
main' = do
lift \$ putStrLn "I'm going to tell you a message"
liftIO \$ putStrLn "The message is:"
lift \$ putStrLn message
``````

### Exercise 2

Create a terminating, monadic fold, which allows you to perform effects while stepping through the list. There are many different ways to do this, both with and without monad transformers.

``````#!/usr/bin/env stack
-- stack --resolver lts-12.21 script

foldTerminateM :: Monad m => (b -> a -> m (Either b b)) -> b -> [a] -> m b
foldTerminateM = _

loudSumPositive :: [Int] -> IO Int
loudSumPositive =
foldTerminateM go 0
where
go total x
| x < 0 = do
putStrLn "Found a negative, stopping"
return \$ Left total
| otherwise = do
putStrLn "Non-negative, continuing"
let total' = total + x
putStrLn \$ "New total: " ++ show total'
return \$ Right total'

main :: IO ()
main = do
res <- loudSumPositive [1, 2, 3, -1, 5]
putStrLn \$ "Result: " ++ show res
``````

The output should be:

``````Non-negative, continuing
New total: 1
Non-negative, continuing
New total: 3
Non-negative, continuing
New total: 6
Found a negative, stopping
Result: 6
``````

NOTE Don't be surprised if this exercise is difficult to implement with transformers. It's a tricky problem.

### Exercise 3

The implementation of `ageInYear` below is unpleasant. Use `MaybeT` to clean it up.

``````#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
import System.IO

prompt :: Read a => String -> IO (Maybe a)
prompt question = do
putStr question
putStr ": "
hFlush stdout

ageInYear :: IO (Maybe Int)
ageInYear = do
mbirthYear <- prompt "Birth year"
case mbirthYear of
Nothing -> return Nothing
Just birthYear -> do
mfutureYear <- prompt "Future year"
case mfutureYear of
Nothing -> return Nothing
Just futureYear -> return \$ Just \$ futureYear - birthYear

main :: IO ()
main = do
mage <- ageInYear
case mage of
Nothing -> putStrLn \$ "Some problem with input, sorry"
Just age -> putStrLn \$ "In that year, age will be: " ++ show age
``````

### Exercise 4

This example ties together the `ReaderT`+`IO` concept with the lenses we learned last week. Fix up the following program so that it compiles.

``````-- Does not compile
#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
import Lens.Micro
import Lens.Micro.Mtl (view) -- hint :)

data LogLevel = Debug | Info
data Verbosity = Quiet | Verbose

logFunction :: Verbosity -> LogLevel -> String -> IO ()
logFunction Quiet Debug _ = return ()
logFunction _ _ str = putStrLn str

class HasVerbosity env where
verbosityL :: Lens' env Verbosity

logDebug :: HasVerbosity env => String -> ReaderT env IO ()
logDebug msg = do
verbosity <- _
logFunction verbosity Debug msg

main :: IO ()
main = do
putStrLn "===\nQuiet\n===\n"
_ inner Quiet
putStrLn "\n\n===\nVerbose\n===\n"
_ inner Verbose

inner :: _
inner = do
logDebug "This is debug level output"
logInfo "This is info level output"
``````

This is the core idea behind `RIO`, which you can read more about at the RIO monad.

### Exercise 5

Implement a properly strict `WriterT`, including a `MonadWriter` instance, which internally looks like a `StateT`.

## Solutions

### Exercise 1

``````#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE DeriveFunctor #-}
import Data.Functor.Identity

deriving Functor
pure x = ReaderT \$ \_ -> pure x
return = pure
ReaderT f >>= g = ReaderT \$ \r -> f r >>= flip runReaderT r . g
lift action = ReaderT \$ \_ -> action
liftIO = lift . liftIO

main :: IO ()
main = runReaderT main' "Hello World"

main' :: ReaderT String IO ()
main' = do
lift \$ putStrLn "I'm going to tell you a message"
liftIO \$ putStrLn "The message is:"
lift \$ putStrLn message
``````

### Exercise 2

One solution: use `MaybeT` to terminate early, and keep the accumulator in a `StateT`:

``````import Control.Monad.State.Strict

foldTerminateM :: Monad m => (b -> a -> m (Either b b)) -> b -> [a] -> m b
foldTerminateM f accum0 list0 =
execStateT (runMaybeT \$ mapM_ go list0) accum0
where
go a = do
accum0 <- get
res <- lift \$ lift \$ f accum0 a
case res of
Left accum -> do
put \$! accum
MaybeT \$ return Nothing
Right accum -> put \$! accum
``````

Another possibility: use `ExceptT` and put the early terminate value in the `Left` value via `throwError`:

``````foldTerminateM :: Monad m => (b -> a -> m (Either b b)) -> b -> [a] -> m b
foldTerminateM f accum0 list0 =
fmap (either id id) \$ runExceptT \$ execStateT (mapM_ go list0) accum0
where
go a = do
accum0 <- get
res <- lift \$ lift \$ f accum0 a
case res of
Left accum -> throwError accum
Right accum -> put \$! accum
``````

Or, of course, just implement it without transformers at all:

``````foldTerminateM :: Monad m => (b -> a -> m (Either b b)) -> b -> [a] -> m b
foldTerminateM f =
go
where
go !accum [] = return accum
go !accum (a:as) = do
res <- f accum a
case res of
Left accum' -> return accum'
Right accum' -> go accum' as
``````

Moral of the story: transformers don't always make life easier.

### Exercise 3

``````ageInYear :: IO (Maybe Int)
ageInYear = runMaybeT \$ do
birthYear <- MaybeT \$ prompt "Birth year"
futureYear <- MaybeT \$ prompt "Future year"
return \$ futureYear - birthYear
``````

### Exercise 4

``````#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
import Lens.Micro
import Lens.Micro.Mtl

data LogLevel = Debug | Info
data Verbosity = Quiet | Verbose

logFunction :: Verbosity -> LogLevel -> String -> IO ()
logFunction Quiet Debug _ = return ()
logFunction _ _ str = putStrLn str

class HasVerbosity env where
verbosityL :: Lens' env Verbosity
instance HasVerbosity Verbosity where
verbosityL = id

logDebug :: HasVerbosity env => String -> ReaderT env IO ()
logDebug msg = do
verbosity <- view verbosityL
liftIO \$ logFunction verbosity Debug msg

verbosity <- view verbosityL
liftIO \$ logFunction verbosity Info msg

main :: IO ()
main = do
putStrLn "===\nQuiet\n===\n"
putStrLn "\n\n===\nVerbose\n===\n"

inner :: ReaderT Verbosity IO ()
inner = do
logDebug "This is debug level output"
logInfo "This is info level output"
``````

### Exercise 5

``````#!/usr/bin/env stack
-- stack --resolver lts-12.21 script
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveFunctor #-}

newtype WriterT w m a = WriterT (w -> m (a, w))
deriving Functor

instance Monad m => Applicative (WriterT w m) where
pure x = WriterT \$ \w -> pure (x, w)
WriterT f <*> WriterT x = WriterT \$ \w0 -> do
(f', w1) <- f w0
(x', w2) <- x w1
pure (f' x', w2)

return = pure
WriterT x >>= f = WriterT \$ \w0 -> do
(x', w1) <- x w0
let WriterT f' = f x'
f' w1

lift f = WriterT \$ \w -> do
x <- f
pure (x, w)

liftIO = lift . liftIO

instance (Monad m, Monoid w) => MonadWriter w (WriterT w m) where
tell w2 = WriterT \$ \w1 -> pure ((), w1 `mappend` w2)
pass (WriterT f) = WriterT \$ \w0 -> do
((a, f), w1) <- f w0
pure (a, f w1)
listen (WriterT m) = WriterT \$ \w0 -> do
(a, w) <- m mempty
pure ((a, w), w0 `mappend` w)

runWriterT :: (Monad m, Monoid w) => WriterT w m a -> m (a, w)
runWriterT (WriterT f) = f mempty

main :: IO ()
main = pure ()
``````