> {-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}
> module Diag where

> import GHC.Prim

Polynomial Functors

> newtype Id          x = Id x                   -- element
> newtype K1 a        x = K1 a                   -- constant
> data ((Sum1 p q))   x = L1 (p x) | R1 (q x)    -- choice
> data ((Prod1 p q))  x = P1 (p x) (q x)         -- pairing

< class Functor p where
<   fmap :: (s -> t) -> p s -> p t 

> instance Functor Id where
>   fmap f (Id s)    = Id (f s)
>
> instance Functor (K1 a) where
>   fmap f (K1 a)    = K1 a
>
> instance (Functor p, Functor q) => Functor (Sum1 p q) where
>   fmap f (L1 p)    = L1 (fmap f p)
>   fmap f (R1 q)    = R1 (fmap f q)
>
> instance (Functor p, Functor q) => Functor (Prod1 p q) where
>   fmap f (P1 p q)  = P1 (fmap f p) (fmap f q)

Show stuff

> class PresShow p where
>   presShow :: (x -> String) -> p x -> String

> instance Show a => PresShow (K1 a) where
>   presShow sh (K1 a) = "K1 (" ++ show a ++ ")"

> instance PresShow Id where
>   presShow sh (Id x) = "Id (" ++ sh x ++ ")"

> instance (PresShow p, PresShow q) => PresShow (Sum1 p q) where
>   presShow sh  (L1 p)  = "L1 (" ++ presShow sh p ++ ")"
>   presShow sh  (R1 q)  = "R1 (" ++ presShow sh q ++ ")"

> instance (PresShow p, PresShow q) => PresShow (Prod1 p q) where
>   presShow sh (P1 p q) =
>     "P1 (" ++ presShow sh p ++ ") (" ++  presShow sh q ++ ")"


Polynomial Bifunctors

> newtype Fst         x y = Fst x
> newtype Snd         x y = Snd y
> newtype K2 a        x y = K2 a
> data ((Sum2 p q))   x y = L2 (p x y) | R2 (q x y)
> data ((Prod2 p q))  x y = P2 (p x y) (q x y)

> class Bifunctor p where
>   bimap ::  (s1 -> t1) -> (s2 -> t2) -> p s1 s2 -> p t1 t2
>
> instance Bifunctor Fst where
>   bimap f g (Fst x)   = Fst (f x)
>
> instance Bifunctor Snd where
>   bimap f g (Snd y)   = Snd (g y)
>
> instance Bifunctor (K2 a) where
>   bimap f g (K2 a)    = K2 a
>
> instance  (Bifunctor p, Bifunctor q) =>
>           Bifunctor (Sum2 p q) where
>   bimap f g (L2 p)    = L2 (bimap f g p)
>   bimap f g (R2 q)    = R2 (bimap f g q)
>
> instance  (Bifunctor p, Bifunctor q) =>
>           Bifunctor (Prod2 p q) where
>   bimap f g (P2 p q)  = P2 (bimap f g p) (bimap f g q)

Collapsing the diagonal.

> class (Bifunctor b, Functor f) => Diag b f | b -> f where
>   diag :: b x x -> f x
>   gaid :: f x -> b x x

> instance Diag Fst Id where
>   diag (Fst x) = Id x
>   gaid (Id x)  = Fst x

> instance Diag Snd Id where
>   diag (Snd x) = Id x
>   gaid (Id x)  = Snd x

> instance Diag (K2 a) (K1 a) where
>   diag (K2 a) = K1 a
>   gaid (K1 a) = K2 a

> instance (Diag pb pf, Diag qb qf) => Diag (Sum2 pb qb) (Sum1 pf qf) where
>   diag (L2 p) = L1 (diag p)
>   diag (R2 q) = R1 (diag q)
>   gaid (L1 p) = L2 (gaid p)
>   gaid (R1 q) = R2 (gaid q)

> instance (Diag pb pf, Diag qb qf) => Diag (Prod2 pb qb) (Prod1 pf qf) where
>   diag (P2 p q) = P1 (diag p) (diag q)
>   gaid (P1 p q) = P2 (gaid p) (gaid q)

> dodgy :: Diag b f => b x x -> f x
> dodgy = unsafeCoerce#

> ygdod :: Diag b f => f x -> b x x
> ygdod = unsafeCoerce#