Is it possible to extend free monad interpreters?

Given a free monad DSL such as:

data FooF x = Foo String x
            | Bar Int    x
  deriving (Functor)

type Foo = Free FooF

And a random interpreter for Foo:

printFoo :: Foo -> IO ()
printFoo (Free (Foo s n)) = print s >> printFoo n
printFoo (Free (Bar i n)) = print i >> printFoo n

It appears to me that it should be possible to intersperse something into each iteration of printFoo without resorting to doing it manually:

printFoo' :: Foo -> IO ()
printFoo' (Free (Foo s n)) = print s >> print "extra info" >> printFoo' n
printFoo' (Free (Bar i n)) = print i >> print "extra info" >> printFoo' n

Is this somehow possible by 'wrapping' the original printFoo?

Motivation: I am writing a small DSL that 'compiles' down to a binary format. The binary format contains some extra information after each user command. It has to be there, but is totally irrelevant in my usecase.

The other answers have missed how simplefree makes this! :) Currently you have

{-# LANGUAGE DeriveFunctor #-}

import Control.Monad.Free

data FooF x = Foo String x
            | Bar Int    x
  deriving (Functor)

type Foo = Free FooF

program :: Free FooF ()
program = do
  liftF (Foo "Hello" ())
  liftF (Bar 1 ())
  liftF (Foo "Bye" ())

printFoo :: Foo () -> IO ()
printFoo (Free (Foo s n)) = print s >> printFoo n
printFoo (Free (Bar i n)) = print i >> printFoo n
printFoo (Pure a) = return a

which gives

*Main> printFoo program 
"Hello"
1
"Bye"

That's fine, but iterM can do the requisite plumbing for you

printFooF :: FooF (IO a) -> IO a
printFooF (Foo s x) = print s >> x
printFooF (Bar i x) = print i >> x

printFooBetter :: Foo () -> IO ()
printFooBetter = iterM printFooF

Then we get

*Main> printFooBetter program
"Hello"
1
"Bye"

OK great, it's the same as before. But printFooF gives us more flexibility to augment the translator along the lines you want

printFooFExtra :: FooF (IO a) -> IO a
printFooFExtra = (print "stuff before IO action" >>)
                 . printFooF
                 . fmap (print "stuff after IO action" >>)

printFooExtra :: Foo () -> IO ()
printFooExtra = iterM printFooFExtra

then we get

*Main> printFooExtra program
"stuff before IO action"
"Hello"
"stuff after IO action"
"stuff before IO action"
1
"stuff after IO action"
"stuff before IO action"
"Bye"
"stuff after IO action"

Thanks Gabriel Gonzalez for popularizing free monads and Edward Kmett for writing the library! :)

Here a very simple solution using the operational package -- the reasonable alternative to free monads.

You can just factor the printFoo function into a part that prints the instruction proper and a part that adds the additional information, the standard treatment for code duplication like this.

{-# LANGUAGE GADTs #-}

import Control.Monad.Operational

data FooI a where
    Foo :: String -> FooI ()
    Bar :: Int    -> FooI ()

type Foo = Program FooI

printFoo :: Foo a -> IO a
printFoo = interpretWithMonad printExtra
    where
    printExtra :: FooI a -> IO a
    printExtra instr = do { a <- execFooI instr; print "extra info"; return a; }

execFooI :: FooI a -> IO a
execFooI (Foo s) = print s
execFooI (Bar i) = print i

Are you looking for something like this?

Your original code would be

{-# LANGUAGE DeriveFunctor #-}

import Control.Monad.Free

data FooF a = Foo String a | Bar Int a deriving (Functor)

type Foo = Free FooF

printFoo :: Show a => Foo a -> IO ()
printFoo (Free (Foo s n)) = print s >> printFoo n
printFoo (Free (Bar i n)) = print i >> printFoo n
printFoo (Pure a)         = print a

You can then define a simple wrapper function, and a recursive annotater that adds the extra info to each layer of Foo (obviously these can be as complicated as you like).

annotate :: Foo a -> Foo a
annotate (Free (Foo s n)) = wrapper (Free (Foo s (annotate n)))
annotate (Free (Bar i n)) = wrapper (Free (Bar i (annotate n)))
annotate (Pure a)         = wrapper (Pure a)

wrapper :: Foo a -> Foo a
wrapper n = Free (Foo "Extra info" n)

Now define some convenience constructors that define your DSL

foo :: String -> a -> Foo a
foo s a = Free (Foo s (Pure a))

bar :: Int -> a -> Foo a
bar i a = Free (Bar i (Pure a))

Which means that you can create Foo a objects just using the monad interface and your DSL

example = do
    i <- return 1
    a <- foo "Created A" i
    b <- bar 123 a
    c <- foo "Created C" b
    return c

Now if you load up GHCI, you can work with either the original example or with the annotated version

>> printFoo example
"Created A"
123
"Created C"
1
>> printFoo (annotate example)
"Extra info"
"Created A"
"Extra info"
123
"Extra info"
"Created C"
"Extra info"
1

If you are willing to slightly modify the original interpreter (by changing how the terminal case is handled)

{-# LANGUAGE DeriveFunctor #-}

import Control.Monad.Free
import Control.Monad.Morph
import Pipes

data FooF a = Foo String a | Bar Int a deriving (Functor)

printFoo :: Free FooF a -> IO a
printFoo (Free (Foo s n)) = print s >> printFoo n
printFoo (Free (Bar i n)) = print i >> printFoo n
printFoo (Pure a)         = return a

...then there's a way to add extra actions without modifying the functor or having to repurpose its constructors, while still being able to reuse the interpreter.

The solution uses the pipes and mmorph packages.

First you have to define a sort of "pre-interpeter" that lifts the free monad into a Producer from pipes. The yield () statements in the producer signify the points at which an extra action is inserted.

pre :: Free FooF a -> Producer () (Free FooF) a
pre (Free (Foo s n)) = lift (Free . Foo s $ return ()) >> yield () >> pre n
pre (Free (Bar i n)) = lift (Free . Bar i $ return ()) >> yield () >> pre n
pre (Pure a)         = lift . Pure $ a

(In a more complex example the yield statements could carry extra information, like log messages.)

Then you write a function that applies the printFoo interpreter underneath the Producer, using hoist from mmorph:

printFooUnder :: Producer () (Free FooF) a -> Producer () IO a
printFooUnder = hoist printFoo

So, we have a function that "interprets" the free monad into IO, but at some points emits () values that we must decide how to handle.

Now we can define an extended interpreter that reuses the old interpreter:

printFooWithReuse :: Show a => Free FooF a -> IO () 
printFooWithReuse foo = do
    finalv <- runEffect $ for (printFooUnder . pre $ foo) 
                              (\_ -> lift (print "extra info"))
    print finalv

After testing it, it seems to work:

printFooWithReuse $ Free (Foo "nah" (Pure 4))
-- > "nah"
-- > "extra info"
-- > 4

If you happen to want to insert the extra actions manually, then your can eschew writing the "pre-interpreter" and work directly in the Producer () (Free FooF) monad.

(This solution could also be achieved by layering a free monad transformer instead of a Producer. But I think using a Producer is a bit easier.)

Both things just traverse the structure and accumulate the result of inductive processing. This calls for generalizing the iteration through catamorphism.

> newtype Fix f = Fix {unFix :: f (Fix f)}
> data N a b x = Z a | S b x deriving (Functor)
> type Nat a b = Fix (N a b)
> let z = Fix . Z
> let s x = Fix . S x
> let x = s "blah" $ s "doo" $ s "duh" $ z 0
> let annotate (Z x) = s "annotate" $ z x;
      annotate (S x y) = s "annotate" $ s x y
> let exec (Z x) = print x; exec (S x y) = print x >> y
> let cata phi = phi . fmap (cata phi) . unFix
>
> cata exec x
"blah"
"doo"
"duh"
0
>
> cata exec $ cata annotate x
"annotate"
"blah"
"annotate"
"doo"
"annotate"
"duh"
"annotate"
0

Now let me explain in more depth what is going on, since there were some requests in the comments, and concerns that it won't be a monad anymore, if I use Fix.

Consider functor G:

G(X) = A + F(G(X))

Here F is a arbitrary functor. Then for any A we can find a fixed point (F and G are clearly polynomial - we are in Hask). Since we map every object A of the category to a object of the category, we are talking about a functor of fixed points, T(A). It turns out that it is a Monad. Since it is a monad for any functor F, T(A) is a Free Monad. (You will see it is obviously a Monad from the code below)

{-# LANGUAGE DeriveFunctor
           , TypeSynonymInstances #-}

newtype Fix f = Fix {unFix :: f (Fix f)} -- the type of Fixed point of a functor
newtype Compo f g x = Compo {unCompo :: f (g x)} -- composition of functors

instance (Functor f, Functor g) => Functor (Compo f g) where -- composition of functors is a functor
  fmap f = Compo . fmap (fmap f) . unCompo

data FreeF a x = Pure a | Free x deriving (Functor) -- it is a bi-functor, really;
                -- this derives functor in x

-- a special case of fmap - the fmap with unwrapping; useful to eliminate pattern matching
ffmap :: (a -> b) -> FreeF b a -> b
ffmap f x = case fmap f x of -- unwrapping, since now distinction between Pure and Free is not important
              Pure a -> a
              Free a -> a

-- Free Monad is a functor of fixed points of functor G(X)
-- G(X) = A + F(G(X))
type Free f a = Fix (Compo (FreeF a) f) -- fixed point of composition F . (FreeF a)


-- unfortunately, when defined as type, (Free f a) cannot be declared
-- as a Monad (Free f) - Haskell wants Free f to be with `a`
-- instance Monad (Free f) where -- this derives a functor in a at the same time;
--                          note that fmap will work in x, and is not meant
--                          to be equal to (m >>= return . f), which is in `a`
--   return a = Fix $ Compo $ Pure a
--   (Fix (Compo (Pure a))) >>= f  = f a
--   (Fix (Compo (Free fx))) >>= f = Fix $ Compo $ Free $ fmap (>>= f) fx

ret :: (Functor f) => a -> Free f a -- yet it is a monad: this is return
ret = Fix . Compo . Pure

-- and this is >>= of the monad
bind :: (Functor f) => Free f a -> (a -> Free f b) -> Free f b
bind (Fix (Compo (Pure a))) f = f a
bind (Fix (Compo (Free fx))) f = Fix $ Compo $ Free $ fmap (`bind` f) fx

-- Free is done

-- here is your functor FooF
data FooF x = Z Int x | S String x deriving (Functor)

type Foo x = Free FooF x

-- catamorphism for an algebra phi "folds" any F(X) (represented by fixed point of F)
-- into X
cata :: (Functor f) => (f x -> x) -> Fix f -> x
cata phi = phi . fmap (cata phi) . unFix

-- helper functions to construct "Foo a"
z :: Int -> Foo a -> Foo a
z x = Fix . Compo . Free . Z x

s :: String -> Foo a -> Foo a
s x = Fix . Compo . Free . S x

tip :: a -> Foo a
tip = ret

program :: Foo (IO ())
program = s "blah" $ s "doo" $ s "duh" $ z 0 $ tip $ return ()

-- This is essentially a catamorphism; I only added a bit of unwrapping
cata' :: (Functor f) => (f a -> a) -> Free f a -> a
cata' phi = ffmap (phi . fmap (cata' phi)) . unCompo . unFix

exec (Z x y) = print x >> y
exec (S x y) = print x >> y

annotate (Z x y) = s "annotated Z" $ z x y
annotate (S x y) = s "met S" $ s x y

main = do
         cata' exec program
         cata' exec $ cata' annotate (program `bind` (ret . ret))
           -- cata' annotate (program >>= return . return)
           -- or rather cata' annotate $ fmap return program

program is Foo (IO ()). fmap in a (remember FreeF is a bi-functor - we need the fmap in a) can turn program into Foo (Foo (IO ())) - now catamorphism for annotate can construct a new Foo (IO ()).

Note that cata' is iter from Control.Monad.Free.

来源：https://stackoverflow.com/questions/20564633/is-it-possible-to-extend-free-monad-interpreters

标签

haskell

free-monad