Free.fr

module hello.HelloWorld where

import Data.Foldable (Foldable)
import Data.Traversable (Traversable)

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

liftF :: Functor f => f a -> Free f a
liftF f = Free (fmap Pure f)

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)

instance Foldable f => Foldable (Free f) where
  foldMap f (Pure a) = f a
  foldMap f (Free fa) = foldMap (foldMap f) fa

instance Traversable f => Traversable (Free f) where
    traverse f (Pure a) = Pure <$> f a
    traverse f (Free fa) = Free <$> traverse (traverse f) fa

-- Playing around

data IOCommands a =
    GetLine (String -> a)
  | PutLine String a

instance Functor IOCommands where
  fmap f (GetLine a) = GetLine (\x -> f (a x))
  fmap f (PutLine s a) = PutLine s (f a)

type FreeIO = Free IOCommands

getLineF :: FreeIO String
getLineF = Free (GetLine Pure)

putLineF :: String -> FreeIO ()
putLineF s = Free (PutLine s (Pure ()))

-- Natural transformation from FreeIO ~> IO
unsafePerformFreeIO :: FreeIO a -> IO a
unsafePerformFreeIO (Pure a) = return a
unsafePerformFreeIO (Free (GetLine a)) =
  getLine >>= \x -> unsafePerformFreeIO (a x)
unsafePerformFreeIO (Free (PutLine s a)) =
  putStrLn s >> unsafePerformFreeIO a

-- And a demo

mySafeProgram :: FreeIO ()
mySafeProgram = do
  putLineF "What is your name? "
  str <- getLineF
  putLineF $ "Hello there " ++ str ++ "!"

main = unsafePerformFreeIO mySafeProgram