结合Free类型
我最近一直在教自己关于免费软件包中的Free monad，但是我遇到了一个问题。 我想为不同的图书馆提供不同的免费monad，本质上我想为不同的上下文构建DSL，但我也希望能够将它们结合在一起。 举个例子：
{-# LANGUAGE DeriveFunctor #-}
module TestingFree where
import Control.Monad.Free
data BellsF x
= Ring x
| Chime x
deriving (Functor, Show)
type Bells = Free BellsF
data WhistlesF x
= PeaWhistle x
| SteamWhistle x
deriving (Functor, Show)
type Whistles = Free WhistlesF
ring :: Bells ()
ring = liftF $ Ring ()
chime :: Bells ()
chime = liftF $ Chime ()
peaWhistle :: Whistles ()
peaWhistle = liftF $ PeaWhistle ()
steamWhistle :: Whistles ()
steamWhistle = liftF $ SteamWhistle ()
playBells :: Bells r -> IO r
playBells (Pure r) = return r
playBells (Free (Ring x)) = putStrLn "RingRing!" >> playBells x
playBells (Free (Chime x)) = putStr "Ding-dong!" >> playBells x
playWhistles :: Whistles () -> IO ()
playWhistles (Pure _) = return ()
playWhistles (Free (PeaWhistle x)) = putStrLn "Preeeet!" >> playWhistles x
playWhistles (Free (SteamWhistle x)) = putStrLn "Choo-choo!" >> playWhistles x
现在，我希望能够创建一个类型BellsAndWhistles ，让我二者的功能结合起来Bells和Whistles毫不费力。
由于问题在于组合monads，我首先想到的是查看Control.Monad.Trans.Free模块，以获得快速简单的解决方案。 不幸的是，有稀疏的例子，没有显示我想要做什么。 此外，似乎堆叠两个或更多自由MonadFree不起作用，因为MonadFree具有m -> f的函数依赖关系。 基本上，我希望能够编写如下代码：
newtype BellsAndWhistles m a = BellsAndWhistles
{ unBellsAndWhistles :: ???
} deriving
( Functor
, Monad
-- Whatever else needed
)
noisy :: Monad m => BellsAndWhistles m ()
noisy = do
lift ring
lift peaWhistle
lift chime
lift steamWhistle
play :: BellsAndWhistles IO () -> IO ()
play bellsNwhistles = undefined
但是， Bells和Whistles可以存在于不同的模块中，并且不必知道每个其他实现。 我的想法是，我可以为不同的任务编写独立的模块，每个模块都实现自己的DSL，然后根据需要将它们组合成一个“更大”的DSL。 是否有捷径可寻？
作为奖励，能够利用已经编写的不同play*函数将是非常好的，这样我就可以将它们交换出去。 我希望能够使用一个免费的解释器进行调试，另一个在生产环境中使用，而且能够选择单独调试哪个DSL显然非常有用。
这是一个基于数据类型单点菜单的答案，除非没有类型类。 我建议阅读那篇论文。
诀窍是，而不是写口译Bells和Whistles ，你定义译员的单函子步骤， BellsF和WhistlesF ，就像这样：
playBellsF :: BellsF (IO a) -> IO a
playBellsF (Ring io) = putStrLn "RingRing!" >> io
playBellsF (Chime io) = putStr "Ding-dong!" >> io
playWhistlesF :: WhistelsF (IO a) -> IO a
playWhistlesF (PeaWhistle io) = putStrLn "Preeeet!" >> io
playWhistlesF (SteamWhistle io) = putStrLn "choo-choo!" >> io
如果您选择不合并它们，您可以将它们传递给Control.Monad.Free.iterM以获取您的原始播放功能：
playBells :: Bells a -> IO a
playBells = iterM playBell
playWhistles :: Whistles a -> IO a
playWhistles = iterM playWhistlesF
...但是，因为他们处理单一步骤，他们可以更容易地组合。 你可以像这样定义一个新的组合免费monad：
data BellsAndWhistlesF a = L (BellsF a) | R (WhistlesF a)
然后把它变成一个免费的monad：
type BellsAndWhistles = Free BellsAndWhistlesF
然后你根据两位BellsAndWhistlesF译员为BellsAndWhistlesF写一个口译员：
playBellsAndWhistlesF :: BellsAndWhistlesF (IO a) -> IO a
playBellsAndWhistlesF (L bs) = playBellsF bs
playBellsAndWhistlesF (R ws) = playWhistlesF ws
...然后你通过将它传递给iterM来获得免费monad的解释器：
playBellsAndWhistles :: BellsAndWhistles a -> IO a
playBellsAndWhistles = iterM playBellsAndWhistlesF
所以你的问题的答案是，组合自由单体的诀窍是通过为单独的函子步骤（“代数”）定义中间解释器来保存更多的信息。 这些“代数”比解释者更适合自由单体。
加布里埃尔的回答很有用，但我认为多加注意让这一切发挥作用是值得的，也就是说，两个Functor的总和也是一个Functor ：
-- | Data type to encode the sum of two 'Functor's @f@ and @g@.
data Sum f g a = InL (f a) | InR (g a)
-- | The 'Sum' of two 'Functor's is also a 'Functor'.
instance (Functor f, Functor g) => Functor (Sum f g) where
fmap f (InL fa) = InL (fmap f fa)
fmap f (InR ga) = InR (fmap f ga)
-- | Elimination rule for the 'Sum' type.
elimSum :: (f a -> r) -> (g a -> r) -> Sum f g a -> r
elimSum f _ (InL fa) = f fa
elimSum _ g (InR ga) = g ga
（Edward Kmett的图书馆将此作为Data.Functor.Coproduct 。）
所以如果Functor是Free monads的“指令集”，那么：
elimSum函数是一个基本规则，它允许您从解释器中为f和g elimSum一个Sum fg解释器。 “数据类型点菜”技术就是您在开发这种洞察力时所获得的技术 - 只需手工完成它就非常值得。
这种Functor代数是一个有价值的东西学习。 例如：
data Product f g a = Product (f a) (g a)
-- | The 'Product' of two 'Functor's is also a 'Functor'.
instance (Functor f, Functor g) => Functor (Product f g) where
fmap f (Product fa ga) = Product (fmap f fa) (fmap f ga)
-- | The 'Product' of two 'Applicative's is also an 'Applicative'.
instance (Applicative f, Applicative g) => Applicative (Product f g) where
pure x = Product (pure x) (pure x)
Product ff gf <*> Product fa ga = Product (ff <*> fa) (gf <*> ga)
-- | 'Compose' is to 'Applicative' what monad transformers are to 'Monad'.
-- If your problem domain doesn't need the full power of the 'Monad' class,
-- then applicative composition might be a good alternative on how to combine
-- effects.
data Compose f g a = Compose (f (g a))
-- | The composition of two 'Functor's is also a 'Functor'.
instance (Functor f, Functor g) => Functor (Compose f g) where
fmap f (Compose fga) = Compose (fmap (fmap f) fga)
-- | The composition of two 'Applicative's is also an 'Applicative'.
instance (Applicative f, Applicative g) => Applicative (Compose f g) where
pure = Compose . pure . pure
Compose fgf <*> Compose fga = Compose ((<*>) <$> fgf <*> fga)
Gershom Bazerman的博客文章“Abstract with Applicative s”扩展了关于Applicative的这些观点，非常值得一读。
编辑：我会注意到的最后一件事是，当人们为他们的自由monads设计他们的自定义Functor子时，事实上，他们隐含地使用了这些技巧。 我会从加布里埃尔的“为什么免费单子很重要”中举两个例子：
data Toy b next =
Output b next
| Bell next
| Done
data Interaction next =
Look Direction (Image -> next)
| Fire Direction next
| ReadLine (String -> next)
| WriteLine String (Bool -> next)
所有这些都可以分析成Product ， Sum ， Compose ， (->)函数和以下三个函数的组合：
-- | Provided by "Control.Applicative"
newtype Const b a = Const b
instance Functor (Const b) where
fmap _ (Const b) = Const b
-- | Provided by "Data.Functor.Identity"
newtype Identity a = Identity a
instance Functor Identity where
fmap f (Identity a) = Identity (f a)
-- | Near-isomorphic to @Const ()@
data VoidF a = VoidF
instance Functor VoidF where
fmap _ VoidF = VoidF
因此，为简洁起见，使用以下类型的同义词：
{-# LANGUAGE TypeOperators #-}
type f :+: g = Sum f g
type f :*: g = Product f g
type f :.: g = Compose f g
infixr 6 :+:
infixr 7 :*:
infixr 9 :.:
...我们可以重写这些函子：
type Toy b = Const b :*: Identity :+: Identity :+: VoidF
type Interaction = Const Direction :*: ((->) Image :.: Identity)
:+: Const Direction :*: Identity
:+: (->) String :.: Identity
:+: Const String :*: ((->) Bool :.: Identity)
上一篇: Combining Free types