Testing Monad with QuickCheck

gistfile1.hs

module Main where

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

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

type CharIO = CharActions

data CharActions a = GetChar (Char -> CharActions a)
                   | PutChar Char (CharActions a)
                   | Pure a

----------------------------------------------------------------
-- Our DSL should be Monad

instance Monad CharActions where
    GetChar g   >>= f = GetChar (g >=> f)
    PutChar c x >>= f = PutChar c (x >>= f)
    Pure x      >>= f = f x
    return            = Pure

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

getChar :: CharIO Char
getChar = GetChar return

putChar :: Char -> CharIO ()
putChar c = PutChar c (return ())

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

runCharIO :: CharActions a -> IO a
runCharIO (GetChar f)     = IO.getChar   >>= runCharIO . f
runCharIO (PutChar c cnt) = IO.putChar c >>  runCharIO cnt
runCharIO (Pure x)        = return x

----------------------------------------------------------------
-- 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)
              | Return a
              | Eof
              deriving (Eq, Show)

toOutput :: CharIO a -> String -> Output a
toOutput (Pure a) _             = Return a
toOutput (GetChar _)     []     = Eof
toOutput (PutChar x cnt) []     = Print x (toOutput cnt [])
toOutput (GetChar f)     (c:cs) = Read (toOutput (f c) cs)
toOutput (PutChar x cnt) ccs    = Print x (toOutput cnt ccs)

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

prop_echo :: String -> Bool
prop_echo xs = toOutput echo xs == copy xs

test :: IO ()
test = quickCheck prop_echo