How do I give a Functor instance to a datatype built for general recursion schemes?

Question

I have a recursive datatype which has a Functor instance:

data Expr1 a
  = Val1 a
  | Add1 (Expr1 a) (Expr1 a)
  deriving (Eq, Show, Functor)

Now, I'm interested in modifying this datatype to support general recursion schemes, as they are described in this tutorial and this Hackage package. I managed to get the catamorphism to work:

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

data ExprF a r
  = Val a
  | Add r r
  deriving (Eq, Show, Functor)

type Expr2 a = Fix (ExprF a)

cata :: Functor f => (f a -> a) -> Fix f -> a
cata f = f . fmap (cata f) . unFix

eval :: Expr2 Int -> Int
eval = cata $ \case
  Val n -> n
  Add x y -> x + y

main :: IO ()
main =
  print $ eval
    (Fix (Add (Fix (Val 1)) (Fix (Val 2))))

But now I can't figure out how to give Expr2 the same functor instance that the original Expr had. It seems there is a kind mismatch when trying to define the functor instance:

instance Functor (Fix (ExprF a)) where
    fmap = undefined

Kind mis-match
    The first argument of `Functor' should have kind `* -> *',
    but `Fix (ExprF a)' has kind `*'
    In the instance declaration for `Functor (Fix (ExprF a))'

How do I write a Functor instance for Expr2?

I thought about wrapping Expr2 in a newtype with newtype Expr2 a = Expr2 (Fix (ExprF a)) but then this newtype needs to be unwrapped to be passed to cata, which I don't like very much. I also don't know if it would be possible to automatically derive the Expr2 functor instance like I did with Expr1.

Answer 1

This is an old sore for me. The crucial point is that your ExprF is functorial in both its parameters. So if we had

class Bifunctor b where
  bimap :: (x1 -> y1) -> (x2 -> y2) -> b x1 x2 -> b y1 y2

then you could define (or imagine a machine defining for you)

instance Bifunctor ExprF where
  bimap k1 k2 (Val a)    = Val (k1 a)
  bimap k1 k2 (Add x y)  = Add (k2 x) (k2 y)

and now you can have

newtype Fix2 b a = MkFix2 (b a (Fix2 b a))

accompanied by

map1cata2 :: Bifunctor b => (a -> a') -> (b a' t -> t) -> Fix2 b a -> t
map1cata2 e f (MkFix2 bar) = f (bimap e (map1cata2 e f) bar)

which in turn gives you that when you take a fixpoint in one of the parameters, what's left is still functorial in the other

instance Bifunctor b => Functor (Fix2 b) where
  fmap k = map1cata2 k MkFix2

and you sort of get what you wanted. But your Bifunctor instance isn't going to be built by magic. And it's a bit annoying that you need a different fixpoint operator and a whole new kind of functor. The trouble is that you now have two sorts of substructure: "values" and "subexpressions".

And here's the turn. There is a notion of functor which is closed under fixpoints. Turn on the kitchen sink (especially DataKinds) and

type s :-> t = forall x. s x -> t x

class FunctorIx (f :: (i -> *) -> (o -> *)) where
  mapIx :: (s :-> t) -> f s :-> f t

Note that "elements" come in a kind indexed over i and "structures" in a kind indexed over some other o. We take i-preserving functions on elements to o preserving functions on structures. Crucially, i and o can be different.

The magic words are "1, 2, 4, 8, time to exponentiate!". A type of kind * can easily be turned into a trivially indexed GADT of kind () -> *. And two types can be rolled together to make a GADT of kind Either () () -> *. That means we can roll both sorts of substructure together. In general, we have a kind of type level either.

data Case :: (a -> *) -> (b -> *) -> Either a b -> * where
  CL :: f a -> Case f g (Left a)
  CR :: g b -> Case f g (Right b)

equipped with its notion of "map"

mapCase :: (f :-> f') -> (g :-> g') -> Case f g :-> Case f' g'
mapCase ff gg (CL fx) = CL (ff fx)
mapCase ff gg (CR gx) = CR (gg gx)

So we can refunctor our bifactors as Either-indexed FunctorIx instances.

And now we can take the fixpoint of any node structure f which has places for either elements p or subnodes. It's just the same deal we had above.

newtype FixIx (f :: (Either i o -> *) -> (o -> *))
              (p :: i -> *)
              (b :: o)
  = MkFixIx (f (Case p (FixIx f p)) b)

mapCata :: forall f p q t. FunctorIx f =>
  (p :-> q) -> (f (Case q t) :-> t) -> FixIx f p :-> t
mapCata e f (MkFixIx node) = f (mapIx (mapCase e (mapCata e f)) node)

But now, we get the fact that FunctorIx is closed under FixIx.

instance FunctorIx f => FunctorIx (FixIx f) where
  mapIx f = mapCata f MkFixIx

Functors on indexed sets (with the extra freedom to vary the index) can be very precise and very powerful. They enjoy many more convenient closure properties than Functors do. I don't suppose they'll catch on.

Answer 2

I wonder if you might be better off using the Free type:

data Free f a
  = Pure a
  | Wrap (f (Free f a))
deriving Functor

data ExprF r
  = Add r r
deriving Functor

This has the added benefit that there are quite a few libraries that work on free monads already, so maybe they'll save you some work.

Answer 3

Nothing wrong with pigworker's answer, but maybe you can use a simpler one as a stepping-stone:

{-# LANGUAGE DeriveFunctor, ScopedTypeVariables #-}

import Prelude hiding (map)

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

-- This is the catamorphism function you hopefully know and love
-- already.  Generalizes 'foldr'.
cata :: Functor f => (f r -> r) -> Fix f -> r
cata phi = phi . fmap (cata phi) . unFix

-- The 'Bifunctor' class.  You can find this in Hackage, so if you
-- want to use this just use it from there.
--
-- Minimal definition: either 'bimap' or both 'first' and 'second'.
class Bifunctor f where
    bimap :: (a -> c) -> (b -> d) -> f a b -> f c d
    bimap f g = first f . second g

    first :: (a -> c) -> f a b -> f c b
    first f = bimap f id

    second :: (b -> d) -> f a b -> f a d
    second g = bimap id g

-- The generic map function.  I wrote this out with
-- ScopedTypeVariables to make it easier to read...
map :: forall f a b. (Functor (f a), Bifunctor f) => 
       (a -> b) -> Fix (f a) -> Fix (f b)
map f = cata phi 
    where phi :: f a (Fix (f b)) -> Fix (f b)
          phi = Fix . first f

Now your expression language works like this:

-- This is the base (bi)functor for your expression type.
data ExprF a r = Val a 
               | Add r r
               deriving (Eq, Show, Functor)

instance Bifunctor ExprF where
    bimap f g (Val a) = Val (f a)
    bimap f g (Add l r) = Add (g l) (g r)

newtype Expr a = Expr (Fix (ExprF a))

instance Functor Expr where
    fmap f (Expr exprF) = Expr (map f exprF)

EDIT: Here's a link to the bifunctors package in Hackage.