Demonstration of Reader/Exception/IO Monad Transformer stack constructions from basic Monads to MTL.

monadTransformerDemo.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

module ExceptionTest where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Class (lift)
import Data.Typeable
import qualified Data.Map.Strict as M


data SaunaError = SaunaTooHot deriving Show
data DbError = NoSuchUser deriving Show

data SpaErrors = SaunaErr SaunaError | DbErr DbError  deriving (Show, Typeable)
instance Exception SpaErrors

type Name = String
type TempPreference = Int
data User = User Name TempPreference deriving Show

type Database = M.Map Name User

newtype Connection = Connection (MVar Database)
newtype TempController = TempController (MVar TempPreference)


-------------------------
---- IO (Either a b) ----
-------------------------

database :: Database
database = M.fromList [ ("Joe", User "Joe" 65) , ("Fred", User "Fred" 101) ]

getUserFromDb :: Connection -> Name -> IO (Either SpaErrors User)
getUserFromDb (Connection m) name = do
    db <- takeMVar m
    putMVar m db
    case M.lookup name db of
        Just user -> return $ Right user
        Nothing -> return . Left . DbErr $  NoSuchUser

setServerTemp :: TempController -> TempPreference -> IO ()
setServerTemp (TempController m) newTemp = do
    _ <- takeMVar m
    putMVar m newTemp

checkServerTemp :: TempController -> IO (Either SpaErrors String)
checkServerTemp (TempController m) = do
    tc <- takeMVar m
    putMVar m tc
    if tc > 100
    then return . Left . SaunaErr $ SaunaTooHot
    else return $ Right "New temp set"

main0 :: IO ()
main0 = do
    db <- newMVar database
    tc <- newMVar 65

    -- Our External Services:
    let dbConn = Connection db
    let tempController = TempController tc

    user <- getUserFromDb dbConn "Joe"
    case user of
        Left err -> print err
        Right (User _ newTemp) -> do
            setServerTemp tempController newTemp
            res <- checkServerTemp tempController
            case res of
                Left err -> print err
                Right res -> print res -- irl this would call some other function

-- Using a Let statement to try to flatten the case statements:
main1 :: IO ()
main1 = do
    db <- newMVar database
    tc <- newMVar 65

    -- Our External Services:
    let dbConn = Connection db
    let tempController = TempController tc

    user <- getUserFromDb dbConn "Fred"
    let res :: Either SpaErrors TempPreference
        res = do
        User _ temp <- user
        -- You might want to do this:
        -- setServerTemp tempController temp :: IO (Either SaunaError String)
        -- but it doesn't typecheck because we are in an Either do block
        -- not an IO do block.
        return temp
    case res of
        Left err -> print err
        Right newTemp -> do
            setServerTemp tempController newTemp
            res' <- checkServerTemp tempController
            print res'


--performCombinedIO :: Connection -> TempController -> Name -> ExceptT SpaErrors IO String
--performCombinedIO conn tempCont user = do
--    -- Notice how we got rid of the case tree
--    User _ temp <- ExceptT $ getUserFromDb conn user
--    -- setServerTemp is an IO action, but we are in ExceptT.
--    -- So we must lift it:
--    lift $ setServerTemp tempCont temp
--    res         <- ExceptT $ checkServerTemp tempCont
--    return res

------------------------
---- ExceptT a IO b ----
------------------------

getUserFromDb2 :: Connection -> Name -> ExceptT SpaErrors IO User
getUserFromDb2 (Connection m) name = do
    db <- liftIO $ takeMVar m
    liftIO $ putMVar m db
    case M.lookup name db of
        Just user -> return user
        Nothing -> throwError $ DbErr NoSuchUser

checkServerTemp2 :: TempController -> ExceptT SpaErrors IO String
checkServerTemp2 (TempController m) = do
    tc <- liftIO $ takeMVar m
    liftIO $ putMVar m tc
    if tc > 100
    then throwError $ SaunaErr SaunaTooHot
    else return "New temp set"

performCombinedIO2 :: Connection -> TempController -> Name -> ExceptT SpaErrors IO String
performCombinedIO2 conn tempCont user = do
    -- Notice how we got rid of the case tree
    User _ temp <- getUserFromDb2 conn user
    -- setServerTemp is an IO action, but we are in ExceptT.
    -- So we must lift it:
    liftIO $ setServerTemp tempCont temp
    res <- checkServerTemp2 tempCont
    return res

main2 :: IO ()
main2 = do
    db <- newMVar database
    tc <- newMVar 65

    -- Our External Services:
    let dbConn = Connection db
    let tempCont = TempController tc

    -- 3 examples to demonstrate the handling of the Lefts and Right
    res0 <- runExceptT $ performCombinedIO2 dbConn tempCont "Joe"
    res1 <- runExceptT $ performCombinedIO2 dbConn tempCont "Fred"
    res2 <- runExceptT $ performCombinedIO2 dbConn tempCont "unknown"
    print res0
    print res1
    print res2


-------------------------------------
---- Adding ReaderT to the stack ----
-------------------------------------
-- Context (DB Connection and TempController) are avalaible
-- everywhere we want it implicitely, however we end up doing
-- lots of lifting. Also execution order in main is confusing.

data Env = Env { getDB :: Connection, getTC :: TempController }

-- Alternate Structure:
getUserFromDb3' :: Connection -> Name -> ReaderT Env (ExceptT SpaErrors IO) User
getUserFromDb3' = undefined

getUserFromDb3 :: Name -> ExceptT SpaErrors (ReaderT Env IO) User
getUserFromDb3 name = do
    (Connection m) <- asks getDB
    db <- liftIO $ takeMVar m
    liftIO $ putMVar m db
    case M.lookup name db of
        Just user -> return user
        Nothing -> throwError $ DbErr NoSuchUser

setServerTemp' :: TempPreference -> ReaderT Env IO ()
setServerTemp' newTemp = do
    TempController m <- asks getTC
    _ <- lift $ takeMVar m
    lift $ putMVar m newTemp

checkServerTemp3 :: ExceptT SpaErrors (ReaderT Env IO) String
checkServerTemp3 = do
    TempController m <- asks getTC
    tc <- liftIO $ takeMVar m
    liftIO $ putMVar m tc
    if tc > 100
    then throwError $ SaunaErr SaunaTooHot
    else return "New temp set"


performCombinedIO' :: Name -> ExceptT SpaErrors (ReaderT Env IO) String
performCombinedIO' user = do
    User _ temp <- getUserFromDb3 user
    lift $ setServerTemp' temp
    res <- checkServerTemp3
    return res

main3 :: IO ()
main3 = do
    db <- newMVar database
    tc <- newMVar 65

    -- Our External Services:
    let dbConn = Connection db
    let tempCont = TempController tc

    let env = Env dbConn tempCont
    -- 3 examples to demonstrate the handling of the Lefts and Right
    res1 <- flip runReaderT env $ runExceptT (performCombinedIO' "Joe")
    res2 <- flip runReaderT env $ runExceptT (performCombinedIO' "Fred")
    res3 <- flip runReaderT env $ runExceptT (performCombinedIO' "unknown")
    print res1
    print res2
    print res3


--------------------------------------------
---- Wrapping The Stack In a Type Alias ----
--------------------------------------------
-- Simplified the execution in Main

type App a = ExceptT SpaErrors (ReaderT Env IO) a

runApp :: Env -> App a -> IO (Either SpaErrors a)
runApp env = flip runReaderT env . runExceptT


getUserFromDb4 :: Name -> App User
getUserFromDb4 name = do
    (Connection m) <- asks getDB
    db <- liftIO $ takeMVar m
    liftIO $ putMVar m db
    case M.lookup name db of
        Just user -> return user
        Nothing -> throwError $ DbErr NoSuchUser


checkServerTemp4 :: App String
checkServerTemp4 = do
    TempController m <- asks getTC
    tc <- liftIO $ takeMVar m
    liftIO $ putMVar m tc
    if tc > 100
    then throwError $ SaunaErr SaunaTooHot
    else return "New temp set"

performCombinedIO4 :: Name -> App String
performCombinedIO4 user = do
    User _ temp <- getUserFromDb4 user
    lift $ setServerTemp' temp
    res <- checkServerTemp4
    return res

main4 :: IO ()
main4 = do
    db <- newMVar database
    tc <- newMVar 65

    -- Our External Services:
    let dbConn = Connection db
    let tempCont = TempController tc
    let env = Env dbConn tempCont

    res1 <- runApp env (performCombinedIO4 "Joe")
    res2 <- runApp env (performCombinedIO4 "Fred")
    res3 <- runApp env (performCombinedIO4 "unknown")
    print res1
    print res2
    print res3


----------------------------
---- MTL Style: Round 1 ----
----------------------------

getUserFromDb5 ::
    ( MonadReader Env m
    , MonadIO m
    , MonadError SpaErrors m
    ) => Name -> m User
getUserFromDb5 name = do
    (Connection m) <- asks getDB
    db <- liftIO $ takeMVar m
    liftIO $ putMVar m db
    case M.lookup name db of
        Just user -> return user
        Nothing -> throwError . DbErr $  NoSuchUser

setServerTemp5 ::
    ( MonadReader Env m
    , MonadIO m
    ) => TempPreference -> m ()
setServerTemp5 newTemp = do
    TempController m <- asks getTC
    _ <- liftIO $ takeMVar m
    liftIO $ putMVar m newTemp

checkServerTemp5 ::
    ( MonadReader Env m
    , MonadIO m
    , MonadError SpaErrors m
    ) => m String
checkServerTemp5 = do
    TempController m <- asks getTC
    tc <- liftIO $ takeMVar m
    liftIO $ putMVar m tc
    if tc > 100
    then throwError . SaunaErr $ SaunaTooHot
    else return "New temp set"

performCombinedIO5 ::
    ( MonadReader Env m
    , MonadIO m
    , MonadError SpaErrors m
    ) => Name -> m String
performCombinedIO5 user = do
    User _ temp <- getUserFromDb5 user
    setServerTemp5 temp
    res <- checkServerTemp5
    return res

main5 :: IO ()
main5 = do
    db <- newMVar database
    tc <- newMVar 65

    -- Our External Services:
    let dbConn = Connection db
    let tempCont = TempController tc

    let env = Env dbConn tempCont
    -- 3 examples to demonstrate the handling of the Lefts and Right
    res1 <- flip runReaderT env $ runExceptT (performCombinedIO5 "Joe")
    res2 <- flip runReaderT env $ runExceptT (performCombinedIO5 "Fred")
    res3 <- flip runReaderT env $ runExceptT (performCombinedIO5 "unknown")
    print res1
    print res2
    print res3


--------------------------------------
---- MTL Style Round2: HasPattern ----
--------------------------------------

class HasTempController a where
    getTempControl :: a -> TempController
instance HasTempController Env where
    getTempControl = getTC
instance HasTempController TempController where
    getTempControl = id

class HasDatabase a where
    getDatabase :: a -> Connection
instance HasDatabase Env where
    getDatabase = getDB
instance HasDatabase Connection where
    getDatabase = id

getUserFromDb6 ::
    ( MonadReader Env m
    , MonadIO m
    , MonadError SpaErrors m
    ) => Name -> m User
getUserFromDb6 name = do
    (Connection m) <- asks getDatabase
    db <- liftIO $ takeMVar m
    liftIO $ putMVar m db
    case M.lookup name db of
        Just user -> return user
        Nothing -> throwError . DbErr $  NoSuchUser

setServerTemp6 ::
    ( MonadReader Env m
    , MonadIO m
    ) => TempPreference -> m ()
setServerTemp6 newTemp = do
    TempController m <- asks getTempControl
    _ <- liftIO $ takeMVar m
    liftIO $ putMVar m newTemp

checkServerTemp6 ::
    ( MonadReader Env m
    , MonadIO m
    , MonadError SpaErrors m
    ) => m String
checkServerTemp6 = do
    TempController m <- asks getTempControl
    tc <- liftIO $ takeMVar m
    liftIO $ putMVar m tc
    if tc > 100
    then throwError . SaunaErr $ SaunaTooHot
    else return "New temp set"

performCombinedIO6 ::
    ( MonadReader Env m
    , MonadIO m
    , MonadError SpaErrors m
    ) => Name -> m String
performCombinedIO6 user = do
    User _ temp <- getUserFromDb5 user
    setServerTemp5 temp
    res <- checkServerTemp5
    return res

main6 :: IO ()
main6 = do
    db <- newMVar database
    tc <- newMVar 65

    -- Our External Services:
    let dbConn = Connection db
    let tempCont = TempController tc

    let env = Env dbConn tempCont
    -- 3 examples to demonstrate the handling of the Lefts and Right
    res1 <- flip runReaderT env $ runExceptT (performCombinedIO6 "Joe")
    res2 <- flip runReaderT env $ runExceptT (performCombinedIO6 "Fred")
    res3 <- flip runReaderT env $ runExceptT (performCombinedIO6 "unknown")
    print res1
    print res2
    print res3


----------------------------------
---- MTL Style Round3: Purity ----
----------------------------------

newtype AppM a = AppM { unAppM :: ExceptT SpaErrors (ReaderT Env IO) a}
    deriving (Functor, Applicative, Monad, MonadIO, MonadReader Env, MonadError SpaErrors)

runAppM :: Env -> AppM a -> IO (Either SpaErrors a)
runAppM env = flip runReaderT env . runExceptT . unAppM

class Monad m => MonadDatabase m where
    readDatabase :: m Database
instance (MonadIO m, MonadReader Env m) => MonadDatabase (ReaderT Env m) where
    readDatabase = do
        Connection m <- asks getDatabase
        db <- liftIO $ takeMVar m
        liftIO $ putMVar m db
        return db

class Monad m => MonadTemp m where
    setTemp :: TempPreference -> m ()
    checkTemp :: m TempPreference
instance (MonadIO m, MonadReader Env m) => MonadTemp (ReaderT Env m) where
    setTemp newTemp = do
        TempController m <- asks getTempControl
        _ <- liftIO $ takeMVar m
        liftIO $ putMVar m newTemp
        return ()
    checkTemp = do
        TempController m <- asks getTempControl
        temp <- liftIO $ takeMVar m
        liftIO $ putMVar m temp
        return temp

-- This function can no longer do arbitary IO or asks
getUserFromDb7 ::
    ( MonadError SpaErrors m
    , MonadDatabase m
    ) => Name -> m User
getUserFromDb7 name = do
    db <- readDatabase
    case M.lookup name db of
        Just user -> return user
        Nothing -> throwError . DbErr $  NoSuchUser

-- Kinda silly function now that its all been moved to the class instance.
-- However, the point is that all the specific sideeffects have been enumerated
-- and GHC wont let this function do anything other then what is specified by
-- MonadTemp.
setServerTemp7 ::
    MonadTemp m => TempPreference -> m ()
setServerTemp7 = setTemp

checkServerTemp7 ::
    ( MonadError SpaErrors m
    , MonadTemp m
    ) => m String
checkServerTemp7 = do
    tc <- checkTemp
    if tc > 100
    then throwError . SaunaErr $ SaunaTooHot
    else return "New temp set"

-- This function can do anything baked into AppM:
performCombinedIO7 :: Name -> AppM String
performCombinedIO7 user = do
    User _ temp <- getUserFromDb5 user
    setServerTemp5 temp
    checkServerTemp5

main7 :: IO ()
main7 = do
    db <- newMVar database
    tc <- newMVar 75

    -- Our External Services:
    let dbConn = Connection db
    let tempCont = TempController tc

    let env = Env dbConn tempCont
    -- 3 examples to demonstrate the handling of the Lefts and Right
    res1 <- runAppM env (performCombinedIO7 "Joe")
    res2 <- runAppM env (performCombinedIO7 "Fred")
    res3 <- runAppM env (performCombinedIO7 "unknown")
    print res1
    print res2
    print res3