是否有可能扩展免费的monad口译员？

Question

给出免费的monad DSL，例如：

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

type Foo = Free FooF

Foo的随机翻译：

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

在我看来，应该可以在printFoo的每次迭代中散布一些内容，而无需手动操作：

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

通过＆＃39;包装＆＃39;这是否可行？原printFoo？

---

动机：我正在编写一个小型DSL，用于编译＆＃39;到二进制格式。二进制格式在每个用户命令后包含一些额外信息。它必须在那里，但在我的用例中完全无关紧要。

Answer 1

其他答案错过了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"

感谢Gabriel Gonzalez推广免费monad和Edward Kmett 写图书馆！ ：）

Answer 2

这是一个使用operational包的非常简单的解决方案 - 免费monad的合理替代方案。

您可以将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

Answer 3

你在找这样的东西吗？

您的原始代码将是

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

这意味着您只需使用monad接口和DSL

即可创建Foo a个对象

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

Answer 4

这两件事只是遍历结构并积累归纳处理的结果。这要求通过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

---

现在让我更深入地解释发生了什么，因为评论中有一些请求，并且担心如果我使用Fix，它将不再是monad。

考虑仿函数G：

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

这里F是一个任意的函子。然后对于任何A，我们可以找到一个固定点（F和G显然是多项式的 - 我们在Hask中）。由于我们将类别的每个对象A映射到该类别的对象，因此我们讨论的是固定点的仿函数T（A）。事实证明它是一个Monad。由于它是任何仿函数F的monad，因此T（A）是免费Monad。 （你会看到它显然是下面代码中的Monad）

{-# 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是一个双向仿函数 - 我们需要a中的fmap）可以将program转换为Foo (Foo (IO ())) - 现在注释可以使用catamorphism构建一个新的Foo (IO ())。

请注意，cata' iter为Control.Monad.Free。

Answer 5

如果您愿意稍微修改原始解释器（通过更改终端案例的处理方式）

{-# 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个包。

首先，你必须定义一种“pre-interpeter”，将免费monad从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解释器应用于<{em> mmorph下方的函数：

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

因此，我们有一个功能可以将免费monad“解释”为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) monad中工作。

（这个解决方案也可以通过分层一个免费的monad变换器而不是Producer来实现。但我认为使用Producer会更容易一些。）