Once I have an F-Algebra, can I define Foldable and Traversable in terms of it?

Question

I have defined an F-Algebra, as per Bartosz Milewski's articles (one, two):

(This is not to say my code is an exact embodiment of Bartosz's ideas, it's merely my limited understanding of them, and any faults are mine alone.)

module Algebra where

data Expr a = Branch [a] | Leaf Int

instance Functor Expr where
    fmap f (Branch xs) = Branch (fmap f xs)
    fmap _ (Leaf   i ) = Leaf    i

newtype Fix a = Fix { unFix :: a (Fix a) }

branch = Fix . Branch
leaf   = Fix . Leaf

-- | This is an example algebra.
evalSum (Branch xs) = sum xs
evalSum (Leaf   i ) =     i

cata f = f . fmap (cata f) . unFix

I can now do pretty much anything I want about it, for example, sum the leaves:

λ cata evalSum $ branch [branch [leaf 1, leaf 2], leaf 3]
6

This is a contrived example that I made up specifically for this question, but I actually tried some less trivial things (such as evaluating and simplifying polynomials with any number of variables) and it works like a charm. One may indeed fold and replace any parts of a structure as one runs a catamorphism through, with a suitably chosen algebra. So, I am pretty sure an F-Algebra subsumes a Foldable, and it even appears to subsume Traversable as well.

Now, can I define Foldable / Traversable instances in terms of an F-Algebra?

It seems to me that I cannot.

• I can only run a catamorphism on an initial algebra, which is a nullary type constructor. And the algebra I give it has a type a b -> b rather than a -> b, that is to say, there is a functional dependency between the "in" and "out" type.
• I don't see an Algebra a => Foldable a anywhere in type signatures. If this is not done, it must be impossible.

It seems to me that I cannot define Foldable in terms of an F-Algebra for the reason that an Expr must for that be a Functor in two variables: one for carrier, another for values, and then a Foldable in the second. So, it may be that a bifunctor is more suitable. And we can construct an F-Algebra with a bifunctor as well:

module Algebra2 where

import Data.Bifunctor

data Expr a i = Branch [a] | Leaf i

instance Bifunctor Expr where
    bimap f _ (Branch xs) = Branch (fmap f xs)
    bimap _ g (Leaf   i ) = Leaf   (g i)

newtype Fix2 a i = Fix2 { unFix2 :: a (Fix2 a i) i }

branch = Fix2 . Branch
leaf   = Fix2 . Leaf

evalSum (Branch xs) = sum xs
evalSum (Leaf   i ) =     i

cata2 f g = f . bimap (cata2 f g) g . unFix2

It runs like this:

λ cata2 evalSum (+1) $ branch [branch [leaf 1, leaf 2], leaf 3]
9

But I still can't define a Foldable. It would have type like this:

instance Foldable \i -> Expr (Fix2 Expr i) i where ...

Unfortunately, one doesn't get lambda abstractions on types, and there's no way to put an implied type variable in two places at once.

I don't know what to do.

Answer 1

An F-algebra defines a recipe for evaluating a single level of a recursive data structure, after you have evaluated all the children. Foldable defines a way of evaluating a (not necessarily recursive) data structure, provided you know how to convert values stored in it to elements of a monoid.

To implement foldMap for a recursive data structure, you may start by defining an algebra, whose carrier is a monoid. You would define how to convert a leaf to a monoidal value. Then, assuming that all children of a node were evaluated to monoidal values, you'd define a way to combine them within a node. Once you've defined such an algebra, you can run a catamorphism to evaluate foldMap for the whole tree.

So the answer to your question is that to make a Foldable instance for a fixed-point data structure, you have to define an appropriate algebra whose carrier is a monoid.

Edit: Here's an implementation of Foldable:

data Expr e a = Branch [a] | Leaf e

newtype Ex e = Ex { unEx :: Fix (Expr e) }

evalM :: Monoid m => (e -> m) -> Algebra (Expr e) m
evalM _ (Branch xs) = mconcat xs
evalM f (Leaf   i ) = f i

instance Foldable (Ex) where
  foldMap f = cata (evalM f) . unEx

tree :: Ex Int
tree = Ex $ branch [branch [leaf 1, leaf 2], leaf 3]

x = foldMap Sum tree

Implementing Traversable as a catamorphism is a little more involved because you want the result to be not just a summary--it must contain the complete reconstructed data structure. The carrier of the algebra must therefore be the type of the final result of traverse, which is (f (Fix (Expr b))), where f is Applicative.

tAlg :: Applicative f => (e -> f b) -> Algebra (Expr e) (f (Fix (Expr b)))

Here's this algebra:

tAlg g (Leaf e)    = leaf   <$> g e
tAlg _ (Branch xs) = branch <$> sequenceA xs

And this is how you implement traverse:

instance Traversable Ex where
  traverse g = fmap Ex . cata (tAlg g) . unEx

The superclass of Traversable is a Functor, so you need to show that the fixed-point data structure is a functor. You can do it by implementing a simple algebra and running a catamorphism over it:

fAlg :: (a -> b) -> Algebra (Expr a) (Fix (Expr b))
fAlg g (Leaf e) = leaf (g e)
fAlg _ (Branch es) = branch es

instance Functor Ex where
  fmap g = Ex . cata (fAlg g) . unEx

(Michael Sloan helped me write this code.)

Answer 2

It's very nice, that you used Bifunctor. Using Bifunctor of a base functor (Expr) to define Functor on a fixpoint (Fix Expr). That approach generalises to Bifoldable and Bitraversable (they are in base now) too.

Let's see how this would like using recursion-schemes. It looks a bit different, as there we define normal recursive type, say Tree e, and also its base functor: Base (Tree e) = TreeF e a with two functions: project :: Tree e -> TreeF e (Tree e) and embed :: TreeF e (Tree e) -> Tree e. The recursion machinery is derivable using TemplateHaskell:

Note that we have Base (Fix f) = f (project = unFix, embed = Fix), therefore we can use refix convert Tree e to Fix (TreeF e) and back. But we don't need to use Fix, as we able to cata Tree directly!

First includes:

{-# LANGUAGE TemplateHaskell, KindSignatures, TypeFamilies, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
import Data.Functor.Foldable
import Data.Functor.Foldable.TH

import Data.Bifunctor
import Data.Bifoldable
import Data.Bitraversable

Then the data:

data Tree e = Branch [Tree e] | Leaf e deriving Show

-- data TreeF e r = BranchF [r] | LeafF e
-- instance Traversable (TreeF e)
-- instance Foldable (TreeF e)
-- instance Functor (TreeF e)
makeBaseFunctor ''Tree

Now as we have machinery in place, we can have catamorphisms

cata :: Recursive t => (Base t a -> a) -> t -> a
cata f = c where c = f . fmap c . project

or (which we will need later)

cataBi :: (Recursive t, Bifunctor p, Base t ~ p x) => (p x a -> a) -> t -> a
cataBi f = c where c = f . second c . project

First a Functor instance. The Bifunctor instance for TreeF is as OP has written, note how Functor falls out by itself.

instance Bifunctor TreeF where
    bimap f _ (LeafF e)    = LeafF (f e)
    bimap _ g (BranchF xs) = BranchF (fmap g xs)

instance Functor Tree where
    fmap f = cata (embed . bimap f id)

Not surprisingly, Foldable for fixpoint can be defined in terms of Bifoldable of base functor:

instance Bifoldable TreeF where
    bifoldMap f _ (LeafF e)    = f e
    bifoldMap _ g (BranchF xs) = foldMap g xs

instance Foldable Tree where
    foldMap f = cata (bifoldMap f id)

And finally Traversable:

instance Bitraversable TreeF where
    bitraverse f _ (LeafF e)    = LeafF <$> f e
    bitraverse _ g (BranchF xs) = BranchF <$> traverse g xs

instance Traversable Tree where
    traverse f = cata (fmap embed . bitraverse f id)

As you can see the definitions are very straight forward and follow similarish pattern.

Indeed we can define traverse-like function for every fix-point which base functor is Bitraversable.

traverseRec
    :: ( Recursive t, Corecursive s, Applicative f
       , Base t ~ base a, Base s ~ base b, Bitraversable base)
    => (a -> f b) -> t -> f s
traverseRec f = cataBi (fmap embed . bitraverse f id)

Here we use cataBi to make type-signature prettier: no Functor (base b) as it's "implied" by Bitraversable base. Btw, that's a one nice function as its type signature is three times longer than the implementation).

To conclude, I must mention that Fix in Haskell is not perfect: We use the last argument to fix base-functor:

Fix :: (* -> *) -> * -- example: Tree e ~ Fix (TreeF e)

Thus Bartosz needs to define Ex in his answer to make kinds align, however it would be nicer to fix on the first argument:

Fix :: (* -> k) -> k -- example: Tree e = Fix TreeF' e

where data TreeF' a e = LeafF' e | BranchF' [a], i.e. TreeF with indexes flipped. That way we could have Functor (Fix b) in terms of Bifunctor f, Bifunctor (Fix b) in terms of (non-existing in common libraries) Trifunctor etc.

You can read about my failed attempts about that and Edward Kmett's comments on the issue in https://github.com/ekmett/recursion-schemes/pull/23