{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Data.Barbie.Internal.Functor
( FunctorB(..)
, GFunctorB
, gbmapDefault
, CanDeriveGenericInstance
)
where
import Data.Barbie.Internal.Generics
import Data.Barbie.Internal.Tags (F,G)
import GHC.Generics
class FunctorB b where
bmap :: (forall a . f a -> g a) -> b f -> b g
default bmap
:: CanDeriveGenericInstance b
=> (forall a . f a -> g a) -> b f -> b g
bmap = gbmapDefault
type CanDeriveGenericInstance b
= ( Generic (b (Target F))
, Generic (b (Target G))
, GFunctorB (Rep (b (Target F)))
, Rep (b (Target G)) ~ Repl (Target F) (Target G) (Rep (b (Target F)))
)
gbmapDefault
:: CanDeriveGenericInstance b
=> (forall a . f a -> g a) -> b f -> b g
gbmapDefault f b
= unsafeUntargetBarbie @G $ to $ gbmap f $ from (unsafeTargetBarbie @F b)
class GFunctorB b where
gbmap :: (forall a . f a -> g a) -> b x -> Repl (Target F) (Target G) b x
instance GFunctorB x => GFunctorB (M1 i c x) where
{-# INLINE gbmap #-}
gbmap f (M1 x) = M1 (gbmap f x)
instance GFunctorB V1 where
gbmap _ _ = undefined
instance GFunctorB U1 where
{-# INLINE gbmap #-}
gbmap _ u1 = u1
instance (GFunctorB l, GFunctorB r) => GFunctorB (l :*: r) where
{-# INLINE gbmap #-}
gbmap f (l :*: r)
= (gbmap f l) :*: gbmap f r
instance (GFunctorB l, GFunctorB r) => GFunctorB (l :+: r) where
{-# INLINE gbmap #-}
gbmap f = \case
L1 l -> L1 (gbmap f l)
R1 r -> R1 (gbmap f r)
instance {-# OVERLAPPING #-} GFunctorB (K1 R (Target (W F) a)) where
{-# INLINE gbmap #-}
gbmap f (K1 fa)
= K1 $ unsafeTarget @(W G) (f $ unsafeUntarget @(W F) fa)
instance {-# OVERLAPPING #-} GFunctorB (K1 R (Target F a)) where
{-# INLINE gbmap #-}
gbmap f (K1 fa)
= K1 $ unsafeTarget @G (f $ unsafeUntarget @F fa)
instance {-# OVERLAPPING #-} FunctorB b => GFunctorB (K1 R (b (Target F))) where
{-# INLINE gbmap #-}
gbmap f (K1 bf)
= K1 $ bmap (unsafeTarget @G . f . unsafeUntarget @F) bf
instance {-# OVERLAPPING #-}
( Functor h
, FunctorB b
, Repl (Target F) (Target G) (K1 R (h (b (Target F))))
~ (K1 R (h (b (Target G))))
)
=> GFunctorB (K1 R (h (b (Target F)))) where
{-# INLINE gbmap #-}
gbmap f (K1 hbf)
= K1 (fmap (unsafeTargetBarbie @G . bmap f . unsafeUntargetBarbie @F) hbf)
instance (K1 i c) ~ Repl (Target F) (Target G) (K1 i c) => GFunctorB (K1 i c) where
{-# INLINE gbmap #-}
gbmap _ k1 = k1