A Monad Transformer tutorial

MonadTrans.hs

module MonadTrans where

import Control.Applicative (empty)
import Control.Monad (guard, join)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Identity (IdentityT (..), runIdentityT)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Control.Monad.Trans.Reader (Reader, ReaderT (..), ask)
import Data.List (intercalate)
import qualified Data.Map.Lazy as M
import Data.Maybe (fromMaybe)

-- IdentityT
-- The simplest of transformers!
-- newtype IdentityT f a = IdentityT { runIdentityT :: f a }

identityMaybeInt :: IdentityT Maybe Int
identityMaybeInt = IdentityT (Just 10)

-- identityExample :: IdentityT Maybe Int
-- identityExample =
--   let result =
--         fmap (runIdentityT . (\a -> IdentityT (Just (a + 10)))) identityMaybeInt
--    in IdentityT $ join $ runIdentityT result

-- identityExample =
--   let add10 = fmap (runIdentityT . (\a -> IdentityT (Just (a + 10))))
--    in IdentityT $ join $ runIdentityT $ add10 identityMaybeInt

-- But this is quite cumbersome...

-- Let's think about the type signature of >>=
-- (>>=) :: m a -> (a -> m b) -> m b
--
-- Let's do some replacing:
-- m a => (IdentityT Maybe) Int
-- a -> m b => Int -> ((IdentityT Maybe) Int)
-- m b => (IdentityT Maybe) Int

-- So in our case m is `IdentityT Maybe` and we can use >>= as normal
-- identityExample' :: IdentityT Maybe Int
-- identityExample' = identityMaybeInt >>= (\a -> IdentityT $ Just (a + 10))

identityExample' :: IdentityT Maybe Int
identityExample' = identityMaybeInt >>= (\a -> pure (a + 10))

-- Note the beauty of the monad interface and `pure`, we could be applying
-- this function to both `IdentityT Maybe Int` and `Maybe Int` with no changes

myPrompt :: String -> IO String
myPrompt prompt = do
  putStr prompt
  getLine

nicePrint :: Maybe String -> IO ()
nicePrint result =
  putStrLn $
    intercalate
      "\n"
      [ "==============================",
        fromMaybe "An error occurred..." result,
        "=============================="
      ]

naiveTry :: IO ()
naiveTry = do
  name <- myPrompt "Name? "
  if name /= ""
    then do
      phoneNumber <- myPrompt "Phone Number? "
      if length phoneNumber < 10
        then do
          streetName <- myPrompt "Street Name? "
          if streetName /= ""
            then
              nicePrint
                ( Just $
                    "Name: "
                      ++ name
                      ++ "\nPhone Number: "
                      ++ phoneNumber
                      ++ "\nStreet Name: "
                      ++ streetName
                )
            else pure ()
        else pure ()
    else pure ()

fixedTry :: IO ()
fixedTry = do
  name <- myPrompt "Name? "
  guard $ name /= ""
  phoneNumber <- myPrompt "Phone Number? "
  guard $ length phoneNumber < 10
  streetName <- myPrompt "Street Name? "
  guard $ streetName /= ""
  nicePrint $
    Just $
      "Name: "
        ++ name
        ++ "\nPhone Number: "
        ++ phoneNumber
        ++ "\nStreet Name: "
        ++ streetName

-- This works but it's not very flexible.

-- Let's look at MaybeT
-- newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }

getNameBroken :: MaybeT IO String
getNameBroken = do
  -- BROKEN: input <- myPrompt "Name? "
  input <- lift $ myPrompt "Name? "
  if input == ""
    then MaybeT $ return Nothing
    else MaybeT $ return $ Just $ "Name: " ++ input ++ "\n"

-- Unfortunately, this doesn't compile because when we're using monadic do
-- notation each line has to evaluate to the same monad. Instead `myPrompt`
-- returns a `IO String` instead of a `MaybeT IO String`

-- So we need this function:
-- `IO String -> MaybeT IO String`

-- Or a more generic one for all monads
-- `m a -> MaybeT m a`

-- Or a more generic one for all transformers
-- `m a -> t m a`

-- Surprise, this function exists and is called lift!

getName :: MaybeT IO String
getName = do
  input <- lift $ myPrompt "Name? "
  if input == ""
    then MaybeT $ return Nothing
    else MaybeT $ return $ Just $ "Name: " ++ input ++ "\n"

getNumber :: String -> MaybeT IO String
getNumber str = do
  input <- lift $ myPrompt "Phone number? "
  if input == ""
    then MaybeT $ return Nothing
    else MaybeT $ return $ Just $ str ++ "Phone Number: " ++ input ++ "\n"

getStreetName :: String -> MaybeT IO String
getStreetName str = do
  input <- lift $ myPrompt "Street Name? "
  if input == ""
    then MaybeT $ return Nothing
    else MaybeT $ return $ Just $ str ++ "Street Name: " ++ input

allTogether :: MaybeT IO String
allTogether = getName >>= getNumber >>= getStreetName

runAllTogetherNow :: IO ()
runAllTogetherNow = do
  result <- runMaybeT allTogether
  nicePrint result

-- The only thing which is weird is that getName, getNumber, and getStreetName
-- have different type signatures. We can rewrite them so they look exactly the same.
-- Also, we don't need to explicitly specify the return types.

getNameM :: MaybeT IO String
getNameM = do
  input <- lift $ myPrompt "Name? "
  if input == "" || length input > 10
    then empty
    else return $ "Name: " ++ input

getNumberM :: MaybeT IO String
getNumberM = do
  input <- lift $ myPrompt "Phone number? "
  if input == "" || length input > 10
    then empty
    else return $ "Phone Number: " ++ input

getStreetNameM :: MaybeT IO String
getStreetNameM = do
  input <- lift $ myPrompt "Street Name? "
  if input == "" || length input > 10
    then empty
    else return $ "Street Name: " ++ input

allTogetherM :: MaybeT IO String
allTogetherM = intercalate "\n" <$> sequence [getNameM, getNumberM, getStreetNameM]

runAllTogetherNowM :: IO ()
runAllTogetherNowM = do
  result <- runMaybeT allTogetherM
  nicePrint result

-- Reader and ReaderT:
-- type Reader r = ReaderT r Identity
-- newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }

readerIntIOString :: ReaderT Int IO String
readerIntIOString =
  ReaderT $ \int ->
    if int > 10
      then pure "VERY BIG"
      else pure "smal"

readerExample :: IO ()
readerExample = do
  result <- runReaderT readerIntIOString 11
  putStrLn result

-- Let's try with a more real-world example

type Env = M.Map String Int

testEnv :: Env
testEnv =
  M.fromList [("maxLength", 3)]

exampleGetter :: ReaderT Env IO Int
exampleGetter =
  -- Naive version
  -- ReaderT $ \env ->
  --   pure $ fromMaybe 0 . (M.lookup "maxLength" env)
  fromMaybe 0 . M.lookup "maxLength" <$> ask

envReaderExample :: IO ()
envReaderExample = do
  result <- runReaderT exampleGetter testEnv
  print result

-- Let's write a more generic version now

getEnv :: String -> ReaderT Env IO Int
getEnv key = fromMaybe 0 . M.lookup key <$> ask

getNameWithEnv :: MaybeT (ReaderT Env IO) String
getNameWithEnv = do
  input <- lift $ lift $ myPrompt "Name? "
  maxLength <- lift $ getEnv "maxLength"
  if input == "" || length input > maxLength
    then empty
    else return $ "Name: " ++ input

getNumberWithEnv :: MaybeT (ReaderT Env IO) String
getNumberWithEnv = do
  input <- lift $ lift $ myPrompt "Phone number? "
  maxLength <- lift $ getEnv "maxLength"
  if input == "" || length input > maxLength
    then empty
    else return $ "Phone Number: " ++ input

getStreetNameWithEnv :: MaybeT (ReaderT Env IO) String
getStreetNameWithEnv = do
  input <- lift $ lift $ myPrompt "Street Name? "
  maxLength <- lift $ getEnv "maxLength"
  if input == "" || length input > maxLength
    then empty
    else return $ "Street Name: " ++ input

allTogetherWithEnv :: MaybeT (ReaderT Env IO) String
allTogetherWithEnv =
  intercalate "\n"
    <$> sequence [getNameWithEnv, getNumberWithEnv, getStreetNameWithEnv]

runWithEnv :: IO ()
runWithEnv = do
  putStr "Max Length? "
  maxLength <- readLn
  result <-
    runReaderT
      (runMaybeT allTogetherWithEnv)
      (M.fromList [("maxLength", maxLength :: Int)])
  nicePrint result

-- Now we have customizable validations using Monad Transformers.