Polynomial functors, initial algebras and catamorphisms

gistfile1.hs

{-# LANGUAGE PatternSynonyms #-}
module Polynomial where

import Prelude hiding (Maybe(..))

class Bifunctor f where
  bimap :: (a -> b) -> (c -> d) -> f a c -> f b d

instance Bifunctor (,) where
  bimap f g (x, y) = (f x, g y)

instance Bifunctor Either where
  bimap f _ (Left x)  = Left (f x)
  bimap _ g (Right y) = Right (g y)

newtype Const a b = Const { runConst :: a }

instance Functor (Const a) where
  fmap f = Const . runConst

newtype Id a = Id { runId :: a }

instance Functor Id where
  fmap f = Id . f . runId

newtype Coproduct f g a = Coproduct
  { runCoproduct :: Either (f a) (g a) }

instance (Functor f, Functor g) => Functor (Coproduct f g) where
  fmap f = Coproduct . bimap (fmap f) (fmap f) . runCoproduct

newtype Product f g a = Product
  { runProduct :: (f a, g a) }

instance (Functor f, Functor g) => Functor (Product f g) where
  fmap f = Product . bimap (fmap f) (fmap f) . runProduct

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

type Algebra f a = f a -> a

cata :: Functor f => Algebra f a -> Fix f -> a
cata phi = phi . fmap (cata phi) . runFix

newtype ListF a l = ListF
  { runListF :: Coproduct (Const ()) (Product Id (Const l)) a }

pattern NilF       = ListF (Coproduct (Left (Const ())))
pattern ConsF x xs = ListF (Coproduct (Right (Product (Id x, Const xs))))

instance Functor (ListF a) where
  fmap _ NilF         = NilF
  fmap f (ConsF x xs) = ConsF x (f xs)

newtype List a = List { runList :: Fix (ListF a) }

mkAlg :: (a -> b) -> Algebra (ListF a) (List b)
mkAlg _ NilF         = nil
mkAlg f (ConsF x xs) = f x `cons` xs

instance Functor List where
  fmap f = cata (mkAlg f) . runList

nil :: List a
nil = List (Fix NilF)

infixr 5 `cons`
cons :: a -> List a -> List a
cons x = List . Fix . ConsF x . runList

alg :: Algebra (ListF a) [a]
alg NilF         = []
alg (ConsF x xs) = x : xs

evalList :: List a -> [a]
evalList = cata alg . runList

listexample :: [Int]
listexample = evalList (fmap (*2) $ 333 `cons` 222 `cons` nil)