20

给定一个免费的 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

这是否可以通过“包装”原件来实现printFoo？

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

4

5 回答 5

14

其他答案错过了它的简单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 编写库！:)

于 2013-12-13T20:33:46.180 回答
5

这是一个使用包的非常简单的解决方案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
于 2013-12-14T10:24:01.680 回答
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))

这意味着您可以Foo a仅使用 monad 接口和 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
于 2013-12-13T11:46:41.027 回答
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包。

首先，您必须定义一种“preinterpeter”，将 free monad 提升为Producerfrom 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应用解释器，使用from ：Producerhoistmmorph

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)monad 中工作。

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

于 2013-12-13T15:58:48.333 回答
1

两者都只是遍历结构，积累归纳处理的结果。这需要通过变态泛化迭代。

> 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 的单子，所以 T(A) 是一个自由单子。（你会从下面的代码中看到它显然是一个 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 ())。fmapin a（记住 FreeF 是一个双函子 - 我们需要 fmap in a）可以program变成Foo (Foo (IO ()))- 现在 annotate 的变态可以构造一个新的Foo (IO ()).

请注意cata'，iter来自Control.Monad.Free.

于 2013-12-13T14:49:17.697 回答