Free monad example

free.hs

module Main where

import Control.Monad.Free

data StackF a
    = Push Int a
    | Pop (Int -> a)

instance Functor StackF where
    fmap f (Push x k) = Push x (f k)
    fmap f (Pop k) = Pop (f . k)

type Stack = Free StackF

push :: Int -> Stack ()
push x = liftF (Push x ())

pop :: Stack Int
pop = liftF (Pop id)

runStack :: Stack a -> Maybe a
runStack = go []
  where
    go _ (Pure x) = Just x
    go stack (Free (Push x k)) = go (x:stack) k
    go [] (Free (Pop _)) = Nothing
    go (x:stack) (Free (Pop k)) = go stack (k x)

showStack :: Stack a -> [String]
showStack = go []
  where
    go _ (Pure _) = []
    go stack (Free (Push x k)) = ("Push " ++ show x) : go (x:stack) k
    go [] (Free (Pop _)) = ["ERROR"]
    go (x:stack) (Free (Pop k)) = ("Pop " ++ show x) : go stack (k x)

test :: Stack Int
test = do
    push 1
    push 2
    push 3
    x <- pop
    push (if x < 2 then 4 else 5)
    fmap (*20) pop

main :: IO ()
main = do
    mapM_ putStrLn $ showStack test
    print $ runStack test