Free Monad (RWH 15.8)

gistfile1.hs

----------------------------------------------------------------
-- Free Monad example agaist RWH 15.8
--
-- Original code: http://ideone.com/F49k71

import Control.Applicative
import Control.Monad.Free
import System.IO (Handle, IOMode(..), stdout)
import qualified System.IO as IO
import System.IO.Unsafe

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

type HandleIO = Free HandleAction
 
data HandleAction a = Open FilePath IOMode (Handle -> a)
                    | Close Handle a
                    | PutString Handle String a
                    | GetContents Handle (String -> a)
                    | LiftIO (IO a)

----------------------------------------------------------------
-- Our DSL should be Functor

instance Functor HandleAction where
    fmap f (Open path mode r)  = Open path mode (f . r)
    fmap f (Close h x)         = Close h (f x)
    fmap f (PutString h str x) = PutString h str (f x)
    fmap f (GetContents h r)   = GetContents h (f . r)
    fmap f (LiftIO m)          = LiftIO (f <$> m)

----------------------------------------------------------------
-- APIs of Our DSL

openFile :: FilePath -> IOMode -> HandleIO Handle
openFile path mode = liftF $ Open path mode id 

hClose :: Handle -> HandleIO ()
hClose h  = liftF $ Close h ()

hPutStr :: Handle -> String -> HandleIO ()
hPutStr h str = liftF $ PutString h str ()

hGetContents :: Handle -> HandleIO String
hGetContents h = liftF $ GetContents h id

liftIO :: IO a -> HandleIO a
liftIO m = liftF $ LiftIO m

hPutStrLn :: Handle -> String -> HandleIO ()
hPutStrLn h str = hPutStr h (str ++ "\n")

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

runHandleIO :: HandleIO a -> IO a
runHandleIO (Pure a)   = return a
runHandleIO (Free x) = case x of
    Open path mode r          -> IO.openFile path mode  >>= runHandleIO . r
    Close handle cont         -> IO.hClose handle       >>  runHandleIO cont
    PutString handle str cont -> IO.hPutStr handle str  >>  runHandleIO cont
    GetContents handle r      -> IO.hGetContents handle >>= runHandleIO . r
    LiftIO m                  -> m                      >>= runHandleIO

----------------------------------------------------------------
-- Showing our DSL

showHandleIO :: Show a => HandleIO a -> String
showHandleIO (Pure a)   = "return " ++ show a ++ "\n"
showHandleIO (Free x) = case x of
    Open path mode r          -> "openFile " ++ show path ++ " " ++ show mode ++ "\n" ++ showHandleIO (r stdout)
    Close handle cont         -> "hClose " ++ show handle ++ "\n" ++ showHandleIO cont
    PutString handle str cont -> "hPutStr " ++ show handle ++ " " ++ str ++ "\n" ++ showHandleIO cont
    GetContents handle r      -> "hGetContents " ++ show handle ++ "\n" ++ showHandleIO (r "dummy")
    LiftIO m                  -> "liftIO " ++ "\n" ++ showHandleIO (unsafePerformIO m)

----------------------------------------------------------------
-- Composing example code of our DSL

safeHello :: FilePath -> HandleIO ()
safeHello path = do
    h <- openFile path WriteMode
    hPutStrLn h "Hello, world!"
    hClose h
    
example :: HandleIO ()
example = do
    liftIO $ print (42 :: Int)
    safeHello "/dev/stdout"
    hGetContents IO.stdin >>= hPutStr IO.stdout