PlayingWithFree.hs

{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}

import Control.Arrow ((&&&))
import Data.Functor.Coyoneda

import qualified Control.Monad.Free as F



-- The van Laarhoven-encoded Free Monad
newtype Free effect a =
  Free { runFree :: forall m. Monad m => effect m -> m a }

instance Functor (Free effect) where
  fmap f (Free run) = Free (fmap f . run)

instance Applicative (Free effect) where
  pure a = Free (const (pure a))
  (Free fab) <*> (Free a) =
    Free (\e -> fab e <*> a e)

instance Monad (Free effect) where
  (Free run) >>= f =
    Free (\e -> run e >>= \a -> runFree (f a) e)



-- T for "traditional" Free monad encoding
data TeletypeT a = GetStringT (String -> a)
                 | PrintStringT String a
                 deriving Functor

getStringT :: F.Free TeletypeT String
getStringT = F.liftF $ GetStringT id

printStringT :: String -> F.Free TeletypeT ()
printStringT s = F.liftF $ PrintStringT s ()

traditionalFree :: F.Free TeletypeT ()
traditionalFree = do
    myString <- getStringT
    printStringT myString



-- C for Coyoneda Free monad encoding
data TeletypeC a where
    GetStringC :: TeletypeC String
    PrintStringC :: String -> TeletypeC ()

getStringC :: F.Free (Coyoneda TeletypeC) String
getStringC = F.liftF $ liftCoyoneda GetStringC

printStringC :: String -> F.Free (Coyoneda TeletypeC) ()
printStringC s = F.liftF $ liftCoyoneda $ PrintStringC s


freeC :: F.Free (Coyoneda TeletypeC) ()
freeC = do
    myString <- getStringC
    printStringC myString



-- VL for van Laarhoven Free monad encoding
data TeletypeVL m = TeletypeVL
    { getStringF :: m String
    , putStringF :: String -> m ()
    }


ioTeletype :: TeletypeVL IO
ioTeletype = TeletypeVL { getStringF = getLine, putStringF = putStrLn }

getStringVL :: Free TeletypeVL String
getStringVL = Free (\f -> getStringF f)

putStringVL :: String -> Free TeletypeVL ()
putStringVL s = Free (\f -> putStringF f s)


freeVL :: Free TeletypeVL ()
freeVL = do
    myString <- getStringVL
    putStringVL myString



-- TC for type class (final-tagless) encoding of operations.
class TeletypeTC rep where
    getStringTC :: rep String
    printStringTC :: String -> rep ()


freeTC :: (TeletypeTC m, Monad m) => m ()
freeTC = do
    myString <- getStringTC
    printStringTC myString

instance TeletypeTC IO where
    getStringTC = getLine
    printStringTC = putStrLn

instance TeletypeTC (Free TeletypeVL) where
    getStringTC = getStringVL
    printStringTC = putStringVL

instance TeletypeTC (Free TeletypeVL) where
    getStringTC = getStringC
    printStringTC = putStringC


ioEval :: IO ()
ioEval = freeTC