如何使用递归方案来“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 但仍然是自递归而不是相互递归？

我认为这个问题可能与Recursion schemes with several types 有关，但我不明白那里的答案：Cofree 对我来说到目前为止很神秘，我不知道它是问题的本质还是只是一个问题使用的部分表示；并且该问题中的类型不是完全相互递归的，所以我不知道如何将那里的解决方案应用于我的类型。

Answer 1

One answer to the linked question 提到添加一个额外的类型参数，因此我们使用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

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