Skip to content

Instantly share code, notes, and snippets.

@kazu-yamamoto
Last active Dec 12, 2015
Embed
What would you like to do?
Free Monad example with DeriveFunctor
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment