Testing typeclass with QuickCheck

gistfile1.txt

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

module Main where

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

class Monad m => CharIO m where
    getChar :: m Char
    putChar :: Char -> m ()

instance CharIO IO where
    getChar = IO.getChar
    putChar = IO.putChar

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

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

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

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

main :: IO ()
main = echo

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

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

type EOFError = String

type PureIO = ErrorT EOFError (RWS () [Output] String)

instance CharIO PureIO where
    getChar   = do
        cs <- lift get
        case cs of
            []   -> throwError "EOF"
            x:xs -> do
                lift $ put xs
                lift $ tell [Read]
                return x
    putChar c = lift $ tell [Print c]
    
toOutput :: PureIO a -> String -> (Either EOFError a, [Output])
toOutput act str = evalRWS (runErrorT act) () str

copy :: String -> [Output]
copy []     = []
copy (c:cs) = [Read, Print c] ++ copy cs

prop_echo :: String -> Bool
prop_echo xs = toOutput echo xs == (Left "EOF", copy xs)

test :: IO ()
test = quickCheck prop_echo