Skip to content

Instantly share code, notes, and snippets.

@kcsongor kcsongor/Bifunctor.hs
Last active Oct 7, 2019

Embed
What would you like to do?
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

This comment has been minimized.

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

This comment has been minimized.

Copy link
Owner Author

kcsongor commented Jan 1, 2018

Oops, you're right, thanks!

@treeowl

This comment has been minimized.

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
You can’t perform that action at this time.