{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Barbie.Internal.Instances ( Barbie(..) )
where
import Data.Barbie.Internal.Bare
import Data.Barbie.Internal.Constraints
import Data.Barbie.Internal.Dicts
import Data.Barbie.Internal.Functor
import Data.Barbie.Internal.Traversable
import Data.Barbie.Internal.Product
import Data.Barbie.Internal.ProofB
import Data.Semigroup (Semigroup, (<>))
newtype Barbie b (f :: * -> *)
= Barbie { getBarbie :: b f }
deriving (FunctorB, ProductB, BareB, ProofB)
instance ConstraintsB b => ConstraintsB (Barbie b) where
type ConstraintsOf c f (Barbie b) = ConstraintsOf c f b
adjProof = Barbie . adjProof . getBarbie
instance TraversableB b => TraversableB (Barbie b) where
btraverse f = fmap Barbie . btraverse f . getBarbie
instance (ProofB b, ConstraintsOf Semigroup f b) => Semigroup (Barbie b f) where
(<>) = bzipWith3 mk bproof
where
mk :: DictOf Semigroup f a -> f a -> f a -> f a
mk = requiringDict (<>)
instance (ProofB b, ConstraintsOf Semigroup f b, ConstraintsOf Monoid f b) => Monoid (Barbie b f) where
mempty = bmap mk bproof
where
mk :: DictOf Monoid f a -> f a
mk = requiringDict mempty
mappend = (<>)