subtle free monads

freet.hs

{-# LANGUAGE DeriveFunctor #-}
module Main where

import Control.Monad.IO.Class
import Control.Monad.State
import Control.Monad.Trans.Free

data MyFunctor next = PrimitiveA next | PrimitiveB next deriving Functor
type MyFreeT m = FreeT MyFunctor m
type Program = MyFreeT (StateT Int IO)

primA = liftF (PrimitiveA ())
primB = liftF (PrimitiveB ())

-- some program built from primitives defined in MyFunctor and StateT operations
program :: Program Int
program = do
  lift get >>= liftIO . putStrLn . (\n -> "a-" ++ show n)
  primA
  lift get >>= liftIO . putStrLn . (\n -> "b-" ++ show n)
  primB
  lift get >>= liftIO . putStrLn . (\n -> "c-" ++ show n)
  -- returned value
  lift get

-- some function to evaluate primitives at each step
step :: MonadIO m => MyFunctor (m a) -> m a
step (PrimitiveA next) = liftIO (print "primitive A") >> next
step (PrimitiveB next) = liftIO (print "primitive B") >> next

-- runs the program
example1 = runStateT (iterT step program) 0 >>= print

-- let's count every primitives
example2 = runStateT (iterT (\x -> modify (+1) >> step x) program) 0 >>= print

-- let's also count primitives
example3 = runStateT (iterT step (hoistFreeT (\x -> modify (+1) >> x) program)) 0 >>= print

main = do
  print "** example-1"
  example1
  print "** example-2"
  example2
  print "** example-3"
  example3
  
{- OUTPUT (reformatted for readability)

"** example-1"       "** example-2"      "** example-3"
a-0                  a-0                  a-1
"primitive A"        "primitive A"       "primitive A"
b-0                  b-1                  b-2
"primitive B"        "primitive B"        "primitive B"
c-0                  c-2                  c-3
(0,0)                (2,2)                (3,3)

Example 1 just a "control group" to ensure there is not madness.
Example 2 seems to be a post-increment:
  - actually, we changed the evaluator function
Example 3 seems to be a pre-increment:
  - actually, we changed the program

-}