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

Question

I started with this type for leaf-valued trees with labeled nodes:

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

I have some folds I'd like to write over this tree, and they all take the form of catamorphisms, so let's let recursion-schemes do the recursive traversal for me:

{-# 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

And all is well: we can traverse a tree:

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

But that definition of Tree is a little clunky: each data constructor needs to handle the Label separately. For a small structure like Tree this isn't too bad, but with more constructors it would be quite a nuisance. So let's make the labeling its own layer:

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'

Great, now our Node type represents the structure of a tree without labels, and Tree' and Labeled conspire to decorate it with labels. But I no longer know how to use cata with these types, even though they are isomorphic to the original Tree type. makeBaseFunctor doesn't see any recursion, so it just defines base functors that are identical to the original types:

$ 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]

Which like, fair enough, I don't know what I'd want it to generate either: cata expects a single type to pattern-match on, and of course it can't synthesize one that's a combination of two of my types.

So what's the plan here? Is there some adaptation of cata that works here if I define my own Functor instances? Or a better way to define this type that avoids duplicate handling of Label but still is self-recursive instead of mutually recursive?

I think this question is probably related to Recursion schemes with several types, but I don't understand the answer there: Cofree is so far mysterious to me, and I can't tell whether it's essential to the problem or just a part of the representation used; and the types in that question are not quite mutally-recursive, so I don't know how to apply the solution there to my types.

Frontpage

Answer 1

One answer to the linked question mentions adding an extra type parameter, so that instead of Tree (Labeled a) we use 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])

This way, a single type (Tree) is responsible for the recursion, and so makeBaseFunctor should recognize the recursion and abstract it over a functor. And it does do that, but the instances it generates aren't quite right. Looking at -ddump-splices again, I see that makeBaseFunctor ''Tree produces:

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

but this doesn't compile, because the Recursive and Corecursive instances are only correct when f is a functor. In the worst case, I can copy the splices into my file directly and add the constraint myself:

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

After which I can use cata in a way very similar to the original version in my question:

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

However, dfeuer explains in a (now-deleted) comment that recursion-schemes has a facility already for saying "please generate the base functor as you normally would, but include this constraint in the generated class instances". So, you can write

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

to generate the same instances that I produced above by hand-editing the splices.

Frontpage