Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Testing Free Monad with QuickCheck
module Main where
import Control.Monad
import Control.Monad.Free
import Prelude hiding (putChar, getChar)
import qualified System.IO as IO
import Test.QuickCheck
----------------------------------------------------------------
-- Our DSL
type CharIO = Free CharActions
data CharActions a = GetChar (Char -> a)
| PutChar Char a
----------------------------------------------------------------
-- Our DSL should be Functor
instance Functor CharActions where
f `fmap` GetChar g = GetChar (f . g)
f `fmap` PutChar c x = PutChar c (f x)
----------------------------------------------------------------
-- APIs of our DSL
getChar :: CharIO Char
getChar = liftF $ GetChar id
putChar :: Char -> CharIO ()
putChar c = liftF $ PutChar c ()
----------------------------------------------------------------
-- Running our DSL in IO
runCharIO :: Free CharActions a -> IO a
runCharIO (Pure a) = return a
runCharIO (Free a) = case a of
GetChar f -> IO.getChar >>= runCharIO . f
PutChar c cnt -> IO.putChar c >> runCharIO cnt
----------------------------------------------------------------
-- 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 (Free a) [] = case a of
GetChar _ -> Eof
PutChar x cnt -> Print x (toOutput cnt [])
toOutput (Free a) ccs@(c:cs) = case a of
GetChar f -> Read (toOutput (f c) cs)
PutChar x cnt -> 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment