Haskell functor for red-black tree

Question

So I'm learning Haskell and I have a red-black tree with different types in red and black nodes implemented like this:

data Rbtree a1 b1 = EmptyTree | Node a1 (Rbtree b1 a1) (Rbtree b1 a1) deriving (Show, Read, Eq)

And now I need to define a functor instance for it. Because Rbtree is a type constructor that takes two parameters I have to make an instance for Rbtree c. And after this I'm stuck. My code now is something like this:

instance Functor (Rbtree c) where
fmap f EmptyTree = EmptyTree
fmap f (Node x left right) = Node x (fmap f left) (fmap f right)

As you could guess that does't compile. (compilation errors). I understand that fmap for it has to be (a -> b) -> (Rbtree c) a -> (Rbtree c) b and looking deeper for Node part it has to be (a -> b) -> (Node c (Rbtree a c) (Rbree a c)) -> (Node c (Rbtree b c) (Rbree b c)). What I do not understand is how to unfold left and right so i can apply f only to part of it. I think I'm missing something here.

Answer 1

You can make your Rbtree a Bifunctor (see bifunctors package) like this:

import Data.Bifunctor

data Rbtree a1 b1 = EmptyTree | Node a1 (Rbtree b1 a1) (Rbtree b1 a1)

instance Bifunctor Rbtree where
  bimap _ _ EmptyTree = EmptyTree
  bimap f g (Node x l r) = Node (f x) (bimap g f l) (bimap g f r)

With this instance you now have both first and second functions to map over red or black nodes (second ~ fmap). Actually you can define Functor instance like this:

instance Functor (Rbtree c) where
  fmap = second

---

Example

>>> let t = Node 1 (Node "hello" EmptyTree EmptyTree) EmptyTree
>>> bimap show length t
Node "1" (Node 5 EmptyTree EmptyTree) EmptyTree
>>> fmap length t
Node 1 (Node 5 EmptyTree EmptyTree) EmptyTree
>>> first show t
Node "1" (Node "hello" EmptyTree EmptyTree) EmptyTree

Answer 2

You can enforce all Red-Black tree invariants using GADTs and some type hackery (existential quantification, type arithmetic, data kinds). The properties are:

1. A node is either red or black.
2. The root is black.
3. All leaves (NIL) are black.
4. Every red node must have two black child nodes.
5. Every path from a given node to any of its descendant leaves contains the same number of black nodes.

And here is example code:

{-# LANGUAGE GADTs, StandaloneDeriving, ExistentialQuantification,
             KindSignatures, DataKinds #-}

data Nat = Zero | Succ Nat
data Color = Red | Black

data Node :: Color -> Nat -> * -> * where
    Nil :: Node Black Zero a
    RedNode :: a -> Node Black n a -> Node Black n a -> Node Red n a
    BlackNode :: a -> Node c1 n a -> Node c2 n a -> Node Black (Succ n) a

data RBTree a = forall n. RBTree (Node Black n a)

deriving instance (Show a) => Show (Node c n a)
deriving instance (Show a) => Show (RBTree a)

instance Functor (Node c n) where
    fmap f Nil = Nil
    fmap f (RedNode   x l r) = RedNode   (f x) (fmap f l) (fmap f r)
    fmap f (BlackNode x l r) = BlackNode (f x) (fmap f l) (fmap f r)

instance Functor RBTree where
    fmap f (RBTree t) = RBTree (fmap f t)

You can use it like this:

tree = RBTree $ BlackNode 3 (RedNode 4 Nil Nil) (RedNode 5 Nil Nil)
main = print $ fmap (*5) tree

Result:

RBTree (BlackNode 15 (RedNode 20 Nil Nil) (RedNode 25 Nil Nil))

But this won't compile:

tree = RBTree $ BlackNode 3 (RedNode 4 Nil Nil) (BlackNode 5 Nil Nil)

You will get a nice error message:

Couldn't match type `Succ Zero' with `Zero'
Expected type: Node Black Zero a0
  Actual type: Node Black (Succ Zero) a0
In the return type of a call of `BlackNode'
In the third argument of `BlackNode', namely
  `(BlackNode 5 Nil Nil)'
In the second argument of `($)', namely
  `BlackNode 3 (RedNode 4 Nil Nil) (BlackNode 5 Nil Nil)'