Printer monad example

Printer.hs

#!/usr/bin/env stack
{-
  stack --resolver lts-9.0 script
  --package directory,extra,filepath,mtl,text,text-show
-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Main where

import Control.Monad (forM_)
import Control.Monad.Extra (whenJust)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Writer (execWriter, execWriterT, tell, Writer, WriterT)
import Control.Monad.Writer.Class (MonadWriter)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text.IO as Text
import System.Directory (getFileSize)
import System.FilePath (FilePath)
import TextShow (showt)


data Order = Order { ordNumber :: Text
                   , ordDeliveryAddress :: Address
                   , ordItems :: [Item]
                   , ordBillingAddress :: Maybe Address
                   }

data Item = Item { itName :: Text, itQuantity :: Int }

data Address = Address { addrFirstName :: Text
                       , addrLastName :: Text
                       , addrLine1 :: Text
                       , addrLine2 :: Maybe Text
                       , addrCity :: Text
                       , addrPostalCode :: Text
                       }


ppOrder :: Order -> Text
ppOrder Order{..} = execWriter $ do
    putLn $ "Order #" <> ordNumber
    ppAddress ordDeliveryAddress
    forM_ (zip [1..] ordItems) $ \(i, Item{..}) -> do
        putLn $ showt (i::Int) <> ". " <> itName <> " x" <> showt itQuantity
    whenJust ordBillingAddress ppAddress

ppAddress :: Address -> Writer Text ()
ppAddress Address{..} = do
    putLn $ addrFirstName <> " " <> addrLastName
    putLn addrLine1
    whenJust addrLine2 putLn
    putLn $ addrCity <> ", " <> addrPostalCode


-- To print this data type nicely, we sadly require I/O :(
data User = User { usrName :: Text
                 , usrHomeDir :: FilePath
                 }

ppUser :: User -> IO Text
ppUser User{..} = execPrinter $ do
    putLn $ "Name: " <> usrName
    homeSize <- liftIO $ getFileSize usrHomeDir
    putLn $ "$HOME: " <> showt usrHomeDir <> "(" <> showt homeSize <> " bytes)"

type Printer a = WriterT Text IO a

execPrinter :: Printer () -> IO Text
execPrinter = execWriterT


putLn :: MonadWriter Text m => Text -> m ()
putLn line = tell $ line <> "\n"


main :: IO ()
main = do
    let address = Address "John" "Smith" "123 Main Rd" Nothing "Townsville" "13X"
    let order = Order "42-42" address [Item "Pizza" 1] Nothing
    Text.putStr $ ppOrder order