{-# 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 )
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 :: 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 t context
table (GHField field) = GHColumns (Rep (t context)) context
-> HField (GHColumns (Rep (t context))) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield (Rep (t context) Any -> GHColumns (Rep (t context)) context
forall (context :: Context) (rep :: Context) 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))) a
HField (GHColumns (Rep (t Proxy))) a
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 forall a. HField t a -> context a
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 :: Context) (rep :: Context) 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 a. HField (GHColumns (Rep (t context))) a -> context a)
-> GHColumns (Rep (t context)) context
forall (t :: HTable) (context :: Context).
HTable t =>
(forall a. HField t a -> context a) -> t context
htabulate (GHField t a -> context a
forall a. HField t a -> context a
f (GHField t a -> context a)
-> (HField (GHColumns (Rep (t context))) a -> GHField t a)
-> HField (GHColumns (Rep (t context))) a
-> context a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HField (GHColumns (Rep (t context))) a -> GHField t a
forall (t :: HTable) a.
HField (GHColumns (Rep (t Proxy))) a -> GHField t a
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 forall a. f a -> m (g a)
f = (GHColumns (Rep (t g)) g -> t g)
-> m (GHColumns (Rep (t g)) g) -> m (t g)
forall (f :: Context) 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 :: Context) (rep :: Context) 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 a. f a -> m (g a))
-> GHColumns (Rep (t g)) f -> m (GHColumns (Rep (t g)) g)
forall (t :: HTable) (m :: Context) (f :: Context) (g :: Context).
(HTable t, Apply m) =>
(forall a. f a -> m (g a)) -> t f -> m (t g)
htraverse forall a. f a -> m (g a)
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 :: Context) (rep :: Context) 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 :: Context) (rep :: Context) 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 :: * -> Constraint).
(HTable t, HConstrainTable t c) =>
t (Dict c)
hdicts @(GHColumns (Rep (t Proxy))) @c)

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

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


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


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


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 i c rep x -> GHColumns (M1 i c rep) context
toGHColumns (M1 rep x
a) = rep x -> GHColumns rep context
forall (context :: Context) (rep :: Context) 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 :: Context) (rep :: Context) 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 :: Context).
a context -> b context -> HProduct a b context
HProduct (a x -> GHColumns a context
forall (context :: Context) (rep :: Context) x.
GHTable context rep =>
rep x -> GHColumns rep context
toGHColumns a x
a) (b x -> GHColumns b context
forall (context :: Context) (rep :: Context) 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 :: Context) (rep :: Context) 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 :: Context) (rep :: Context) 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 -> 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 x y context -> HField (HProduct x y) a -> context a
hfield (HProduct x context
l y context
r) = \case
    HFst i -> x context -> HField x a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield x context
l HField x a
i
    HSnd i -> y context -> HField y a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield y context
r HField y a
i

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

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