This document is a Literate Haskell file, available here

In this article I demonstrate how to use classy prisms and Plated to write and apply optimisations to programs written in a free monad DSL.

Plated is a class in lens that provides powerful tools to work with self-recursive data structures. One such tool is recursive bottom-up rewriting, which repeatedly applies a transformation everywhere in a Plated structure until it can no longer be applied.

The free monad has an instance of Plated :

Traversable f => Plated ( Free f a) f a)

so if you derive Foldable and Traversable for the underlying functor, you can use the Plated combinators on your free monad DSL.

Defining classy prisms for the base functor provides pattern matching on free monad programs for free. When coupled with rewrite , we get a system for applying optimisations to our free monad programs with minimal effort.

Let’s get into it.

{-# language DeriveFunctor #-} {-# language DeriveFoldable #-} {-# language DeriveTraversable #-} {-# language FlexibleInstances #-} {-# language FunctionalDependencies #-} {-# language MultiParamTypeClasses #-} {-# language TemplateHaskell #-} module FreePlated where import Control.Lens.Fold ((^?)) ((^?)) import Control.Lens.Plated ( Plated , rewrite) , rewrite) import Control.Lens.Prism (aside) (aside) import Control.Lens.Review ((#)) ((#)) import Control.Lens.TH (makeClassyPrisms) (makeClassyPrisms) import Control.Monad.Free ( Free , liftF, _ Free ) , liftF, _ import Data.Monoid ( First (..)) (..))

First, define the DSL. This is a bit of a contrived one:

data InstF a = One a | Many Int a | Pause a deriving ( Functor , Foldable , Traversable , Eq , Show ) type Inst = Free InstF one :: Inst () () = liftF $ One () oneliftF() many :: Int -> Inst () () = liftF $ Many n () many nliftFn () pause :: Inst () () = liftF $ Pause () pauseliftF()

one - “do something once”

- “do something once” many n - “do something n times”

- “do something times” pause - “take a break”

In this DSL, we are going impose the property that many n should be equivalent to replicateM_ n one .

Next, generate classy prisms for the functor.

'InstF makeClassyPrisms '

makeClassyPrisms ''InstF generates the following prisms:

_InstF :: AsInstF s a => Prism' s ( InstF a) ` s as (a)

_One :: AsInstF s a => Prism' s a s as a

_Many :: AsInstF s a => Prism' s ( Int , a) ` s as (, a)

_Pause :: AsInstF s a => Prism' s a ` s as a

Lift the classy prisms into the free monad:

instance AsInstF ( Inst a) ( Inst a) where a) (a) = _Free _InstF_Free

We can now use the prisms as if they had these types:

_One :: Prism' ( Inst a) ( Inst a) a) (a)

_Many :: Prism' ( Inst a) ( Int , Inst a) a) (a)

_Pause :: Prism' ( Inst a) ( Inst a) a) (a)

If one of these prisms match, it means the program begins with that particular instruction, and the Inst a returned is the tail of the program.

Now it’s time to write optimisations over the free monad structure. A rewrite rule has the type a -> Maybe a - if the function returns a Just , the input will be replaced with the contents of the Just . If it returns Nothing then no rewriting will occur.

optimisations :: AsInstF s s => [s -> Maybe s] s s[ss] = [onesToMany, oneAndMany, manyAndOne] optimisations[onesToMany, oneAndMany, manyAndOne] where

Rule 1: one followed by one is equivalent to many 2

= do onesToMany s <- s ^? _One . _One s'_One_One pure $ _Many # ( 2 , s') _Many, s')

Rule 2: one followed by many n is equivalent to many (n+1)

= do oneAndMany s <- s ^? _One . _Many (n, s')_One_Many pure $ _Many # (n + 1 , s') _Many(n, s')

Rule 3: many n followed by one is equivalent to many (n+1)

= do manyAndOne s <- s ^? _Many . aside _One (n, s')_Manyaside _One pure $ _Many # (n + 1 , s') _Many(n, s')

The last step is to write a function that applies all the optimisations to a program.

optimise :: ( Plated s, AsInstF s s) => s -> s s,s s) = rewrite $ getFirst . foldMap ( First . ) optimisations optimiserewritegetFirst) optimisations

getFirst . foldMap (First .) has type [a -> Maybe a] -> a -> Maybe a . It combines all the rewrite rules into a single rule that picks the first rule to succeed for the input.

Now we can optimise a program:

= do program one one one pause one one 3 many one

The one s before the pause should collapse into many 3 , and the instructions after the pause should collapse into many 6 .

ghci> optimise program == (many 3 *> pause *> many 6) True

:)