Skip to content

Instantly share code, notes, and snippets.

@kcsongor
Last active October 7, 2019 23:04
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save kcsongor/a8cb718f676c6ca1d999bfc56def9b7b to your computer and use it in GitHub Desktop.
Save kcsongor/a8cb718f676c6ca1d999bfc56def9b7b to your computer and use it in GitHub Desktop.
Derive Bifunctor with GHC.Generics
{-# 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)
@adituv
Copy link

adituv commented Jan 1, 2018

You're missing at least a couple of instances. The ones I found was the case like this:

data TDup a b = TDup (Either a a) b

Adding these instances fixes it:

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

@kcsongor
Copy link
Author

kcsongor commented Jan 1, 2018

Oops, you're right, thanks!

@treeowl
Copy link

treeowl commented Oct 7, 2019

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.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment