Solution for http://www.reddit.com/r/haskell/comments/27wqk6/navigating_and_modifying_asts_built_on_the_free/

ast.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}

module Main where

import Prelude hiding (repeat)

import Data.Data

import Control.Monad (forM_)

import Control.Monad.Free
import Control.Monad.Free.TH

import Data.Generics (everywhere, mkT)

data CommandF next = DisplayChar Char next
                  | DisplayString String next
                  | Repeat Int (Free CommandF ()) next
                  | Done
  deriving (Eq, Show, Functor, Data, Typeable)

makeFree ''CommandF

type Command = Free CommandF

execute :: Command () -> IO ()
execute = iterM handle
  where
    handle = \case
        DisplayChar ch next -> putChar ch >> next
        DisplayString str next -> putStr str >> next
        Repeat n block next -> forM_ [1 .. n] (\_ -> execute block) >> next
        Done -> return ()

optimize :: Command () -> Command ()
optimize = optimize' . optimize'
  where
    optimize' = everywhere (mkT inner)

    inner :: Command () -> Command ()
    -- char + char becomes string
    inner (Free (DisplayChar c1 (Free (DisplayChar c2 next)))) = do
        displayString [c1, c2]
        next

    -- char + string becomes string
    inner (Free (DisplayChar c (Free (DisplayString s next)))) = do
        displayString $ c : s
        next

    -- string + string becomes string
    inner (Free (DisplayString s1 (Free (DisplayString s2 next)))) = do
        displayString $ s1 ++ s2
        next

    -- Loop unrolling
    inner f@(Free (Repeat n block next)) | n < 5 = forM_ [1 .. n] (\_ -> block) >> next
                                         | otherwise = f

    inner a = a

prog :: Command ()
prog = do
    displayChar 'a'
    displayChar 'b'
    repeat 1 $ displayChar 'c' >> displayString "def"
    displayChar 'g'
    displayChar 'h'
    repeat 10 $ do
        displayChar 'i'
        displayChar 'j'
        displayString "klm"
    repeat 3 $ displayChar 'n'

main :: IO ()
main = do
    putStrLn "Original program:"
    print prog
    putStrLn "Evaluation of original program:"
    execute prog
    putStrLn "\n"

    let opt = optimize prog
    putStrLn "Optimized program:"
    print opt
    putStrLn "Evaluation of optimized program:"
    execute opt
    putStrLn ""