haskell - 结合自由类型

Question

我最近一直在自学免费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将两者的功能结合起来。BellsWhistles

由于问题在于组合 monad，我的第一个想法是查看Control.Monad.Trans.Free模块以获得快速简便的解决方案。不幸的是，有很少的例子，没有一个显示我想要做什么。此外，似乎堆叠两个或多个免费 monad 不起作用，因为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 显然很有用。

Answer 1

这是基于论文Data types à la carte的答案，除了没有类型类。我建议阅读那篇论文。

Bells诀窍是，您无需为and编写解释器，而是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

...但是，由于它们处理单个步骤，因此可以更轻松地组合它们。你可以像这样定义一个新的组合自由单子：

data BellsAndWhistlesF a = L (BellsF a) | R (WhistlesF a)

然后把它变成一个免费的单子：

type BellsAndWhistles = Free BellsAndWhistlesF

BellsAndWhistlesF然后你根据两个子解释器为一个步骤编写一个解释器：

playBellsAndWhistlesF :: BellsAndWhistlesF (IO a) -> IO a
playBellsAndWhistlesF (L bs) = playBellsF    bs
playBellsAndWhistlesF (R ws) = playWhistlesF ws

...然后您只需将其传递给即可获得免费 monad 的解释器iterM：

playBellsAndWhistles :: BellsAndWhistles a -> IO a
playBellsAndWhistles = iterM playBellsAndWhistlesF

因此，您的问题的答案是，组合自由单子的诀窍是通过为各个函子步骤（“代数”）定义中间解释器来保留更多信息。这些“代数”比自由单子的解释器更容易组合。

Answer 2

加布里埃尔的回答是正确的，但我认为有必要多强调一下使一切正常的事情，即两个 s 的总和Functor也是 aFunctor：

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

因此，如果Functors 是Freemonad 的“指令集”，那么：

1. Sum函子为您提供此类指令集的并集，从而为您提供相应的组合自由单子
2. 该elimSum函数是允许您从一个 for和一个 for的解释器中构建一个Sum f g解释器的基本规则。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 的博客文章“用s抽象Applicative”扩展了关于Applicatives 的这些观点，非常值得一读。

---

编辑：我要注意的最后一件事是，当人们Functor为他们的自由单子设计他们的 custom 时，事实上，他们隐含地使用了这些技术。我将从 Gabriel 的“Why free monads matter”中举两个例子：

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)