Можно ли расширить бесплатные интерпретаторы монад?

Другие ответы упустили из виду, насколько это простоfree! :) В настоящее время у вас есть

{-# 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

который дает

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

Это нормально, но iterM может сделать за вас необходимую сантехнику

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

Тогда мы получим

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

Хорошо, отлично, все как раньше. Но printFooF дает нам больше гибкости, чтобы расширять переводчик в соответствии с вашими пожеланиями.

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

тогда мы получаем

*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"

Спасибо Габриэлю Гонсалесу за популяризацию бесплатных монад и Эдварду Кметту за написание библиотеки! :)

Вот очень простое решение с использованием пакета operational - разумной альтернативы бесплатным монадам.

Вы можете просто разложить функцию printFoo на часть, которая печатает собственно инструкцию, и часть, которая добавляет дополнительную информацию, стандартное лечение для подобного дублирования кода.

{-# 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

Вы ищете что-то подобное?

Ваш исходный код будет

{-# 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

Затем вы можете определить простую функцию-оболочку и рекурсивный аннотатор, который добавляет дополнительную информацию на каждый уровень Foo (очевидно, они могут быть сколь угодно сложными).

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)

Теперь определите несколько удобных конструкторов, которые определяют ваш 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))

Это означает, что вы можете создавать Foo a объектов, просто используя интерфейс монады и свой DSL.

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

Теперь, если вы загрузите GHCI, вы можете работать либо с исходной example, либо с аннотированной версией.

>> 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

Если вы хотите немного изменить исходный интерпретатор (изменив способ обработки терминального случая)

{-# 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

... тогда есть способ добавить дополнительные действия без изменения функтора или необходимости перепрофилировать его конструкторы, сохраняя при этом возможность повторно использовать интерпретатор.

В решении используются пакеты pipes и mmorph.

Сначала вы должны определить своего рода «предварительный интерпретатор», который поднимает свободную монаду в Producer из pipes. Операторы yield () в производителе обозначают точки, в которые вставляется дополнительное действие.

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 

(В более сложном примере операторы yield могут содержать дополнительную информацию, например сообщения журнала.)

Затем вы пишете функцию, которая применяет интерпретатор printFoo под Producer, используя hoist из mmorph:

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

Итак, у нас есть функция, которая «интерпретирует» свободную монаду в IO, но в некоторых моментах выдает () значений, которые мы должны решить, как обрабатывать.

Теперь мы можем определить расширенный интерпретатор, который повторно использует старый интерпретатор:

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

После тестирования вроде работает:

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

Если вы хотите вставить дополнительные действия вручную, вы можете отказаться от написания «предварительного интерпретатора» и работать непосредственно в монаде Producer () (Free FooF).

(Это решение также может быть достигнуто путем наслоения бесплатного преобразователя монад вместо Producer. Но я думаю, что использовать Producer немного проще.)

Обе вещи просто проходят через структуру и накапливают результат индуктивной обработки. Это требует обобщения итерации через катаморфизм.

> 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

Теперь позвольте мне более подробно объяснить, что происходит, поскольку в комментариях были некоторые запросы и опасения, что это больше не будет монадой, если я буду использовать Fix.

Рассмотрим функтор G:

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

Здесь F - произвольный функтор. Тогда для любого A мы можем найти неподвижную точку (F и G явно полиномиальны - мы находимся в Hask). Поскольку мы сопоставляем каждый объект A категории с объектом категории, мы говорим о функторе неподвижных точек T (A). Оказывается, это монада. Поскольку это монада для любого функтора F, T (A) - свободная монада. (Вы увидите, что это, очевидно, монада из приведенного ниже кода)

{-# 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 равно Foo (IO ()). fmap в a (помните, что FreeF - это бифунктор - нам нужен fmap в a) может превратить program в Foo (Foo (IO ())) - теперь катаморфизм для аннотации может создавать новый Foo (IO ()).

Обратите внимание, что cata' - это iter из Control.Monad.Free.