Final haskell example for my STL talk

testing-free-monads.hs

{-# 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, String)
greet = do
    name <- prompt "Enter your name> "
    display ("Hello there, " ++ name ++ "!")
    fname <- prompt "Friend's name? "
    display ("Greets, " ++ fname ++ ".")
    return (name, fname)


-- 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 "Hello there, radix!" >>=
    checkPrompt "Friend's name? " "ace" >>=
    checkDisplay "Greets, ace." >>=
    checkReturn ("radix", "ace")