An Example

Let's look at our little display program once more to see whether we can clean it up further using MonadIO, MonadState, MonadReader, and MonadIO. Here is the implementation we have developed so far:

display.hs

{-# LANGUAGE ScopedTypeVariables #-}

import Control.Exception hiding (catch)
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import System.Environment
import System.IO
import System.Process

data Config = Cfg
    { fileName :: String
    , usePager :: Bool
    }

main :: IO ()
main = void $ runMaybeT $ do
    cfg <- MaybeT (mkCfg <$> getArgs) `catch` do
        lift $ putStrLn "USAGE: display [-p] <file>"
        fail ""
    runReaderT realMain cfg

mkCfg :: [String] -> Maybe Config
mkCfg [fileName]       = Just $ Cfg fileName False
mkCfg ["-p", fileName] = Just $ Cfg fileName True
mkCfg _                = Nothing

type Prog = ReaderT Config (MaybeT IO)

realMain :: Prog ()
realMain = loadFile >>= display

loadFile :: Prog String
loadFile = do
    file <- asks fileName
    lift $ do
        txt  <- lift $ try $ readFile file
        case txt of
            Left (_ :: IOException) -> do
                lift $ putStrLn $ "ERROR: Unable to read file '" ++ file ++ "'!"
                fail ""
            Right t -> return t

display :: String -> Prog ()
display txt = do
    usePgr <- asks usePager
    lift $ lift $ if usePgr then do
        let pagerInfo = (shell "less") { std_in = CreatePipe }
        (Just h, _, _, pager) <- createProcess pagerInfo
        hPutStr h txt
        hFlush h
        hClose h
        void $ waitForProcess pager
    else
        putStr txt

catch :: Monad m => MaybeT m a -> MaybeT m a -> MaybeT m a
x `catch` handler = MaybeT $ do
    result <- runMaybeT x
    case result of
        Nothing -> runMaybeT handler
        r       -> return r

The MonadReader, MonadWriter, and MonadState classes do not provide any improvements here because our Prog monad is a reader monad but ReaderT is the outermost monad transformer, so we already do not require any lifting of our calls of asks at the beginning of loadFile and display.

The MonadIO class proves more useful. ReaderT Config (MaybeT IO) is an instance of MonadIO, so we can lift all IO functions into this monad using a single application of liftIO. Let's go through our functions one at a time.

In the main function, we currently lift a call of putStrLn one level using lift. Using liftIO doesn't simplify anything, but it is better for the reader of our code if we consistently use liftIO throughout our code instead of using lift in some places and liftIO elsewhere. So let's replace the use of lift with liftIO:

display.hs

main :: IO ()
main = void $ runMaybeT $ do
    cfg <- MaybeT (mkCfg <$> getArgs) `catch` do
        liftIO $ putStrLn "USAGE: display [-p] <file>"
        fail ""
    runReaderT realMain cfg

mkCfg does not even use any monad, so there's nothing to simplify here. realMain is as short as it gets. No improvements here either. So let's look at loadFile. This is a place where things become much nicer by using liftIO. Currently, we have an inner do-block that we lift one level so we only have to lift the IO functions in this inner do-block one more level. Without this do-block, our implementation of loadFile would be:

display.hs

loadFile :: Prog String
loadFile = do
    file <- asks fileName
    txt  <- lift $ lift $ try $ readFile file
    case txt of
        Left (_ :: IOException) -> do
            lift $ lift $ putStrLn $ "ERROR: Unable to read file '" ++ file ++ "'!"
            fail ""
        Right t -> return t

The inner do-block is gone, but we had to lift each IO function twice, through the MaybeT transformer and the ReaderT Config transformer. This gets simpler using liftIO:

display.hs

loadFile :: Prog String
loadFile = do
    file <- asks fileName
    txt  <- liftIO $ try $ readFile file
    case txt of
        Left (_ :: IOException) -> do
            liftIO $ putStrLn $ "ERROR: Unable to read file '" ++ file ++ "'!"
            fail ""
        Right t -> return t

Our display function lifts its if-then-else expression twice. Using liftIO, we can reduce this to a single lift operation:

display.hs

display :: String -> Prog ()
display txt = do
    usePgr <- asks usePager
    liftIO $ if usePgr then do
        let pagerInfo = (shell "less") { std_in = CreatePipe }
        (Just h, _, _, pager) <- createProcess pagerInfo
        hPutStr h txt
        hFlush h
        hClose h
        void $ waitForProcess pager
    else
        putStr txt

All the applications of lift are now gone from our code, so we no longer need to import Control.Monad.Trans. liftIO is provided by Control.Monad.IO.Class. So we need to replace the import of Control.Monad.Trans with an import of Control.Monad.IO.Class:

display.hs

{-# LANGUAGE ScopedTypeVariables #-}

import Control.Exception hiding (catch)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import System.Environment
import System.IO
import System.Process

The final program is

display.hs

{-# LANGUAGE ScopedTypeVariables #-}

import Control.Exception hiding (catch)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import System.Environment
import System.IO
import System.Process

data Config = Cfg
    { fileName :: String
    , usePager :: Bool
    }

main :: IO ()
main = void $ runMaybeT $ do
    cfg <- MaybeT (mkCfg <$> getArgs) `catch` do
        liftIO $ putStrLn "USAGE: display [-p] <file>"
        fail ""
    runReaderT realMain cfg

mkCfg :: [String] -> Maybe Config
mkCfg [fileName]       = Just $ Cfg fileName False
mkCfg ["-p", fileName] = Just $ Cfg fileName True
mkCfg _                = Nothing

type Prog = ReaderT Config (MaybeT IO)

realMain :: Prog ()
realMain = loadFile >>= display

loadFile :: Prog String
loadFile = do
    file <- asks fileName
    txt  <- liftIO $ try $ readFile file
    case txt of
        Left (_ :: IOException) -> do
            liftIO $ putStrLn $ "ERROR: Unable to read file '" ++ file ++ "'!"
            fail ""
        Right t -> return t

display :: String -> Prog ()
display txt = do
    usePgr <- asks usePager
    liftIO $ if usePgr then do
        let pagerInfo = (shell "less") { std_in = CreatePipe }
        (Just h, _, _, pager) <- createProcess pagerInfo
        hPutStr h txt
        hFlush h
        hClose h
        void $ waitForProcess pager
    else
        putStr txt

catch :: Monad m => MaybeT m a -> MaybeT m a -> MaybeT m a
x `catch` handler = MaybeT $ do
    result <- runMaybeT x
    case result of
        Nothing -> runMaybeT handler
        r       -> return r

Try it out. It still compiles and works:

Shell

$ stack ghc -- display.hs
[1 of 1] Compiling Main             ( display.hs, display.o )
Linking display ...
$ ./display display.hs
{-# LANGUAGE ScopedTypeVariables #-}

import Control.Exception hiding (catch)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import System.Environment
import System.IO
import System.Process

data Config = Cfg
    { fileName :: String
    , usePager :: Bool
    }

main :: IO ()
main = void $ runMaybeT $ do
    cfg <- MaybeT (mkCfg <$> getArgs) `catch` do
        liftIO $ putStrLn "USAGE: display [-p] <file>"
        fail ""
    runReaderT realMain cfg

mkCfg :: [String] -> Maybe Config
mkCfg [fileName]       = Just $ Cfg fileName False
mkCfg ["-p", fileName] = Just $ Cfg fileName True
mkCfg _                = Nothing

type Prog = ReaderT Config (MaybeT IO)

realMain :: Prog ()
realMain = loadFile >>= display

loadFile :: Prog String
loadFile = do
    file <- asks fileName
    txt  <- liftIO $ try $ readFile file
    case txt of
        Left (_ :: IOException) -> do
            liftIO $ putStrLn $ "ERROR: Unable to read file '" ++ file ++ "'!"
            fail ""
        Right t -> return t

display :: String -> Prog ()
display txt = do
    usePgr <- asks usePager
    liftIO $ if usePgr then do
        let pagerInfo = (shell "less") { std_in = CreatePipe }
        (Just h, _, _, pager) <- createProcess pagerInfo
        hPutStr h txt
        hFlush h
        hClose h
        void $ waitForProcess pager
    else
        putStr txt

catch :: Monad m => MaybeT m a -> MaybeT m a -> MaybeT m a
x `catch` handler = MaybeT $ do
    result <- runMaybeT x
    case result of
        Nothing -> runMaybeT handler
        r       -> return r