DEV Community

Cover image for Merging IO and Either into one monad
Riccardo Odone
Riccardo Odone

Posted on • Updated on • Originally published at odone.io

Merging IO and Either into one monad

#haskell #functional

You can keep reading here or jump to my blog to get the full experience, including the wonderful pink, blue and white palette.

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
    [_, domain] -> Right domain
    _           -> Left InvalidEmail
Enter fullscreen mode Exit fullscreen mode

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)
getToken = do
  T.putStrLn "Enter email address:"
  email <- T.getLine
  pure $ getDomain email
Enter fullscreen mode Exit fullscreen mode

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

users :: Map Text Text
users = Map.fromList
  [ ("example.com", "qwerty123")
  , ("localhost", "password")
  ]
Enter fullscreen mode Exit fullscreen mode

For our authentication system three possible errors are possible:

data LoginError
  = InvalidEmail
  | NoSuchUser
  | WrongPassword
  deriving (Show)
Enter fullscreen mode Exit fullscreen mode

Finally, we can put all together:

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

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)
}
Enter fullscreen mode Exit fullscreen mode

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
  fg <*> f = EitherIO $ liftA2 (<*>) (runEitherIO fg) (runEitherIO f)

instance Monad (EitherIO e) where
  -- (>>=) :: forall a b. m a -> (a -> m b) -> m b
  m >>= mg = EitherIO $ (runEitherIO m >>= either (pure . Left) (runEitherIO . mg))
Enter fullscreen mode Exit fullscreen mode

We can define getToken in terms of our new monad:

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

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

liftEither :: Either e a -> EitherIO e a
liftEither = EitherIO . pure

liftIO :: IO a -> EitherIO e a
liftIO = EitherIO . fmap Right

getToken'' :: EitherIO LoginError Text
getToken'' = do
  liftIO $ T.putStrLn "Enter email address:"
  email <- liftIO T.getLine
  liftEither $ getDomain email
Enter fullscreen mode Exit fullscreen mode

Now, userLogin can be rewritten as:

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

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
userLogin'' = do
  domain <- getToken''
  password <- maybe (liftEither $ Left NoSuchUser) pure $ Map.lookup domain users
  liftIO $ T.putStrLn "Enter password:"
  pw <- liftIO T.getLine
  if pw == password then
    liftEither $ Right domain
  else
    liftEither $ Left WrongPassword
Enter fullscreen mode Exit fullscreen mode

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

main :: IO ()
main = do
  result <- runEitherIO getToken''
  print result
Enter fullscreen mode Exit fullscreen mode

But wait, there's more!

We could refactor userLogin to:

throwE :: e -> EitherIO e a
throwE = liftEither . Left

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

But if we can throw, we can also catch:

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

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

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

With that we can:

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

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
    [_, domain] -> Right domain
    _           -> Left InvalidEmail

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

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

userLogin :: IO (Either LoginError Text)
userLogin = do
  token <- getToken
  case token of
    Right domain ->
      case Map.lookup domain users of
        Just password -> do
          T.putStrLn "Enter password:"
          pw <- T.getLine
          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

instance Applicative (EitherIO e) where
  -- pure :: a -> f a
  pure = EitherIO . pure . Right
  -- (<*>) :: f (a -> b) -> f a -> f b
  fg <*> f = EitherIO $ liftA2 (<*>) (runEitherIO fg) (runEitherIO f)

instance Monad (EitherIO e) where
  -- (>>=) :: forall a b. m a -> (a -> m b) -> m b
  m >>= mg = EitherIO $ (runEitherIO m >>= either (pure . Left) (runEitherIO . mg))

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

liftEither :: Either e a -> EitherIO e a
liftEither = EitherIO . pure

liftIO :: IO a -> EitherIO e a
liftIO = EitherIO . fmap Right

getToken'' :: EitherIO LoginError Text
getToken'' = do
  liftIO $ T.putStrLn "Enter email address:"
  email <- liftIO T.getLine
  liftEither $ getDomain email

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

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

throwE :: e -> EitherIO e a
throwE = liftEither . Left

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

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

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

main :: IO ()
main = do
  print $ getDomain "a"
  print $ getDomain "a@b"
  t <- getToken
  print t
  result <- userLogin
  print result
  t' <- runEitherIO getToken''
  print t'
  t'' <- runEitherIO $ userLogin''' `catchE` wrongPasswordHandler
  print t''
Enter fullscreen mode Exit fullscreen mode

Get the latest content via email from me personally. Reply with your thoughts. Let's learn from each other. Subscribe to my PinkLetter!

Top comments (0)

Read next

mr_sd_jack_003 profile image

ADDING COMMAND ALIASES TO POWERSHELL

Soham Dalal ⚛️ -

balastrong profile image

TanStack Form: Setup and simple validation (with shadcn/ui)

Leonardo Montini -

fajbaba profile image

The Concept of Blockchain and its Terminologies

Emmanuel Fajinmi -

dariomannu profile image

HTML templates vs the IO Monad

Dario Mannu -