{-# language ConstraintKinds #-}
{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language MultiParamTypeClasses #-}
{-# language QuantifiedConstraints #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}

module Rel8.Table.Lifted
  ( Table1( Columns1, ConstrainHContext1, toColumns1, fromColumns1 )
  , Table2( Columns2, ConstrainHContext2, toColumns2, fromColumns2 )
  , ConstrainContext
  )
where

-- base
import Data.Kind ( Constraint, Type )
import Prelude ()

-- rel8
import Rel8.Schema.Context ( Col )
import Rel8.Schema.HTable ( HTable )
import Rel8.Schema.HTable.Pair
import qualified Rel8.Schema.Kind as K


type Table1 :: (Type -> Type) -> Constraint
class Table1 f where
  type Columns1 f :: K.HTable -> K.HTable
  type ConstrainHContext1 f :: K.HContext -> Constraint
  type ConstrainHContext1 _ = DefaultConstrainContext

  toColumns1 :: (ConstrainHContext1 f context, HTable t)
    => (a -> t context)
    -> f a
    -> Columns1 f t context

  fromColumns1 :: (ConstrainHContext1 f context, HTable t)
    => (t context -> a)
    -> Columns1 f t context
    -> f a


type Table2 :: (Type -> Type -> Type) -> Constraint
class Table2 p where
  type Columns2 p :: K.HTable -> K.HTable -> K.HTable
  type ConstrainHContext2 p :: K.HContext -> Constraint
  type ConstrainHContext2 _ = DefaultConstrainContext

  toColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u)
    => (a -> t context)
    -> (b -> u context)
    -> p a b
    -> Columns2 p t u context

  fromColumns2 :: (ConstrainHContext2 p context, HTable t, HTable u)
    => (t context -> a)
    -> (u context -> b)
    -> Columns2 p t u context
    -> p a b


instance Table2 (,) where
  type Columns2 (,) = HPair

  toColumns2 :: forall (context :: HContext) (t :: HTable) (u :: HTable) a b.
(ConstrainHContext2 (,) context, HTable t, HTable u) =>
(a -> t context)
-> (b -> u context) -> (a, b) -> Columns2 (,) t u context
toColumns2 a -> t context
f b -> u context
g (a
a, b
b) = t context -> u context -> HPair t u context
forall (fst :: HTable) (snd :: HTable) (context :: HContext).
fst context -> snd context -> HPair fst snd context
HPair (a -> t context
f a
a) (b -> u context
g b
b)
  fromColumns2 :: forall (context :: HContext) (t :: HTable) (u :: HTable) a b.
(ConstrainHContext2 (,) context, HTable t, HTable u) =>
(t context -> a)
-> (u context -> b) -> Columns2 (,) t u context -> (a, b)
fromColumns2 t context -> a
f u context -> b
g (HPair t context
a u context
b) = (t context -> a
f t context
a, u context -> b
g u context
b)


type DefaultConstrainContext :: K.HContext -> Constraint
class DefaultConstrainContext context
instance DefaultConstrainContext context


type ConstrainContext :: (K.Context -> Constraint) -> K.HContext -> Constraint
class (forall context. hcontext ~ Col context => constraint context)
  => ConstrainContext constraint hcontext
instance (hcontext ~ Col context, constraint context) =>
  ConstrainContext constraint hcontext