Free Monad Web example

FreeWeb.hs

import Control.Monad.Free -- from category-extras

data WebF r = Display String r | Form String (String -> r)

instance Functor WebF where
  fmap f (Display m r) = Display m (f r)
  fmap f (Form m g)    = Form m (f . g)

type Web = Free WebF


display :: String -> Web ()
display msg = inFree (Display msg $ return ())

form :: String -> Web String
form msg = inFree (Form msg return)


runWebInteractively :: Web String -> IO ()
runWebInteractively = cataFree runDone runWebF

runDone :: String -> IO ()
runDone x = putStrLn $ "Done: " ++ x

runWebF :: WebF (IO ()) -> IO ()
runWebF (Display msg np) = do
  putStrLn msg
  np
runWebF (Form msg np) = do 
  putStrLn msg
  putStr "Request> "
  r <- getLine
  np r

example = do name <- form "Hello, what's your name?"
             display $ "Hello, " ++ name
             l    <- form "Enter numbers seperated by spaces:"
             return $ name ++ ", the sum is: " ++ show (sum' l)

runExample = runWebInteractively example

sum' :: String -> Int
sum' = sum . map read . words