Console algebra

gistfile1.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Main where

import Data.Functor
import Control.Monad
import Control.Monad.State
import Control.Monad.Writer


-- | finally tagless encoding of a simple algebra representing
--   interaction with a console device
class ConsoleAction f where
  readLine :: f (Maybe String)
  putLine  :: String -> f ()

instance ConsoleAction IO where
  readLine = mfilter (not . null) . Just <$> getLine
  putLine = putStrLn

-- | A console interpreter where all lines are read from a predefined input
newtype CannedInput a =
  CannedInput { runCannedInput :: StateT [String] (Writer [String]) a }
  deriving (Monad, (MonadState [String]), (MonadWriter [String]))

runCanned :: CannedInput () -> String -> String
runCanned action =
  unlines . snd . runWriter . runStateT (runCannedInput action) . lines 

instance ConsoleAction CannedInput where
  readLine = do
    input <- get
    case input of
      x:xs -> put xs >> return (Just x)
      _    -> return Nothing

  putLine line = tell [line]

greet :: (Monad f, ConsoleAction f) => f ()
greet = do
  putLine "Hello! What's your name?"
  name <- readLine
  case name of
    Just n  -> putLine $ "Hello, " ++ n
    Nothing -> putLine "Oh, you're quiet, aren't you."

cannedMain :: String
cannedMain = runCanned greet "Ben"

main :: IO ()
main = greet