Learning some free monads

Free.hs

{-# LANGUAGE KindSignatures, GADTs #-}

-- Inspired by the Well-Typed "Monads for Free!" slides, available online

data Free :: (* -> *) -> * -> * where
    Return :: a -> Free f a
    Wrap :: f (Free f a) -> Free f a

instance Functor f => Functor (Free f) where
    fmap f (Return x) = Return (f x)
    fmap f (Wrap x) = Wrap $ fmap (fmap f) x

instance Functor f => Monad (Free f) where
    return = Return
    (Return x) >>= f = f x
    (Wrap x) >>= f = Wrap (fmap (>>= f) x)

-- We'll define a special functor for our interactions, and the free monad
-- will let us glue these together using ordinary monadic syntax.
-- I read this type as "an interaction resulting in r"
data InteractionOp r = Say String r -- String and a result not depending on it
                     | Ask (String -> r) -- Something you can do with a string

instance Functor InteractionOp where
    fmap f (Say s r) = Say s (f r)
    fmap f (Ask g) = Ask (f . g)

-- So if we want to Ask something and then Say it, this looks like
-- Ask (\s -> Say s ()) :: InteractionOp (InteractionOp ())
--
-- Oh hey, that's the nested structure of the free monad. Let's use that.

type Interaction = Free InteractionOp

say :: String -> Interaction ()
say s = Wrap $ Say s $ return ()

ask :: Interaction String
ask = Wrap $ Ask $ return

-- We can interpret our monadic syntax directly
runInteraction :: Interaction a -> IO a
runInteraction (Return x) = return x
runInteraction (Wrap (Ask c)) = getLine >>= (runInteraction . c)
runInteraction (Wrap (Say s c)) = putStrLn s >> runInteraction c

-- Or we can simulate it as something that takes some String
-- inputs and writes some String outputs.
simulate :: Interaction a -> [String] -> [String]
simulate (Return x) _ = []
simulate (Wrap (Ask c)) (x:xs) = simulate (c x) xs
simulate (Wrap (Say s c)) xs = s:simulate c xs

-- We can run optimization passes on our syntax tree
optimize :: Interaction a -> Interaction a
-- Concatenate adjacent Says
optimize (Wrap (Say s (Wrap (Say s' c)))) = optimize $ Wrap $ Say (s ++ "\n" ++ s') (optimize c)
-- Optimize subexpressions
optimize (Wrap x) = Wrap $ fmap optimize x
optimize x = x

someInteraction = do
    say "What's your name?"
    name <- ask
    say $ "Nice to meet you, " ++ name ++ "."
    say $ "Your name is " ++ (show $ length name) ++ " characters long."
    say "Isn't that interesting?"

main = runInteraction . optimize $ someInteraction



*Main> simulate someInteraction ["Nick"]
["What's your name?","Nice to meet you, Nick.","Your name is 4 characters long.","Isn't that interesting?"]
*Main> simulate (optimize someInteraction) ["Nick"]
["What's your name?","Nice to meet you, Nick.\nYour name is 4 characters long.\nIsn't that interesting?"]