Create a gist now

Instantly share code, notes, and snippets.

@Xion /Printer.hs Secret
Created Jul 31, 2017

What would you like to do?
Printer monad example
#!/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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment