{-# 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, htraverse, hdicts, hspecs
  , hmap, htabulateA
  )
where

-- base
import Data.Kind ( Constraint, Type )
import Data.Functor.Compose ( Compose( Compose ), getCompose )
import Data.Proxy ( Proxy )
import GHC.Generics
  ( (:*:)( (:*:) )
  , Generic (Rep, from, to)
  , K1( K1 )
  , M1( M1 )
  )
import Prelude

-- rel8
import Rel8.Schema.Dict ( Dict )
import Rel8.Schema.Spec ( Spec, SSpec )
import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
import qualified Rel8.Schema.Kind as K

-- semigroupoids
import Data.Functor.Apply ( Apply, (<.>) )


-- | 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 :: Spec -> Type) | field -> t
  type HConstrainTable t (c :: Spec -> Constraint) :: Constraint

  hfield :: t context -> HField t spec -> context spec
  htabulate :: (forall spec. HField t spec -> context spec) -> t context
  htraverse :: Apply m => (forall spec. f spec -> m (g spec)) -> t f -> m (t g)
  hdicts :: HConstrainTable t c => t (Dict c)
  hspecs :: t SSpec

  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 spec -> context spec
  hfield t context
table (GHField field) = GHColumns (Rep (t context)) context
-> HField (GHColumns (Rep (t context))) spec -> context spec
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield (Rep (t context) Any -> GHColumns (Rep (t context)) context
forall (context :: HContext) (rep :: * -> *) x.
GHTable context rep =>
rep x -> GHColumns rep context
toGHColumns (t context -> Rep (t context) Any
forall a x. Generic a => a -> Rep a x
from t context
table)) HField (GHColumns (Rep (t context))) spec
HField (GHColumns (Rep (t Proxy))) spec
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 spec. HField t spec -> context spec) -> t context
  htabulate forall (spec :: Spec). HField t spec -> context spec
f = Rep (t context) Any -> t context
forall a x. Generic a => Rep a x -> a
to (Rep (t context) Any -> t context)
-> Rep (t context) Any -> t context
forall a b. (a -> b) -> a -> b
$ GHColumns (Rep (t context)) context -> Rep (t context) Any
forall (context :: HContext) (rep :: * -> *) x.
GHTable context rep =>
GHColumns rep context -> rep x
fromGHColumns (GHColumns (Rep (t context)) context -> Rep (t context) Any)
-> GHColumns (Rep (t context)) context -> Rep (t context) Any
forall a b. (a -> b) -> a -> b
$ (forall (spec :: Spec).
 HField (GHColumns (Rep (t context))) spec -> context spec)
-> GHColumns (Rep (t context)) context
forall (t :: HTable) (context :: HContext).
HTable t =>
(forall (spec :: Spec). HField t spec -> context spec) -> t context
htabulate (GHField t spec -> context spec
forall (spec :: Spec). HField t spec -> context spec
f (GHField t spec -> context spec)
-> (HField (GHColumns (Rep (t context))) spec -> GHField t spec)
-> HField (GHColumns (Rep (t context))) spec
-> context spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HField (GHColumns (Rep (t context))) spec -> GHField t spec
forall (t :: HTable) (spec :: Spec).
HField (GHColumns (Rep (t Proxy))) spec -> GHField t spec
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 spec. f spec -> m (g spec)) -> t f -> m (t g)
  htraverse forall (spec :: Spec). f spec -> m (g spec)
f = (GHColumns (Rep (t g)) g -> t g)
-> m (GHColumns (Rep (t g)) g) -> m (t g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rep (t g) Any -> t g
forall a x. Generic a => Rep a x -> a
to (Rep (t g) Any -> t g)
-> (GHColumns (Rep (t g)) g -> Rep (t g) Any)
-> GHColumns (Rep (t g)) g
-> t g
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GHColumns (Rep (t g)) g -> Rep (t g) Any
forall (context :: HContext) (rep :: * -> *) x.
GHTable context rep =>
GHColumns rep context -> rep x
fromGHColumns) (m (GHColumns (Rep (t g)) g) -> m (t g))
-> (t f -> m (GHColumns (Rep (t g)) g)) -> t f -> m (t g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (spec :: Spec). f spec -> m (g spec))
-> GHColumns (Rep (t g)) f -> m (GHColumns (Rep (t g)) g)
forall (t :: HTable) (m :: * -> *) (f :: HContext) (g :: HContext).
(HTable t, Apply m) =>
(forall (spec :: Spec). f spec -> m (g spec)) -> t f -> m (t g)
htraverse forall (spec :: Spec). f spec -> m (g spec)
f (GHColumns (Rep (t g)) f -> m (GHColumns (Rep (t g)) g))
-> (t f -> GHColumns (Rep (t g)) f)
-> t f
-> m (GHColumns (Rep (t g)) g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep (t f) Any -> GHColumns (Rep (t g)) f
forall (context :: HContext) (rep :: * -> *) x.
GHTable context rep =>
rep x -> GHColumns rep context
toGHColumns (Rep (t f) Any -> GHColumns (Rep (t g)) f)
-> (t f -> Rep (t f) Any) -> t f -> GHColumns (Rep (t g)) f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t f -> Rep (t f) Any
forall a x. Generic a => a -> Rep a x
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 = Rep (t (Dict c)) Any -> t (Dict c)
forall a x. Generic a => Rep a x -> a
to (Rep (t (Dict c)) Any -> t (Dict c))
-> Rep (t (Dict c)) Any -> t (Dict c)
forall a b. (a -> b) -> a -> b
$ GHColumns (Rep (t (Dict c))) (Dict c) -> Rep (t (Dict c)) Any
forall (context :: HContext) (rep :: * -> *) x.
GHTable context rep =>
GHColumns rep context -> rep x
fromGHColumns (HConstrainTable (GHColumns (Rep (t Proxy))) c =>
GHColumns (Rep (t Proxy)) (Dict c)
forall (t :: HTable) (c :: Spec -> Constraint).
(HTable t, HConstrainTable t c) =>
t (Dict c)
hdicts @(GHColumns (Rep (t Proxy))) @c)

  default hspecs ::
    ( Generic (t SSpec)
    , GHTable SSpec (Rep (t SSpec))
    )
    => t SSpec
  hspecs = Rep (t SSpec) Any -> t SSpec
forall a x. Generic a => Rep a x -> a
to (Rep (t SSpec) Any -> t SSpec) -> Rep (t SSpec) Any -> t SSpec
forall a b. (a -> b) -> a -> b
$ GHColumns (Rep (t SSpec)) SSpec -> Rep (t SSpec) Any
forall (context :: HContext) (rep :: * -> *) x.
GHTable context rep =>
GHColumns rep context -> rep x
fromGHColumns GHColumns (Rep (t SSpec)) SSpec
forall (t :: HTable). HTable t => t SSpec
hspecs

  {-# INLINABLE hfield #-}
  {-# INLINABLE htabulate #-}
  {-# INLINABLE htraverse #-}
  {-# INLINABLE hdicts #-}
  {-# INLINABLE hspecs #-}


hmap :: HTable t
  => (forall spec. context spec -> context' spec) -> t context -> t context'
hmap :: (forall (spec :: Spec). context spec -> context' spec)
-> t context -> t context'
hmap forall (spec :: Spec). context spec -> context' spec
f t context
a = (forall (spec :: Spec). HField t spec -> context' spec)
-> t context'
forall (t :: HTable) (context :: HContext).
HTable t =>
(forall (spec :: Spec). HField t spec -> context spec) -> t context
htabulate ((forall (spec :: Spec). HField t spec -> context' spec)
 -> t context')
-> (forall (spec :: Spec). HField t spec -> context' spec)
-> t context'
forall a b. (a -> b) -> a -> b
$ \HField t spec
field -> context spec -> context' spec
forall (spec :: Spec). context spec -> context' spec
f (t context -> HField t spec -> context spec
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield t context
a HField t spec
field)


htabulateA :: (HTable t, Apply m)
  => (forall spec. HField t spec -> m (context spec)) -> m (t context)
htabulateA :: (forall (spec :: Spec). HField t spec -> m (context spec))
-> m (t context)
htabulateA forall (spec :: Spec). HField t spec -> m (context spec)
f = (forall (spec :: Spec). Compose m context spec -> m (context spec))
-> t (Compose m context) -> m (t context)
forall (t :: HTable) (m :: * -> *) (f :: HContext) (g :: HContext).
(HTable t, Apply m) =>
(forall (spec :: Spec). f spec -> m (g spec)) -> t f -> m (t g)
htraverse forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
forall (spec :: Spec). Compose m context spec -> m (context spec)
getCompose (t (Compose m context) -> m (t context))
-> t (Compose m context) -> m (t context)
forall a b. (a -> b) -> a -> b
$ (forall (spec :: Spec). HField t spec -> Compose m context spec)
-> t (Compose m context)
forall (t :: HTable) (context :: HContext).
HTable t =>
(forall (spec :: Spec). HField t spec -> context spec) -> t context
htabulate ((forall (spec :: Spec). HField t spec -> Compose m context spec)
 -> t (Compose m context))
-> (forall (spec :: Spec). HField t spec -> Compose m context spec)
-> t (Compose m context)
forall a b. (a -> b) -> a -> b
$ m (context spec) -> Compose m context spec
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (m (context spec) -> Compose m context spec)
-> (HField t spec -> m (context spec))
-> HField t spec
-> Compose m context spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HField t spec -> m (context spec)
forall (spec :: Spec). HField t spec -> m (context spec)
f
{-# INLINABLE htabulateA #-}


type GHField :: K.HTable -> Spec -> Type
newtype GHField t spec = GHField (HField (GHColumns (Rep (t Proxy))) spec)


type GHTable :: K.HContext -> (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 i c rep x -> GHColumns (M1 i c rep) context
toGHColumns (M1 rep x
a) = rep x -> GHColumns rep context
forall (context :: HContext) (rep :: * -> *) x.
GHTable context rep =>
rep x -> GHColumns rep context
toGHColumns rep x
a
  fromGHColumns :: GHColumns (M1 i c rep) context -> M1 i c rep x
fromGHColumns = rep x -> M1 i c rep x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (rep x -> M1 i c rep x)
-> (GHColumns rep context -> rep x)
-> GHColumns rep context
-> M1 i c rep x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GHColumns rep context -> rep x
forall (context :: HContext) (rep :: * -> *) x.
GHTable context rep =>
GHColumns rep context -> rep x
fromGHColumns


instance HTable table => GHTable context (K1 i (table context)) where
  type GHColumns (K1 i (table context)) = table
  toGHColumns :: K1 i (table context) x -> GHColumns (K1 i (table context)) context
toGHColumns (K1 table context
a) = table context
GHColumns (K1 i (table context)) context
a
  fromGHColumns :: GHColumns (K1 i (table context)) context -> K1 i (table context) x
fromGHColumns = GHColumns (K1 i (table context)) context -> K1 i (table context) x
forall k i c (p :: k). c -> K1 i c p
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 x -> GHColumns (a :*: b) context
toGHColumns (a x
a :*: b x
b) = GHColumns a context
-> GHColumns b context
-> HProduct (GHColumns a) (GHColumns b) context
forall (a :: HTable) (b :: HTable) (context :: HContext).
a context -> b context -> HProduct a b context
HProduct (a x -> GHColumns a context
forall (context :: HContext) (rep :: * -> *) x.
GHTable context rep =>
rep x -> GHColumns rep context
toGHColumns a x
a) (b x -> GHColumns b context
forall (context :: HContext) (rep :: * -> *) x.
GHTable context rep =>
rep x -> GHColumns rep context
toGHColumns b x
b)
  fromGHColumns :: GHColumns (a :*: b) context -> (:*:) a b x
fromGHColumns (HProduct a b) = GHColumns a context -> a x
forall (context :: HContext) (rep :: * -> *) x.
GHTable context rep =>
GHColumns rep context -> rep x
fromGHColumns GHColumns a context
a a x -> b x -> (:*:) a b x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: GHColumns b context -> b x
forall (context :: HContext) (rep :: * -> *) x.
GHTable context rep =>
GHColumns rep context -> rep x
fromGHColumns GHColumns b context
b


-- | A HField type for indexing into HProduct.
type HProductField :: K.HTable -> K.HTable -> Spec -> Type
data HProductField x y spec
  = HFst (HField x spec)
  | HSnd (HField y spec)


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 x y context -> HField (HProduct x y) spec -> context spec
hfield (HProduct x context
l y context
r) = \case
    HFst i -> x context -> HField x spec -> context spec
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield x context
l HField x spec
i
    HSnd i -> y context -> HField y spec -> context spec
forall (t :: HTable) (context :: HContext) (spec :: Spec).
HTable t =>
t context -> HField t spec -> context spec
hfield y context
r HField y spec
i

  htabulate :: (forall (spec :: Spec). HField (HProduct x y) spec -> context spec)
-> HProduct x y context
htabulate forall (spec :: Spec). HField (HProduct x y) spec -> context spec
f = x context -> y context -> HProduct x y context
forall (a :: HTable) (b :: HTable) (context :: HContext).
a context -> b context -> HProduct a b context
HProduct ((forall (spec :: Spec). HField x spec -> context spec) -> x context
forall (t :: HTable) (context :: HContext).
HTable t =>
(forall (spec :: Spec). HField t spec -> context spec) -> t context
htabulate (HProductField x y spec -> context spec
forall (spec :: Spec). HField (HProduct x y) spec -> context spec
f (HProductField x y spec -> context spec)
-> (HField x spec -> HProductField x y spec)
-> HField x spec
-> context spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HField x spec -> HProductField x y spec
forall (x :: HTable) (y :: HTable) (spec :: Spec).
HField x spec -> HProductField x y spec
HFst)) ((forall (spec :: Spec). HField y spec -> context spec) -> y context
forall (t :: HTable) (context :: HContext).
HTable t =>
(forall (spec :: Spec). HField t spec -> context spec) -> t context
htabulate (HProductField x y spec -> context spec
forall (spec :: Spec). HField (HProduct x y) spec -> context spec
f (HProductField x y spec -> context spec)
-> (HField y spec -> HProductField x y spec)
-> HField y spec
-> context spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HField y spec -> HProductField x y spec
forall (x :: HTable) (y :: HTable) (spec :: Spec).
HField y spec -> HProductField x y spec
HSnd))
  htraverse :: (forall (spec :: Spec). f spec -> m (g spec))
-> HProduct x y f -> m (HProduct x y g)
htraverse forall (spec :: Spec). f spec -> m (g spec)
f (HProduct x f
x y f
y) = x g -> y g -> HProduct x y g
forall (a :: HTable) (b :: HTable) (context :: HContext).
a context -> b context -> HProduct a b context
HProduct (x g -> y g -> HProduct x y g)
-> m (x g) -> m (y g -> HProduct x y g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (spec :: Spec). f spec -> m (g spec)) -> x f -> m (x g)
forall (t :: HTable) (m :: * -> *) (f :: HContext) (g :: HContext).
(HTable t, Apply m) =>
(forall (spec :: Spec). f spec -> m (g spec)) -> t f -> m (t g)
htraverse forall (spec :: Spec). f spec -> m (g spec)
f x f
x m (y g -> HProduct x y g) -> m (y g) -> m (HProduct x y g)
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
<.> (forall (spec :: Spec). f spec -> m (g spec)) -> y f -> m (y g)
forall (t :: HTable) (m :: * -> *) (f :: HContext) (g :: HContext).
(HTable t, Apply m) =>
(forall (spec :: Spec). f spec -> m (g spec)) -> t f -> m (t g)
htraverse forall (spec :: Spec). f spec -> m (g spec)
f y f
y
  hdicts :: HProduct x y (Dict c)
hdicts = x (Dict c) -> y (Dict c) -> HProduct x y (Dict c)
forall (a :: HTable) (b :: HTable) (context :: HContext).
a context -> b context -> HProduct a b context
HProduct x (Dict c)
forall (t :: HTable) (c :: Spec -> Constraint).
(HTable t, HConstrainTable t c) =>
t (Dict c)
hdicts y (Dict c)
forall (t :: HTable) (c :: Spec -> Constraint).
(HTable t, HConstrainTable t c) =>
t (Dict c)
hdicts
  hspecs :: HProduct x y SSpec
hspecs = x SSpec -> y SSpec -> HProduct x y SSpec
forall (a :: HTable) (b :: HTable) (context :: HContext).
a context -> b context -> HProduct a b context
HProduct x SSpec
forall (t :: HTable). HTable t => t SSpec
hspecs y SSpec
forall (t :: HTable). HTable t => t SSpec
hspecs

  {-# INLINABLE hfield #-}
  {-# INLINABLE htabulate #-}
  {-# INLINABLE htraverse #-}
  {-# INLINABLE hdicts #-}
  {-# INLINABLE hspecs #-}