Derive Bifunctor with GHC.Generics

Bifunctor.hs

{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeOperators         #-}

module Bifunctor where

import GHC.Generics

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

  default bimap
    :: ( Generic (p a c)
       , Generic (p b d)
       , GBifunctor (Rep (p a c)) (Rep (p b d)) a b c d
       ) => (a -> b) -> (c -> d) -> p a c -> p b d
  bimap f g = to . gbimap f g . from

deriving instance Bifunctor Either

data T a b = T1 (Maybe a) a (Either a b) | T2 (Maybe b)
  deriving (Generic, Bifunctor)

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

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 {-# INCOHERENT #-} GBifunctor (Rec0 a) (Rec0 b) a b c d where
  gbimap f _ (K1 a) = K1 (f a)

instance {-# INCOHERENT #-} GBifunctor (Rec0 c) (Rec0 d) a b c d where
  gbimap _ g (K1 a) = K1 (g a)

instance {-# INCOHERENT #-} GBifunctor (Rec0 x) (Rec0 x) a b c d where
  gbimap _ _ = id

-- These instances look through wrapped functors and bifunctors.

instance {-# INCOHERENT #-} Bifunctor f => GBifunctor (Rec0 (f a c)) (Rec0 (f b d)) a b c d where
  gbimap f g (K1 a) = K1 (bimap f g a)

instance {-# INCOHERENT #-} Functor f => GBifunctor (Rec0 (f c)) (Rec0 (f d)) a b c d where
  gbimap _ g (K1 a) = K1 (fmap g a)

instance {-# INCOHERENT #-} Functor f => GBifunctor (Rec0 (f a)) (Rec0 (f b)) a b c d where
  gbimap f _ (K1 a) = K1 (fmap f a)
  
instance {-# INCOHERENT #-} Bifunctor f => GBifunctor (Rec0 (f a a)) (Rec0 (f b b)) a b c d where
  gbimap f _ (K1 a) = K1 (bimap f f a)

instance {-# INCOHERENT #-} Bifunctor f => GBifunctor (Rec0 (f c c)) (Rec0 (f d d)) a b c d where
  gbimap _ g (K1 b) = K1 (bimap g g b)

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

In principle, we actually have

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

instance GBifunctor V1 t a b c d where
  gbimap _ _ x = case x of

but that's probably not useful in context and I don't know how it might affect instance resolution.