Traverse, Fold, Functor for Tree

Tree.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
module Main where

import Prelude hiding (foldr)
import Control.Applicative
import Control.Monad (void)
import Data.Foldable
import Data.Traversable

data Tree a
  = Empty
  | Leaf a
  | Node (Tree a) a (Tree a) deriving Show

-- Let GHC figure out reasonable defaults
data Tree' a
  = Empty'
  | Leaf' a
  | Node' (Tree' a) a (Tree' a) deriving (Show, Functor, Foldable, Traversable)

-- Functor by hand
instance Functor Tree where
  fmap _ Empty = Empty
  fmap f (Leaf a) = Leaf (f a)
  fmap f (Node l x r) = Node (fmap f l) (f x) (fmap f r)

-- Foldable by hand
instance Foldable Tree where
  foldr _ z Empty = z
  foldr f z (Leaf a) = f a z
  foldr f z (Node l x r) = foldr f (f x (foldr f z l)) r

-- effectful traversal of a Tree by hand
instance Traversable Tree where
  traverse _ Empty = pure Empty
  traverse f (Leaf a) = Leaf <$> f a
  traverse f (Node l x r) = Node <$> traverse f l <*> f x <*> traverse f r

main :: IO ()
main = do
  let t = Node (Leaf 1) 2 (Leaf 3)
  let t' = Node' (Leaf' 1) 2 (Leaf' 3)
  (void . print) $ fmap (+1) t
  (void . print) $ fmap (+1) t'
  void $ traverse print t
  void $ traverse print t'