Testing effectful programs in Haskell, take 2

testing-free-monads.hs

-- With much thanks to Cirdec of Stack Overflow: http://stackoverflow.com/questions/32673144/how-do-i-compare-a-program-specified-as-a-free-monad-against-a-description-of-ex

{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ViewPatterns #-}

import Text.Show.Functions
import Control.Monad.Operational

-- Core effect definition

data Intent result where
    Prompt :: String -> Intent String
    Display :: String -> Intent ()
deriving instance Show (Intent result)

type MyEffect a = Program Intent a

prompt p = singleton (Prompt p)
display o = singleton (Display o)

-- |run programs in the real world
runIO :: MyEffect a -> IO a
runIO (view -> (Return x)) = return x
runIO (view -> (Prompt p :>>= cont)) = do
    putStr p
    line <- getLine
    runIO (cont line)
runIO (view -> (Display o :>>= cont)) = do putStrLn o; runIO (cont ())


-- |A sample program
greet :: MyEffect String
greet = do
    name <- prompt "Enter your name: "
    let greeting = "Why hello there, " ++ name ++ "."
    display greeting
    friendName <- prompt "And what is your friend's name? "
    display ("It's good to meet you too, " ++ friendName ++ ".")
    return "blacrg"


-- Testing API

-- |Check if the next instruction is a Prompt with the given parameter,
--  and simulate returning a value.
checkPrompt :: String -> String -> MyEffect a -> Either String (MyEffect a)
checkPrompt expected response prog =
    case view prog of
        (Prompt p :>>= cont)
            | p == expected -> Right (cont response)
        (intent :>>= cont)  -> Left $ "Expected (Prompt " ++ show expected ++ ") Got (" ++ show intent ++ ")"

-- |Check if the next instruction is a Display with the given parameter
checkDisplay :: String -> MyEffect a -> Either String (MyEffect a)
checkDisplay expected prog =
    case view prog of
        (Display o :>>= cont)
            | o == expected -> Right (cont ())
        (intent :>>= cont)  -> Left $ "Expected (Display " ++ show expected ++ ") Got (" ++ show intent ++ ")"

-- |Check if the next instruction is a Return with the given parameter
checkReturn :: (Eq a, Show a) => a -> MyEffect a -> Either String ()
checkReturn expected prog =
    case view prog of
        Return x | x == expected -> Right ()
                 | otherwise     -> Left $ "Expected (Return " ++ show expected ++ ") Got (Return " ++ show x ++ ")"

-- Finally, the test case for the `greet` program.
testGreet prog =
    Right prog >>=
    checkPrompt "Enter your name: " "radix" >>=
    checkDisplay "Why hello there, radix." >>=
    checkPrompt "And what is your friend's name? " "Bob" >>=
    checkDisplay "It's good to meet you too, Bob." >>=
    checkReturn "blacrg"