如何使用递归-方案`猫‘两种相互递归类型？

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的定义有点笨拙:每个数据构造函数都需要分别处理标签。对于像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'

太好了，现在我们的节点类型代表了一棵没有标签的树的结构，而树‘和标签合谋用标签来装饰它。但是我不再知道如何在这些类型中使用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期望一个类型的模式匹配，当然它不能合成一个是我的两种类型的组合。

那么这里的计划是什么？如果我定义了我自己的函子实例，这里是否有一些cata的适应性？还是一种更好的方法来定义这种类型，以避免重复处理标签，但仍然是自递归，而不是相互递归？

我认为这个问题可能与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

但是这不能编译，因为递归和共递归实例只有在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

dfeuer在注释中解释说，recursion-schemes已经有了一种功能，可以说“请像通常那样生成基本函子，但是在生成的类实例中包含这个约束”。所以，你可以写

makeBaseFunctor [d| instance Functor f => Recursive (Tree f a) |]

通过手工编辑剪接来生成与我上面生成的实例相同的实例。