Free monads

teletype.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveFunctor #-}
module Teletype
       ( main -- :: IO ()
       ) where
import Prelude hiding (putStrLn, getLine)
import qualified Prelude as P (putStrLn, getLine)
import qualified System.Exit as Exit (exitSuccess)
import System.Environment (getArgs)

import Test.QuickCheck (quickCheck)

import Control.Monad.Free

data TeletypeF r
  = PutStrLn String r
  | GetLine (String -> r)
  | ExitSuccess
  deriving (Functor)

type Teletype = Free TeletypeF

putStrLn :: String -> Teletype ()
putStrLn = liftF . flip PutStrLn ()

getLine :: Teletype String
getLine = liftF $ GetLine id

exitSuccess :: Teletype ()
exitSuccess = liftF ExitSuccess

{-# RULES
  "exit" forall m. exitSuccess >> m = exitSuccess
    #-}

echo :: Teletype ()
echo = do
  str <- getLine
  putStrLn str
  exitSuccess
  putStrLn "done!"

runIO :: TeletypeF (IO r) -> IO r
runIO = \case
  PutStrLn x r -> P.putStrLn x >> r
  GetLine f    -> P.getLine >>= f
  ExitSuccess  -> Exit.exitSuccess

runPure :: Teletype r -> [String] -> [String]
runPure (Pure r)              _   = []
runPure (Free (PutStrLn y t)) xs  = y:runPure t xs
runPure (Free (GetLine k))    []  = []
runPure (Free (GetLine k)) (x:xs) = runPure (k x) xs
runPure (Free (ExitSuccess))  _   = []

liftRun :: (Monad m, Functor f) => (f (m a) -> m a) -> Free f a -> m a
liftRun f = iter f . fmap return

main :: IO ()
main = getArgs >>= go
  where go ["-test"] = quickCheck (\xs -> runPure echo xs == take 1 xs)
        go _         = liftRun runIO echo