Free Monad example with DeriveFunctor

gistfile1.hs

{-# LANGUAGE DeriveFunctor #-}

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
                   deriving Functor

----------------------------------------------------------------
-- 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