# Merging IO and Either into one monad

A good way to metabolize new concepts is to copy ideas from other people and try to make them compile. This is exactly what we are going to do today.

In case you wanted to read the (better) original, please check out “A Gentle Introduction to Monad Transformers”.

## The Problem

Let’s write a function to extract the domain from an email:

```
getDomain :: Text -> Either LoginError Text
=
getDomain email case T.splitOn "@" email of
-> Right domain
[_, domain] -> Left InvalidEmail _
```

Then let’s say we want to ask the user for their email and use the domain as a token for authentication:

```
getToken :: IO (Either LoginError Text)
= do
getToken "Enter email address:"
T.putStrLn <- T.getLine
email pure $ getDomain email
```

Besides the token, the user need to input a password. The database of users is the following:

```
users :: Map Text Text
= Map.fromList
users "example.com", "qwerty123")
[ ("localhost", "password")
, ( ]
```

For our authentication system three possible errors are possible:

```
data LoginError
= InvalidEmail
| NoSuchUser
| WrongPassword
deriving (Show)
```

Finally, we can put all together:

```
userLogin :: IO (Either LoginError Text)
= do
userLogin <- getToken
token case token of
Right domain ->
case Map.lookup domain users of
Just password -> do
"Enter password:"
T.putStrLn <- T.getLine
pw if pw == password then
pure $ Right domain
else
pure $ Left WrongPassword
Nothing ->
pure $ Left NoSuchUser
->
left pure $ left
```

And we are done!

Nope, it’s a joke. That piece of code really is ugly. We need to do something about it.

There’s one secret to clean up `userLogin`

: the indentation comes from the fact that we are dealing with two different monads (i.e. `IO`

and `Either`

).

Let’s see if merging the two into one solves our issue.

## The Solution

We first wrap the two monads into `EitherIO`

:

```
data EitherIO e a = EitherIO {
runEitherIO :: IO (Either e a)
}
```

Then we define instances for `Functor`

, `Applicative`

and `Monad`

:

```
instance Functor (EitherIO e) where
-- fmap :: Functor f => (a -> b) -> f a -> f b
-- fmap g f = EitherIO $ fmap (fmap g) (runEitherIO f)
fmap g = EitherIO . fmap (fmap g) . runEitherIO
-- THIS IS NOT LAWFUL. DO NOT USE FOR SERIOUS STUFF!
instance Applicative (EitherIO e) where
-- pure :: a -> f a
pure = EitherIO . pure . Right
-- (<*>) :: f (a -> b) -> f a -> f b
<*> f = EitherIO $ liftA2 (<*>) (runEitherIO fg) (runEitherIO f)
fg
instance Monad (EitherIO e) where
-- (>>=) :: forall a b. m a -> (a -> m b) -> m b
>>= mg = EitherIO $ (runEitherIO m >>= either (pure . Left) (runEitherIO . mg)) m
```

We can define `getToken`

in terms of our new monad:

```
getToken' :: EitherIO LoginError Text
= do
getToken' EitherIO $ fmap Right (T.putStrLn "Enter email address:")
<- EitherIO $ fmap Right T.getLine
email EitherIO $ pure $ getDomain email
```

Even better, we can create a couple of helpers to make it cleaner

```
liftEither :: Either e a -> EitherIO e a
= EitherIO . pure
liftEither
liftIO :: IO a -> EitherIO e a
= EitherIO . fmap Right
liftIO
getToken'' :: EitherIO LoginError Text
= do
getToken'' $ T.putStrLn "Enter email address:"
liftIO <- liftIO T.getLine
email $ getDomain email liftEither
```

Now, `userLogin`

can be rewritten as:

```
userLogin' :: EitherIO LoginError Text
= do
userLogin' <- getToken''
domain case Map.lookup domain users of
Just password -> do
$ T.putStrLn "Enter password:"
liftIO <- liftIO T.getLine
pw if pw == password then
$ Right domain
liftEither else
$ Left WrongPassword
liftEither Nothing ->
$ Left NoSuchUser liftEither
```

We have removed one level of nesting. That is because with the Monad instance of `EitherIO`

, we “extract” the domain with `<- getToken''`

and not the `Either _ domain`

as before. But we can do even better:

```
userLogin'' :: EitherIO LoginError Text
= do
userLogin'' <- getToken''
domain <- maybe (liftEither $ Left NoSuchUser) pure $ Map.lookup domain users
password $ T.putStrLn "Enter password:"
liftIO <- liftIO T.getLine
pw if pw == password then
$ Right domain
liftEither else
$ Left WrongPassword liftEither
```

With all of that in place we can run the login with:

```
main :: IO ()
= do
main <- runEitherIO getToken''
result print result
```

## But wait, there’s more!

We could refactor `userLogin`

to:

```
throwE :: e -> EitherIO e a
= liftEither . Left
throwE
userLogin''' :: EitherIO LoginError Text
= do
userLogin''' <- getToken''
domain <- maybe (throwE NoSuchUser) pure $ Map.lookup domain users
password $ T.putStrLn "Enter password:"
liftIO <- liftIO T.getLine
pw if pw == password then
$ Right domain
liftEither else
WrongPassword throwE
```

But if we can throw, we can also catch:

```
catchE :: EitherIO e a -> (e -> EitherIO e a) -> EitherIO e a
= EitherIO $ do
catchE throwing handler <- runEitherIO throwing
result case result of
Left e -> runEitherIO $ handler e
-> pure success success
```

And have a handler that allows the user to retry the login in case of `WrongPassword`

error:

```
wrongPasswordHandler :: LoginError -> EitherIO LoginError Text
WrongPassword = do
wrongPasswordHandler $ T.putStrLn "Wrong password, one more chance."
liftIO
userLogin'''= throwE e wrongPasswordHandler e
```

With that we can:

```
main :: IO ()
= do
main <- runEitherIO $ userLogin''' `catchE` wrongPasswordHandler
result print result
```

## The whole code

```
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Data.Text as T
import Data.Text.IO as T
import Data.Map as Map
import Data.Either (either)
import Data.Maybe (maybe)
import Control.Applicative (liftA2)
data LoginError
= InvalidEmail
| NoSuchUser
| WrongPassword
deriving (Show)
getDomain :: Text -> Either LoginError Text
=
getDomain email case T.splitOn "@" email of
-> Right domain
[_, domain] -> Left InvalidEmail
_
getToken :: IO (Either LoginError Text)
= do
getToken "Enter email address:"
T.putStrLn <- T.getLine
email pure $ getDomain email
users :: Map Text Text
= Map.fromList
users "example.com", "qwerty123")
[ ("localhost", "password")
, (
]
userLogin :: IO (Either LoginError Text)
= do
userLogin <- getToken
token case token of
Right domain ->
case Map.lookup domain users of
Just password -> do
"Enter password:"
T.putStrLn <- T.getLine
pw if pw == password then
pure $ Right domain
else
pure $ Left WrongPassword
Nothing ->
pure $ Left NoSuchUser
->
left pure $ left
data EitherIO e a = EitherIO {
runEitherIO :: IO (Either e a)
}
instance Functor (EitherIO e) where
-- fmap :: Functor f => (a -> b) -> f a -> f b
-- fmap g f = EitherIO $ fmap (fmap g) (runEitherIO f)
fmap g = EitherIO . fmap (fmap g) . runEitherIO
-- THIS IS NOT LAWFUL. DO NOT USE FOR SERIOUS STUFF!
instance Applicative (EitherIO e) where
-- pure :: a -> f a
pure = EitherIO . pure . Right
-- (<*>) :: f (a -> b) -> f a -> f b
<*> f = EitherIO $ liftA2 (<*>) (runEitherIO fg) (runEitherIO f)
fg
instance Monad (EitherIO e) where
-- (>>=) :: forall a b. m a -> (a -> m b) -> m b
>>= mg = EitherIO $ (runEitherIO m >>= either (pure . Left) (runEitherIO . mg))
m
getToken' :: EitherIO LoginError Text
= do
getToken' EitherIO $ fmap Right (T.putStrLn "Enter email address:")
<- EitherIO $ fmap Right T.getLine
email EitherIO $ pure $ getDomain email
liftEither :: Either e a -> EitherIO e a
= EitherIO . pure
liftEither
liftIO :: IO a -> EitherIO e a
= EitherIO . fmap Right
liftIO
getToken'' :: EitherIO LoginError Text
= do
getToken'' $ T.putStrLn "Enter email address:"
liftIO <- liftIO T.getLine
email $ getDomain email
liftEither
userLogin' :: EitherIO LoginError Text
= do
userLogin' <- getToken''
domain case Map.lookup domain users of
Just password -> do
$ T.putStrLn "Enter password:"
liftIO <- liftIO T.getLine
pw if pw == password then
$ Right domain
liftEither else
$ Left WrongPassword
liftEither Nothing ->
$ Left NoSuchUser
liftEither
userLogin'' :: EitherIO LoginError Text
= do
userLogin'' <- getToken''
domain <- maybe (liftEither $ Left NoSuchUser) pure $ Map.lookup domain users
password $ T.putStrLn "Enter password:"
liftIO <- liftIO T.getLine
pw if pw == password then
$ Right domain
liftEither else
$ Left WrongPassword
liftEither
throwE :: e -> EitherIO e a
= liftEither . Left
throwE
userLogin''' :: EitherIO LoginError Text
= do
userLogin''' <- getToken''
domain <- maybe (throwE NoSuchUser) pure $ Map.lookup domain users
password $ T.putStrLn "Enter password:"
liftIO <- liftIO T.getLine
pw if pw == password then
$ Right domain
liftEither else
WrongPassword
throwE
catchE :: EitherIO e a -> (e -> EitherIO e a) -> EitherIO e a
= EitherIO $ do
catchE throwing handler <- runEitherIO throwing
result case result of
Left e -> runEitherIO $ handler e
-> pure success
success
wrongPasswordHandler :: LoginError -> EitherIO LoginError Text
WrongPassword = do
wrongPasswordHandler $ T.putStrLn "Wrong password, one more chance."
liftIO
userLogin'''= throwE e
wrongPasswordHandler e
main :: IO ()
= do
main print $ getDomain "a"
print $ getDomain "a@b"
<- getToken
t print t
<- userLogin
result print result
<- runEitherIO getToken''
t' print t'
<- runEitherIO $ userLogin''' `catchE` wrongPasswordHandler
t'' print t''
```

**I need your help** to make the blog awesome.
Here's a survey. Since there are no required questions, **you decide how much time to spend on it**.