如何使用递归方案来`cata`两种相互递归类型？

Question

对于带有标记节点的叶值树，我从这种类型开始：

type Label = String
data Tree a = Leaf Label a 
            | Branch Label [Tree a]

我有一些折叠我想写在这棵树上，它们都采用变形的形式，所以让我们recursion-schemes为我做递归遍历：

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, TemplateHaskell, TypeFamilies #-}
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Data.Functor.Foldable (cata)

type Label = String
data Tree a = Leaf Label a 
            | Branch Label [Tree a]
makeBaseFunctor ''Tree

allLabels :: Tree a -> [Label]
allLabels = cata go
  where go (LeafF l _) = [l]
        go (BranchF l lss) = l : concat lss

一切顺利：我们可以遍历一棵树：

λ> allLabels (Branch "root" [(Leaf "a" 1), Branch "b" [Leaf "inner" 2]])
["root","a","b","inner"]

但是 Tree 的定义有点笨拙：每个数据构造函数都需要单独处理 Label。对于像 Tree 这样的小型结构，这还不算太糟糕，但是对于更多的构造函数，这将是一件很麻烦的事情。因此，让我们将标签设为自己的图层：

data Node' a = Leaf' a
             | Branch' [Tree' a]
data Labeled a = Labeled Label a
newtype Tree' a = Tree' (Labeled (Node' a))
makeBaseFunctor ''Tree'
makeBaseFunctor ''Node'

太好了，现在我们的 Node 类型表示没有标签的树的结构，并且 Tree' 和 Labeled 合谋用标签装饰它。但是我不再知道如何将 cata 与这些类型一起使用，即使它们与原始 Tree 类型同构。 makeBaseFunctor 没有看到任何递归，所以它只定义了与原始类型相同的基本仿函数：

$ stack build --ghc-options -ddump-splices
...
newtype Tree'F a r = Tree'F (Labeled (Node' a))
...
data Node'F a r = Leaf'F a | Branch'F [Tree' a]

这很公平，我也不知道我希望它生成什么：cata 期望单一类型进行模式匹配，当然它不能合成一个这是我的两种类型的组合。

那么这里的计划是什么？如果我定义自己的 Functor 实例，是否有一些对 cata 的改编在这里起作用？或者更好的方法来定义这种类型，避免重复处理 Label 但仍然是自递归而不是相互递归？

我认为这个问题可能与有关，但我不明白那里的答案：Cofree对我来说太神秘了，我不知道它是否必要问题或只是所用表示的一部分；并且该问题中的类型不是完全相互递归的，所以我不知道如何将那里的解决方案应用于我的类型。

Answer 1

提到添加一个额外的类型参数，因此我们使用 Tree Labeled a:

而不是 Tree (Labeled a)

type Label = String
data Labeled a = Labeled Label a deriving Functor
data Tree f a = Leaf (f a)
              | Branch (f [Tree f a])

这样，单一类型 (Tree) 负责递归，因此 makeBaseFunctor 应该识别递归并将其抽象为函子。它确实这样做了，但它生成的实例并不完全正确。再次查看 -ddump-splices，我看到 makeBaseFunctor ''Tree 产生：

data TreeF f a r = LeafF (f a) | BranchF (f [r]) deriving (Functor, Foldable, Traversable)
type instance Base (Tree f a) = TreeF f a
instance Recursive (Tree f a) where
  project (Leaf x) = LeafF x
  project (Branch x) = BranchF x
instance Corecursive (Tree f a) where
  embed (LeafF x) = Leaf x
  embed (BranchF x) = Branch x

但这不会编译，因为 Recursive 和 Corecursive 实例仅在 f 是仿函数时才是正确的。递归方案似乎确实有某种可插拔机制，可以以不同的方式获取实例，但我不明白。但是，我可以直接将拼接复制到我的文件中并自己添加约束：

data TreeF f a r = LeafF (f a) | BranchF (f [r]) deriving (Functor, Foldable, Traversable)
type instance Base (Tree f a) = TreeF f a
instance Functor f => Recursive (Tree f a) where
  project (Leaf x) = LeafF x
  project (Branch x) = BranchF x
instance Functor f => Corecursive (Tree f a) where
  embed (LeafF x) = Leaf x
  embed (BranchF x) = Branch x

之后我可以使用与问题中的原始版本非常相似的方式使用 cata：

allLabels :: Tree Labeled a -> [Label]
allLabels = cata go
  where go (LeafF (Labeled l _)) = [l]
        go (BranchF (Labeled l lss)) = l : concat lss

我仍然欢迎一个答案，解释如何完成类似的事情，而不必将一堆拼接的废话手动复制到我的源文件中。

如何使用递归方案来`cata`两种相互递归类型？

How to use recursion-schemes to `cata` two mutually-recursive types?

haskell

recursion-schemes