{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}
module Barbies.Internal.Wrappers
  ( Barbie(..)
  ) where

import Barbies.Internal.ApplicativeB
import Barbies.Internal.ConstraintsB
import Barbies.Internal.Dicts
import Barbies.Internal.FunctorB
import Barbies.Internal.TraversableB

import Data.Kind (Type)


-- | A wrapper for Barbie-types, providing useful instances.
newtype Barbie (b :: (k -> Type) -> Type) f
  = Barbie { Barbie b f -> b f
getBarbie :: b f }
  deriving ((forall (a :: k). f a -> g a) -> Barbie b f -> Barbie b g
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> Barbie b f -> Barbie b g)
-> FunctorB (Barbie b)
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> Barbie b f -> Barbie b g
forall k (b :: (k -> *) -> *).
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> b f -> b g)
-> FunctorB b
forall (f :: k -> *) (g :: k -> *).
(forall (a :: k). f a -> g a) -> Barbie b f -> Barbie b g
bmap :: (forall (a :: k). f a -> g a) -> Barbie b f -> Barbie b g
$cbmap :: forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> Barbie b f -> Barbie b g
FunctorB, FunctorB (Barbie b)
FunctorB (Barbie b)
-> (forall (f :: k -> *). (forall (a :: k). f a) -> Barbie b f)
-> (forall (f :: k -> *) (g :: k -> *).
    Barbie b f -> Barbie b g -> Barbie b (Product f g))
-> ApplicativeB (Barbie b)
Barbie b f -> Barbie b g -> Barbie b (Product f g)
(forall (a :: k). f a) -> Barbie b f
forall k (b :: (k -> *) -> *).
FunctorB b
-> (forall (f :: k -> *). (forall (a :: k). f a) -> b f)
-> (forall (f :: k -> *) (g :: k -> *).
    b f -> b g -> b (Product f g))
-> ApplicativeB b
forall k (b :: (k -> *) -> *).
ApplicativeB b =>
FunctorB (Barbie b)
forall k (b :: (k -> *) -> *) (f :: k -> *).
ApplicativeB b =>
(forall (a :: k). f a) -> Barbie b f
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
ApplicativeB b =>
Barbie b f -> Barbie b g -> Barbie b (Product f g)
forall (f :: k -> *). (forall (a :: k). f a) -> Barbie b f
forall (f :: k -> *) (g :: k -> *).
Barbie b f -> Barbie b g -> Barbie b (Product f g)
bprod :: Barbie b f -> Barbie b g -> Barbie b (Product f g)
$cbprod :: forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
ApplicativeB b =>
Barbie b f -> Barbie b g -> Barbie b (Product f g)
bpure :: (forall (a :: k). f a) -> Barbie b f
$cbpure :: forall k (b :: (k -> *) -> *) (f :: k -> *).
ApplicativeB b =>
(forall (a :: k). f a) -> Barbie b f
$cp1ApplicativeB :: forall k (b :: (k -> *) -> *).
ApplicativeB b =>
FunctorB (Barbie b)
ApplicativeB)

-- Need to derive it manually to make GHC 8.0.2 happy
instance ConstraintsB b => ConstraintsB (Barbie b) where
  type AllB c (Barbie b) = AllB c b
  baddDicts :: Barbie b f -> Barbie b (Product (Dict c) f)
baddDicts = b (Product (Dict c) f) -> Barbie b (Product (Dict c) f)
forall k (b :: (k -> *) -> *) (f :: k -> *). b f -> Barbie b f
Barbie (b (Product (Dict c) f) -> Barbie b (Product (Dict c) f))
-> (Barbie b f -> b (Product (Dict c) f))
-> Barbie b f
-> Barbie b (Product (Dict c) f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b f -> b (Product (Dict c) f)
forall k (b :: (k -> *) -> *) (c :: k -> Constraint) (f :: k -> *).
(ConstraintsB b, AllB c b) =>
b f -> b (Product (Dict c) f)
baddDicts (b f -> b (Product (Dict c) f))
-> (Barbie b f -> b f) -> Barbie b f -> b (Product (Dict c) f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Barbie b f -> b f
forall k (b :: (k -> *) -> *) (f :: k -> *). Barbie b f -> b f
getBarbie

instance TraversableB b => TraversableB (Barbie b) where
  btraverse :: (forall (a :: k). f a -> e (g a)) -> Barbie b f -> e (Barbie b g)
btraverse forall (a :: k). f a -> e (g a)
f = (b g -> Barbie b g) -> e (b g) -> e (Barbie b g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b g -> Barbie b g
forall k (b :: (k -> *) -> *) (f :: k -> *). b f -> Barbie b f
Barbie (e (b g) -> e (Barbie b g))
-> (Barbie b f -> e (b g)) -> Barbie b f -> e (Barbie b g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
forall k (b :: (k -> *) -> *) (e :: * -> *) (f :: k -> *)
       (g :: k -> *).
(TraversableB b, Applicative e) =>
(forall (a :: k). f a -> e (g a)) -> b f -> e (b g)
btraverse forall (a :: k). f a -> e (g a)
f (b f -> e (b g)) -> (Barbie b f -> b f) -> Barbie b f -> e (b g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Barbie b f -> b f
forall k (b :: (k -> *) -> *) (f :: k -> *). Barbie b f -> b f
getBarbie


instance (ConstraintsB b, ApplicativeB b, AllBF Semigroup f b) => Semigroup (Barbie b f) where
  <> :: Barbie b f -> Barbie b f -> Barbie b f
(<>) = (forall (a :: k). Dict (ClassF Semigroup f) a -> f a -> f a -> f a)
-> Barbie b (Dict (ClassF Semigroup f))
-> Barbie b f
-> Barbie b f
-> Barbie b f
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *)
       (h :: k -> *) (i :: k -> *).
ApplicativeB b =>
(forall (a :: k). f a -> g a -> h a -> i a)
-> b f -> b g -> b h -> b i
bzipWith3 forall (a :: k). Dict (ClassF Semigroup f) a -> f a -> f a -> f a
mk Barbie b (Dict (ClassF Semigroup f))
forall k (c :: k -> Constraint) (b :: (k -> *) -> *).
(ConstraintsB b, ApplicativeB b, AllB c b) =>
b (Dict c)
bdicts
    where
      mk :: Dict (ClassF Semigroup f) a -> f a -> f a -> f a
      mk :: Dict (ClassF Semigroup f) a -> f a -> f a -> f a
mk = (ClassF Semigroup f a => f a -> f a -> f a)
-> Dict (ClassF Semigroup f) a -> f a -> f a -> f a
forall k (c :: k -> Constraint) (a :: k) r.
(c a => r) -> Dict c a -> r
requiringDict ClassF Semigroup f a => f a -> f a -> f a
forall a. Semigroup a => a -> a -> a
(<>)

instance (ConstraintsB b, ApplicativeB b, AllBF Semigroup f b, AllBF Monoid f b) => Monoid (Barbie b f) where
  mempty :: Barbie b f
mempty  = Barbie b f
forall k (f :: k -> *) (b :: (k -> *) -> *).
(AllBF Monoid f b, ConstraintsB b, ApplicativeB b) =>
b f
bmempty
  mappend :: Barbie b f -> Barbie b f -> Barbie b f
mappend = Barbie b f -> Barbie b f -> Barbie b f
forall a. Semigroup a => a -> a -> a
(<>)