a minimal free monad implementation

freeMonad.hs

{-# LANGUAGE RankNTypes, TypeOperators #-}
module Main where
import Prelude as P

data Free f a
  = Pure a
  | Free (f (Free f a))

instance Functor f => Functor (Free f) where
  fmap f (Pure a) = Pure $ f a
  fmap f (Free fa) = Free $ fmap (fmap f) fa


instance Functor f => Applicative (Free f) where
  pure = Pure
  Pure a <*> Pure b  = Pure $ a b
  Pure a <*> Free mb = Free $ fmap a <$> mb
  Free ma <*> b      = Free $ (<*> b) <$> ma


instance Functor f => Monad (Free f) where
  return = pure
  Pure a >>= f = f a
  Free m >>= f = Free $ (>>= f) <$> m

liftF :: Functor f => f a -> Free f a
liftF x = Free $ fmap Pure x

--------------------------------------------------------------------------------

data ConsoleF a
  = PutStrLn String a
  | GetLine (String -> a)

instance Functor ConsoleF where
  fmap f (PutStrLn s a) = PutStrLn s (f a)
  fmap f (GetLine fa)   = GetLine $ f . fa


type Console = Free ConsoleF

infixr 0 ~>
type f ~> g = forall x. f x -> g x

runConsole :: Console ~> IO
runConsole (Pure a) = return a
runConsole (Free (PutStrLn s v)) = P.putStrLn s >> runConsole v
runConsole (Free (GetLine f)) = P.getLine >>= runConsole . f

getLine' :: Console String
getLine' = liftF $ (GetLine id)

putStrLn' :: String -> Console ()
putStrLn' s = liftF $ (PutStrLn s ())

echo :: Console ()
echo = do
  putStrLn' "> Please input your name: "
  x <- getLine'
  putStrLn' $ "hello, " ++ x

echo' :: Console ()
echo' = Free (PutStrLn "> Please input your name:" (Pure ()))
      >> Free (GetLine (\x -> Pure x))
      >>= \x -> Free (PutStrLn ("hello, " ++ x) (Pure ()))

echo'' :: Console ()
echo'' = Free (
  PutStrLn "> Please input your name:" (Free (
    GetLine (\x -> (Free (
      PutStrLn ("hello, " ++ x) (Pure ())))))))

main :: IO ()
main = runConsole $ echo'