A demonstration of type class design for monadic applications.

monadic.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Writer
import Control.Monad.State
import Control.Arrow
import Data.Maybe
import qualified System.IO.Strict as Strict

-- Split our IO into different classes of interest.

class Monad m => MonadLog m where
  logLine :: String -> m ()

class Monad m => MonadReadFromFile m where
  readFromFile :: FilePath -> m String

class Monad m => MonadWriteToFile m where
  writeToFile :: FilePath -> String -> m ()
  appendToFile :: FilePath -> String -> m ()

class Monad m => MonadInteract m where
  writeLine :: String -> m ()
  readLine :: m String

-- Make an alias class that encompasses all of these things.

class (Monad m
      ,Functor m
      ,MonadLog m
      ,MonadReadFromFile m
      ,MonadWriteToFile m
      ,MonadInteract m) => MonadDemo m
instance (Monad m
      ,Functor m
      ,MonadLog m
      ,MonadReadFromFile m
      ,MonadWriteToFile m
      ,MonadInteract m) => MonadDemo m

-- Implement IO for this class set.

instance MonadLog IO where
  logLine = putStrLn . ("Log: " ++)
instance MonadReadFromFile IO where
  readFromFile = Strict.readFile
instance MonadWriteToFile IO where
  writeToFile = writeFile
  appendToFile = appendFile
instance MonadInteract IO where
  writeLine = putStrLn
  readLine = getLine

-- Make a type to implement a pure version of this class set.

newtype PureIO a = PureIO {
  runPureIO :: StateT ([(FilePath,String)],[String])
                      (WriterT [Out] Identity)
                      a }
  deriving (Monad
           ,Functor
           ,MonadWriter [Out]
           ,MonadState ([(FilePath,String)],[String]))

data Out = Log String | Stdout String
  deriving (Show)

instance MonadLog PureIO where
  logLine x = tell [Log x]
instance MonadInteract PureIO where
  writeLine x = tell [Stdout x]
  readLine = do
    line <- gets (take 1 . snd)
    modify $ second (drop 1)
    return $ concat line
instance MonadReadFromFile PureIO where
  readFromFile file = do
    line <- gets (lookup file . fst)
    return $ fromMaybe "" line
instance MonadWriteToFile PureIO where
  writeToFile file content = do
    modify $ first (update file content)
      where update key value = map swap where
              swap (key',value') | key' == key = (key,value)
                                 | otherwise   = (key',value')
  appendToFile file content = do
    modify $ first (update file content)
      where update key value = map append where
              append (key',value') | key' == key = (key,value' ++ value)
                                   | otherwise   = (key',value')

-- Run a pure demo with some sample state.

runPure :: PureIO a -> ((a, ([([Char], [Char])], [[Char]])), [Out])
runPure = runIdentity . runWriterT . flip runStateT state . runPureIO
  where state = (files,lines)
        files = [("ages.log","13\n")]
        lines = ["abc","123","123","42"]

-- A simple demo program using these simple building blocks.

demo :: MonadDemo m => m ()
demo = do
  age <- getAge
  case age of
    Nothing -> do logLine "Ending."
                  return ()
    Just age -> do tid <- saveAge age
                   writeLine "Cheers! Ages are:"
                   ages <- readAllAges
                   logLine $ show ages
                   demo

readAllAges :: MonadReadFromFile m => m [Integer]
readAllAges = liftM (catMaybes . map readAge . lines) $ readFromFile agesFile

getAge :: (MonadReadFromFile m,MonadInteract m) => m (Maybe Integer)
getAge = do
  writeLine "Enter your age: "
  line <- readLine
  case readAge line of
    Just age -> do ages <- readAllAges
                   if any (==age) ages
                      then do writeLine "Already exists!"
                              getAge
                      else return $ Just age
    Nothing | null line -> return Nothing
            | otherwise -> do writeLine "Bogus!"
                              getAge
  
saveAge :: MonadWriteToFile m => Integer -> m ()
saveAge = appendToFile agesFile . (++ "\n") . show

readAge :: String -> Maybe Integer
readAge age =
  case reads age of
    [(n,"")] -> Just n
    _        -> Nothing

agesFile :: String
agesFile = "ages.log"

-- Output:

-- λ> runPure demo
-- (((),([("ages.log","13\n123\n42\n")],[])),[Stdout "Enter your age: ",Stdout "Bogus!",Stdout "Enter your age: ",Stdout "Cheers! Ages are:",Log "[13,123]",Stdout "Enter your age: ",Stdout "Already exists!",Stdout "Enter your age: ",Stdout "Cheers! Ages are:",Log "[13,123,42]",Stdout "Enter your age: ",Log "Ending."])