content: {-# language AllowAmbiguousTypes #-}
  {-# language DataKinds #-}
  {-# language DefaultSignatures #-}
  {-# language FlexibleContexts #-}
  {-# language FlexibleInstances #-}
  {-# language FunctionalDependencies #-}
  {-# language LambdaCase #-}
  {-# language RankNTypes #-}
  {-# language ScopedTypeVariables #-}
  {-# language StandaloneKindSignatures #-}
  {-# language TypeApplications #-}
  {-# language TypeFamilyDependencies #-}
  {-# language TypeOperators #-}
  {-# language UndecidableInstances #-}
  
  module Rel8.Schema.HTable
    ( HTable (HField, HConstrainTable)
    , hfield, htabulate, hdicts, hspecs
    , hfoldMap, hmap, htabulateA, htabulateP
    , htraverse, htraverse_, htraverseP, htraversePWithField
    )
  where
  
  -- base
  import Data.Functor (void)
  import Data.Functor.Compose ( Compose( Compose ), getCompose )
  import Data.Functor.Const ( Const( Const ), getConst )
  import Data.Kind ( Constraint, Type )
  import Data.Proxy ( Proxy )
  import GHC.Generics
    ( (:*:)( (:*:) )
    , Generic (Rep, from, to)
    , K1( K1 )
    , M1( M1 )
    )
  import Prelude
  
  -- profunctors
  import Data.Profunctor ( rmap, Profunctor (lmap) )
  
  -- product-profunctors
  import Data.Profunctor.Product ( ProductProfunctor ((****)) )
  
  -- rel8
  import Rel8.Schema.Dict ( Dict )
  import Rel8.Schema.Spec ( Spec )
  import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
  import qualified Rel8.Schema.Kind as K
  
  -- semigroupoids
  import Data.Functor.Apply (Apply, (<.>), liftF2)
  
  -- | A @HTable@ is a functor-indexed/higher-kinded data type that is
  -- representable ('htabulate'/'hfield'), constrainable ('hdicts'), and
  -- specified ('hspecs').
  --
  -- This is an internal concept for Rel8, and you should not need to define
  -- instances yourself or specify this constraint.
  type HTable :: K.HTable -> Constraint
  class HTable t where
    type HField t = (field :: Type -> Type) | field -> t
    type HConstrainTable t (c :: Type -> Constraint) :: Constraint
  
    hfield :: t context -> HField t a -> context a
    htabulate :: (forall a. HField t a -> context a) -> t context
    htraverse :: Apply m => (forall a. f a -> m (g a)) -> t f -> m (t g)
    hdicts :: HConstrainTable t c => t (Dict c)
    hspecs :: t Spec
  
    type HField t = GHField t
    type HConstrainTable t c = HConstrainTable (GHColumns (Rep (t Proxy))) c
  
    default hfield ::
      ( Generic (t context)
      , HField t ~ GHField t
      , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
      , GHTable context (Rep (t context))
      )
      => t context -> HField t a -> context a
    hfield table (GHField field) = hfield (toGHColumns (from table)) field
  
    default htabulate ::
      ( Generic (t context)
      , HField t ~ GHField t
      , HField (GHColumns (Rep (t Proxy))) ~ HField (GHColumns (Rep (t context)))
      , GHTable context (Rep (t context))
      )
      => (forall a. HField t a -> context a) -> t context
    htabulate f = to $ fromGHColumns $ htabulate (f . GHField)
  
    default htraverse
      :: forall f g m
       . ( Apply m
         , Generic (t f), GHTable f (Rep (t f))
         , Generic (t g), GHTable g (Rep (t g))
         , GHColumns (Rep (t f)) ~ GHColumns (Rep (t g))
         )
      => (forall a. f a -> m (g a)) -> t f -> m (t g)
    htraverse f = fmap (to . fromGHColumns) . htraverse f . toGHColumns . from
  
    default hdicts
      :: forall c
       . ( Generic (t (Dict c))
         , GHTable (Dict c) (Rep (t (Dict c)))
         , GHColumns (Rep (t Proxy)) ~ GHColumns (Rep (t (Dict c)))
         , HConstrainTable (GHColumns (Rep (t Proxy))) c
         )
      => t (Dict c)
    hdicts = to $ fromGHColumns (hdicts @(GHColumns (Rep (t Proxy))) @c)
  
    default hspecs ::
      ( Generic (t Spec)
      , GHTable Spec (Rep (t Spec))
      )
      => t Spec
    hspecs = to $ fromGHColumns hspecs
  
    {-# INLINABLE hfield #-}
    {-# INLINABLE htabulate #-}
    {-# INLINABLE htraverse #-}
    {-# INLINABLE hdicts #-}
    {-# INLINABLE hspecs #-}
  
  
  hfoldMap :: (HTable t, Semigroup s)
    => (forall a. context a -> s) -> t context -> s
  hfoldMap f a = getConst $ htraverse (Const . f) a
  
  
  hmap :: HTable t
    => (forall a. context a -> context' a) -> t context -> t context'
  hmap f a = htabulate $ \field -> f (hfield a field)
  
  
  newtype Ap f a = Ap
    { getAp :: f a
    }
  
  
  instance (Apply f, Semigroup a) => Semigroup (Ap f a) where
    Ap a <> Ap b = Ap (liftF2 (<>) a b)
  
  
  htraverse_ :: (HTable t, Apply f)
    => (forall a. context a -> f b) -> t context -> f ()
  htraverse_ f a = getAp $ hfoldMap (Ap . void . f) a
  
  
  htabulateA :: (HTable t, Apply m)
    => (forall a. HField t a -> m (context a)) -> m (t context)
  htabulateA f = htraverse getCompose $ htabulate $ Compose . f
  {-# INLINABLE htabulateA #-}
  
  
  htabulateP :: (HTable t, ProductProfunctor p)
    => (forall a. HField t a -> p i (context a)) -> p i (t context)
  htabulateP f = unApplyP $ htraverse (ApplyP . getCompose) $ htabulate $ Compose . f
  {-# INLINABLE htabulateP #-}
  
  
  newtype ApplyP p a b = ApplyP { unApplyP :: p a b }
  
  
  instance Profunctor p => Functor (ApplyP p a) where
    fmap f = ApplyP . rmap f . unApplyP
  
  
  instance ProductProfunctor p => Apply (ApplyP p a) where
    ApplyP f <.> ApplyP x = ApplyP (rmap id f **** x)
  
  
  htraverseP :: (HTable t, ProductProfunctor p)
    => (forall a. p (f a) (g a)) -> p (t f) (t g)
  htraverseP f = htraversePWithField (const f)
  
  
  htraversePWithField :: (HTable t, ProductProfunctor p)
    => (forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)
  htraversePWithField f =
    htabulateP $ \field -> lmap (flip hfield field) (f field)
  
  
  type GHField :: K.HTable -> Type -> Type
  newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)
  
  
  type GHTable :: K.Context -> (Type -> Type) -> Constraint
  class HTable (GHColumns rep) => GHTable context rep | rep -> context where
    type GHColumns rep :: K.HTable
    toGHColumns :: rep x -> GHColumns rep context
    fromGHColumns :: GHColumns rep context -> rep x
  
  
  instance GHTable context rep => GHTable context (M1 i c rep) where
    type GHColumns (M1 i c rep) = GHColumns rep
    toGHColumns (M1 a) = toGHColumns a
    fromGHColumns = M1 . fromGHColumns
  
  
  instance HTable table => GHTable context (K1 i (table context)) where
    type GHColumns (K1 i (table context)) = table
    toGHColumns (K1 a) = a
    fromGHColumns = K1
  
  
  instance (GHTable context a, GHTable context b) => GHTable context (a :*: b) where
    type GHColumns (a :*: b) = HProduct (GHColumns a) (GHColumns b)
    toGHColumns (a :*: b) = HProduct (toGHColumns a) (toGHColumns b)
    fromGHColumns (HProduct a b) = fromGHColumns a :*: fromGHColumns b
  
  
  -- | A HField type for indexing into HProduct.
  type HProductField :: K.HTable -> K.HTable -> Type -> Type
  data HProductField x y a
    = HFst (HField x a)
    | HSnd (HField y a)
  
  
  instance (HTable x, HTable y) => HTable (HProduct x y) where
    type HConstrainTable (HProduct x y) c = (HConstrainTable x c, HConstrainTable y c)
    type HField (HProduct x y) = HProductField x y
  
    hfield (HProduct l r) = \case
      HFst i -> hfield l i
      HSnd i -> hfield r i
  
    htabulate f = HProduct (htabulate (f . HFst)) (htabulate (f . HSnd))
    htraverse f (HProduct x y) = HProduct <$> htraverse f x <.> htraverse f y
    hdicts = HProduct hdicts hdicts
    hspecs = HProduct hspecs hspecs
  
    {-# INLINABLE hfield #-}
    {-# INLINABLE htabulate #-}
    {-# INLINABLE htraverse #-}
    {-# INLINABLE hdicts #-}
    {-# INLINABLE hspecs #-}
  