Generic implementation of Foldable and Traversable instances

GenericFoldableTraversable.hs

{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts #-}

module GenericFoldableTraversable where

import Data.Monoid         ( Monoid, mappend, mempty )
import Data.Foldable       ( Foldable, foldMap )

import Control.Applicative ( Applicative, pure, (<*>) )
import Data.Traversable    ( Traversable, traverse )

newtype Const c   a = Const c
newtype Id        a = Id a
data    (f :*: g) a = f a :*: g a
data    (f :+: g) a = L (f a) | R (g a)

instance Functor  (Const c) where fmap    _ (Const c) = Const c
instance Foldable (Const c) where foldMap _ _         = mempty

instance Functor  Id where fmap    f (Id x) = Id $ f x
instance Foldable Id where foldMap f (Id x) = f x

instance (Functor f, Functor g) => Functor (f :*: g) where
  fmap f (x :*: y) = fmap f x :*: fmap f y

instance (Foldable f, Foldable g) => Foldable (f :*: g) where
  foldMap f (x :*: y) = foldMap f x `mappend` foldMap f y

instance (Functor f, Functor g) => Functor (f :+: g) where
  fmap f (L x) = L (fmap f x)
  fmap f (R x) = R (fmap f x)

instance (Foldable f, Foldable g) => Foldable (f :+: g) where
  foldMap f (L x) = foldMap f x
  foldMap f (R x) = foldMap f x

class Encodable f where
  type Enc f :: * -> *

  encode :: f a -> Enc f a
  decode :: Enc f a -> f a

foldMapEnc :: (Encodable f, Foldable (Enc f), Monoid m) => (a -> m) -> f a -> m
foldMapEnc f = foldMap f . encode

data List a = Nil | Cons a (List a)
  deriving Show

instance Encodable List where
  type Enc List = Const () :+: (Id :*: List)

  encode Nil         = L $ Const ()
  encode (Cons x xs) = R $ Id x :*: xs

  decode (L (Const ()))    = Nil
  decode (R (Id x :*: xs)) = Cons x xs

instance Foldable List where
  foldMap = foldMapEnc

data Tree a = Tip | Bin (Tree a) a (Tree a)
  deriving Show

instance Encodable Tree where
  type Enc Tree = Const () :+: (Tree :*: Id :*: Tree)

  encode Tip         = L $ Const ()
  encode (Bin l x r) = R $ l :*: Id x :*: r

  decode (L (Const ()))         = Tip
  decode (R (l :*: Id x :*: r)) = Bin l x r

instance Foldable Tree where
  foldMap = foldMapEnc

instance Traversable (Const c) where
  traverse _ (Const c) = pure $ Const c

instance Traversable Id where
  traverse f (Id x) = pure Id <*> f x

instance (Traversable f, Traversable g) => Traversable (f :*: g) where
  traverse f (x :*: y) = pure (:*:) <*> traverse f x <*> traverse f y

instance (Traversable f, Traversable g) => Traversable (f :+: g) where
  traverse f (L x) = pure L <*> traverse f x
  traverse f (R x) = pure R <*> traverse f x

traverseEnc :: (Encodable f, Traversable (Enc f), Applicative g)
            => (a -> g b) -> f a -> g (f b)
traverseEnc f = fmap decode . traverse f . encode

instance Functor List where
  fmap _ Nil         = Nil
  fmap f (Cons x xs) = Cons (f x) (fmap f xs)

instance Traversable List where
  traverse = traverseEnc

instance Functor Tree where
  fmap _ Tip         = Tip
  fmap f (Bin l x r) = Bin (fmap f l) (f x) (fmap f r)

instance Traversable Tree where
  traverse = traverseEnc