Free Operational example to be interpreted to IO and pure testing.

gistfile1.hs

{-# LANGUAGE GADTs #-}

module Main where

import Control.Monad
import Control.Monad.Operational.Simple
import Prelude hiding (putChar, getChar)
import qualified System.IO as IO
import Test.QuickCheck

----------------------------------------------------------------
-- Our DSL

type CharIO = Program CharActions

data CharActions a where
    GetChar :: CharActions Char
    PutChar :: Char -> CharActions ()

----------------------------------------------------------------
-- APIs of our DSL

getChar :: Program CharActions Char
getChar = singleton GetChar

putChar :: Char -> Program CharActions ()
putChar = singleton . PutChar

----------------------------------------------------------------
-- Running our DSL in IO

runCharIO :: CharIO a -> IO a
runCharIO = interpret advent

advent :: CharActions a -> IO a
advent GetChar = IO.getChar
advent (PutChar c) = IO.putChar c

----------------------------------------------------------------
-- Example code

echo :: CharIO ()
echo = do
    getChar >>= putChar
    echo

echo1 :: CharIO Int
echo1 = do
    getChar >>= putChar
    return 1

----------------------------------------------------------------
-- IO

main :: IO ()
main = runCharIO echo

----------------------------------------------------------------
-- Testing pure

data Output a = Read (Output a)
              | Print Char (Output a)
              | Ret a
              | Eof
              deriving (Eq, Show)

toOutput :: ProgramView CharActions a -> String -> Output a
toOutput (Return a) _                = Ret a
toOutput (GetChar :>>= _)     []     = Eof
toOutput (GetChar :>>= cnt)   (c:cs) = Read (toOutput (view (cnt c)) cs)
toOutput (PutChar x :>>= cnt) []     = Print x (toOutput (view (cnt ())) [])
toOutput (PutChar x :>>= cnt) ccs    = Print x (toOutput (view (cnt ())) ccs)

copy :: String -> Output a
copy []     = Eof
copy (c:cs) = Read $ Print c $ copy cs

prop_echo :: String -> Bool
prop_echo xs = toOutput (view echo) xs == copy xs

test :: IO ()
test = quickCheck prop_echo