Playing with polynomial functors

gistfile1.hs

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

type Maybe = Coproduct (Const ()) Id

runMaybe :: Maybe a -> Either () a
runMaybe = bimap runConst runId . runCoproduct

just :: a -> Maybe a
just = Coproduct . Right . Id

nothing :: Maybe a
nothing = Coproduct . Left . Const $ ()

test :: Either () Int
test = runMaybe $ fmap (*2) (just 333)