Code example from "Free Monads Just Got Cheaper" blog post

robot_example.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ViewPatterns #-}
module Main where
import Fixed.FreeMonad
import Data.Interface.TSequence
import Control.Monad
import Control.Applicative
import qualified Control.Monad.Free as F

data FDirective next = FL next | FR next | FS
  deriving (Functor, Show)

-- Traditional Free Monad
type TFM a = F.Free FDirective a

interpret' :: TFM a -> IO ()
interpret' (F.Free (FL f)) = putStrLn "Going left"  >> interpret' f
interpret' (F.Free (FR f)) = putStrLn "Going right" >> interpret' f
interpret' (F.Free FS)     = putStrLn "Saw shutdown, stopping"
interpret' (F.Pure _)      = error "Improper termination"

-- Niceties ...
left'     = F.liftF (FL ())
right'    = F.liftF (FR ())
shutdown' = F.liftF FS

instrs' :: F.Free FDirective a
instrs' = do
  left'
  right'
  left'
  shutdown'

main' = interpret' instrs'


-- "Reflection Without Remorse" version of free monads
type FM a = FreeMonad FDirective a 

interpret :: FM a -> IO ()
interpret (toView -> Impure (FL f)) =
  putStrLn "Going left"  >> (interpret f)
interpret (toView -> Impure (FR f)) =
  putStrLn "Going right"  >> (interpret f)  
interpret (toView -> Impure FS) = putStrLn "Saw shutdown, stopping"
interpret (toView -> Pure _ )  = error "Improper termination"

left :: FreeMonad FDirective () 
left = liftF $ FL () -- same as `fromView $ Impure FR``
right = liftF $ FR ()
shutdown = liftF $ FS

liftF :: Functor f => f a -> FreeMonad f a 
liftF x = fromView $ Impure (fmap return x)

instrs :: FM ()
instrs = 
 do left
    right
    left
    shutdown

main :: IO ()
main = interpret instrs