{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Barbie.Internal.ProductC
( ProductBC(..)
, buniqC
, bmempty
, CanDeriveProductBC
, GAllB
, GProductBC(..)
, gbdictsDefault
, ProofB
, bproof
)
where
import Data.Barbie.Internal.Constraints
import Data.Barbie.Internal.Dicts(ClassF, Dict(..), requiringDict)
import Data.Barbie.Internal.Functor(bmap)
import Data.Barbie.Internal.Product(ProductB(..))
import Data.Generics.GenericN
class (ConstraintsB b, ProductB b) => ProductBC b where
bdicts :: AllB c b => b (Dict c)
default bdicts :: (CanDeriveProductBC c b, AllB c b) => b (Dict c)
bdicts = gbdictsDefault
type CanDeriveProductBC c b
= ( GenericN (b (Dict c))
, AllB c b ~ GAllB c (GAllBRep b)
, GProductBC c (GAllBRep b) (RepN (b (Dict c)))
)
buniqC :: forall c f b . (AllB c b, ProductBC b) => (forall a . c a => f a) -> b f
buniqC x
= bmap (requiringDict @c x) bdicts
bmempty :: forall f b . (AllBF Monoid f b, ProductBC b) => b f
bmempty
= buniqC @(ClassF Monoid f) mempty
{-# DEPRECATED bproof "Renamed to bdicts" #-}
bproof :: forall b c . (ProductBC b, AllB c b) => b (Dict c)
bproof = bdicts
{-# DEPRECATED ProofB "Class was renamed to ProductBC" #-}
type ProofB b = ProductBC b
gbdictsDefault
:: forall b c
. ( CanDeriveProductBC c b
, AllB c b
)
=> b (Dict c)
gbdictsDefault
= toN $ gbdicts @c @(GAllBRep b)
{-# INLINE gbdictsDefault #-}
class GProductBC c repbx repbd where
gbdicts :: GAllB c repbx => repbd x
instance GProductBC c repbx repbd => GProductBC c (M1 i k repbx) (M1 i k repbd) where
gbdicts = M1 (gbdicts @c @repbx)
{-# INLINE gbdicts #-}
instance GProductBC c U1 U1 where
gbdicts = U1
{-# INLINE gbdicts #-}
instance
( GProductBC c lx ld
, GProductBC c rx rd
) => GProductBC c (lx :*: rx)
(ld :*: rd) where
gbdicts = gbdicts @c @lx @ld :*: gbdicts @c @rx @rd
{-# INLINE gbdicts #-}
type P0 = Param 0
instance GProductBC c (Rec (P0 X a) (X a))
(Rec (P0 (Dict c) a) (Dict c a)) where
gbdicts = Rec (K1 Dict)
{-# INLINE gbdicts #-}
instance
( ProductBC b
, AllB c b
) => GProductBC c (Rec (Self b (P0 X)) (b X))
(Rec (b (P0 (Dict c)))
(b (Dict c))) where
gbdicts = Rec $ K1 $ bdicts @b
instance
( SameOrParam b b'
, ProductBC b'
, AllB c b'
) => GProductBC c (Rec (Other b (P0 X)) (b' X))
(Rec (b (P0 (Dict c)))
(b' (Dict c))) where
gbdicts = Rec $ K1 $ bdicts @b'