Haskell teletype

teletype.hs

import Control.Monad.Free
import Control.Monad
import System.Exit
import Data.Traversable (traverse)

data TeletypeF next
    = Say String next
    | Ask (String -> next)
    | Stop

instance Functor TeletypeF where
    fmap f (Say msg next) = Say msg (f next)
    fmap f (Ask     k)    = Ask (f . k)
    fmap _ Stop           = Stop

type Teletype = Free TeletypeF

say :: String -> Teletype ()
say msg = liftF $ Say msg ()

sayMany :: [String] -> Teletype ()
sayMany [x] = say x
sayMany (x:xs) = say x >> sayMany xs

ask :: Teletype String
ask = liftF $ Ask id

askMany :: Int -> Teletype [String]
askMany 1 = fmap (\s -> [s]) ask
askMany n = do
	x <- ask
	xs <- askMany (n - 1)
	return (x:xs)

stop :: Teletype ()
stop = liftF Stop

telExample :: Teletype ()
telExample = do
    sayMany ["Hello!", "Hello!!!!!"]
    say "What is your name?"
    name <- ask
    say "Tell your age and weight:"
    [age, weight] <- askMany 2
    say $ "You are " ++ age ++ " years old. And your weight is " ++ weight
    when (length name >= 10) stop
    say $ "Hello, " ++ name ++ "!"

runIO :: Teletype a -> IO a
runIO (Pure r) = return r
runIO (Free (Say msg t)) = putStrLn msg >>  runIO t
runIO (Free (Ask f    )) = getLine >>= runIO . f
runIO (Free  Stop      ) = exitSuccess

simulate :: Teletype a -> [String] -> [String]
simulate (Pure _)    _ = []
simulate (Free Stop) _ = []
simulate (Free (Say msg next)) l = msg : simulate next l
simulate (Free (Ask k)) (x:xs) = simulate (k x) xs