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

Question

我从这种带有标记节点的叶值树开始：

\n

type Label = String\ndata Tree a = Leaf Label a \n            | Branch Label [Tree a]\n

\n

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

\n

{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, TemplateHaskell, TypeFamilies #-}\nimport Data.Functor.Foldable.TH (makeBaseFunctor)\nimport Data.Functor.Foldable (cata)\n\ntype Label = String\ndata Tree a = Leaf Label a \n            | Branch Label [Tree a]\nmakeBaseFunctor \'\'Tree\n\nallLabels :: Tree a -> [Label]\nallLabels = cata go\n  where go (LeafF l _) = [l]\n        go (BranchF l lss) = l : concat lss\n

\n

一切都很好：我们可以遍历一棵树：

\n

\xce\xbb> allLabels (Branch "root" [(Leaf "a" 1), Branch "b" [Leaf "inner" 2]])\n["root","a","b","inner"]\n

\n

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

\n

data Node\' a = Leaf\' a\n             | Branch\' [Tree\' a]\ndata Labeled a = Labeled Label a\nnewtype Tree\' a = Tree\' (Labeled (Node\' a))\nmakeBaseFunctor \'\'Tree\'\nmakeBaseFunctor \'\'Node\'\n

\n

太好了，现在我们的 Node 类型代表了没有标签的树的结构，而 Tree\' 和 Labeled 共同用标签来装饰它。但我不再知道如何使用cata这些类型，即使它们与原始Tree类型同构。makeBaseFunctor没有看到任何递归，因此它只定义与原始类型相同的基本函子：

\n

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

\n

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

\n

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

\n

我认为这个问题可能与几种类型的递归方案有关，但我不明白那里的答案：到目前为止Cofree对我来说很神秘，我无法判断它是否对问题至关重要或只是使用的表示的一部分；并且该问题中的类型并不是完全相互递归的，所以我不知道如何将那里的解决方案应用于我的类型。

\n

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

然而，dfeuer 在一条（现已删除）评论中解释说，该recursion-schemes评论已经有一个工具可以说“请像平常一样生成基本函子，但在生成的类实例中包含此约束”。所以，你可以写

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

生成与我上面通过手动编辑拼接生成的相同实例。