{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Row.Barbies
--
-- This module adds Barbies instances for 'Rec' and 'Var'.
--
-----------------------------------------------------------------------------


module Data.Row.Barbies () where

import           Data.Functor.Compose
import           Data.Functor.Identity
import           Data.Functor.Product
import           Data.Row
import           Data.Row.Dictionaries
import qualified Data.Row.Records      as Rec
import qualified Data.Row.Variants     as Var

import           Data.Functor.Barbie (FunctorB(..), TraversableB(..), DistributiveB(..), ApplicativeB(..), ConstraintsB(..))
import qualified Barbies.Constraints as B

-- | Barbies requires that the functor be the final argument of the type.  So,
-- even though the real type is @Rec (Map f ρ)@, we must wrap it in a newtype
-- wrapper so that 'f' is at the end.
newtype BarbieRec (ρ :: Row *) (f :: * -> *) = BarbieRec { unBarbieRec :: Rec (Rec.Map f ρ) }
newtype BarbieVar (ρ :: Row *) (f :: * -> *) = BarbieVar { unBarbieVar :: Var (Var.Map f ρ) }

instance FreeForall r => FunctorB (BarbieRec r) where
  bmap f = BarbieRec . Rec.transform' @r f . unBarbieRec

instance FreeForall r => TraversableB (BarbieRec r) where
  btraverse :: forall e f g. Applicative e => (forall a. f a -> e (g a)) -> BarbieRec r f -> e (BarbieRec r g)
  btraverse f  = fmap BarbieRec . Rec.traverseMap @Unconstrained1 @e @f @g @r f . unBarbieRec

instance FreeForall r => DistributiveB (BarbieRec r) where
  bdistribute :: forall f g. Functor f => f (BarbieRec r g) -> BarbieRec r (Compose f g)
  bdistribute = BarbieRec . Rec.compose @f @g @r . Rec.distribute @f @(Rec.Map g r) . fmap unBarbieRec
    \\ freeForall @(Rec.Map g r) @(IsA Unconstrained1 g) \\ mapForall @g @r @Unconstrained1

instance (AllUniqueLabels r, FreeForall r) => ApplicativeB (BarbieRec r) where
  bpure :: forall f. (forall a. f a) -> BarbieRec r f
  bpure fa = BarbieRec $ runIdentity $ Rec.fromLabelsMapA @Unconstrained1 @Identity @f @r (const $ Identity fa)

  bprod :: forall f g. BarbieRec r f -> BarbieRec r g -> BarbieRec r (f `Product` g)
  bprod (BarbieRec r1) (BarbieRec r2) = BarbieRec $ Rec.zipTransform @Unconstrained1 @r @f @g @(Product f g) Pair r1 r2

instance FreeForall r => ConstraintsB (BarbieRec r) where
  type AllB c (BarbieRec r) = Forall r c
  baddDicts :: forall c f. Forall r c => BarbieRec r f -> BarbieRec r (B.Dict c `Product` f)
  baddDicts = BarbieRec . Rec.transform @c @r @f @(B.Dict c `Product` f) (Pair (B.Dict @c)) . unBarbieRec



instance FreeForall r => FunctorB (BarbieVar r) where
  bmap f = BarbieVar . Var.transform' @r f . unBarbieVar

instance FreeForall r => TraversableB (BarbieVar r) where
  btraverse :: forall e f g. Applicative e => (forall a. f a -> e (g a)) -> BarbieVar r f -> e (BarbieVar r g)
  btraverse f  = fmap BarbieVar . Var.traverseMap @Unconstrained1 @e @f @g @r f . unBarbieVar

instance FreeForall r => ConstraintsB (BarbieVar r) where
  type AllB c (BarbieVar r) = Forall r c
  baddDicts :: forall c f. Forall r c => BarbieVar r f -> BarbieVar r (B.Dict c `Product` f)
  baddDicts = BarbieVar . Var.transform @c @r @f @(B.Dict c `Product` f) (Pair (B.Dict @c)) . unBarbieVar