Derive Bifunctor with Generics (no incoherent instances)

BifunctorNoIncoherent.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

module Bifunctor where

import GHC.Generics
import GHC.TypeLits (Nat)
import Data.Coerce

newtype P (i :: Nat) a = P a

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

  default bimap
    :: forall a b c d.
       ( Generic (p (P 1 a) (P 0 c))
       , Generic (p (P 1 b) (P 0 d))
       , Coercible (p a c) (p (P 1 a) (P 0 c))
       , Coercible (p (P 1 b) (P 0 d)) (p b d)
       , GBifunctor (Rep (p (P 1 a) (P 0 c))) (Rep (p (P 1 b) (P 0 d))) a b c d
       ) => (a -> b) -> (c -> d) -> p a c -> p b d
  bimap f g
    = (coerce @(p (P 1 b) (P 0 d)))
      . to . gbimap f g . from
      . (coerce @_ @(p (P 1 a) (P 0 c)))

deriving instance Bifunctor Either

--------------------------------------------------------------------------------

class GBifunctor s t a b c d where
  gbimap :: (a -> b) -> (c -> d) -> s x -> t x

instance GBifunctor s t a b c d => GBifunctor (M1 k m s) (M1 k m t) a b c d where
  gbimap f g = M1 . gbimap f g . unM1

instance (GBifunctor l l' a b c d, GBifunctor r r' a b c d) => GBifunctor (l :+: r) (l' :+: r') a b c d where
  gbimap f g (L1 l) = L1 (gbimap f g l)
  gbimap f g (R1 r) = R1 (gbimap f g r)

instance GBifunctor U1 U1 a b c d where
  gbimap _ _ = id

instance (GBifunctor l l' a b c d, GBifunctor r r' a b c d) => GBifunctor (l :*: r) (l' :*: r') a b c d where
  gbimap f g (l :*: r) = gbimap f g l :*: gbimap f g r

instance GBifunctor (Rec0 (P 1 a)) (Rec0 (P 1 b)) a b c d where
  gbimap f _ (K1 (P a)) = K1 (P (f a))

instance GBifunctor (Rec0 (P 0 c)) (Rec0 (P 0 d)) a b c d where
  gbimap _ g (K1 (P a)) = K1 (P (g a))

instance {-# OVERLAPPABLE #-} x ~ y => GBifunctor (Rec0 x) (Rec0 y) a b c d where
  gbimap _ _ = id

instance {-# OVERLAPPABLE #-}
         ( Bifunctor f
         , Coercible (f (P 1 a) (P 0 c)) (f a c)
         , Coercible (f (P 1 b) (P 0 d)) (f b d)
         ) => GBifunctor (Rec0 (f (P 1 a) (P 0 c))) (Rec0 (f (P 1 b) (P 0 d))) a b c d where
  gbimap f g (K1 a) = coerce (K1 (bimap f g (coerce @_ @(f a c) a)))