{-# language AllowAmbiguousTypes #-}
{-# language BlockArguments #-}
{-# language DataKinds #-}
{-# language FlexibleInstances #-}
{-# language MultiParamTypeClasses #-}
{-# language RankNTypes #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}

module Rel8.Generic.Construction.Record
  ( GConstructor, GConstruct, GConstructable, gconstruct, gdeconstruct
  , GFields, Representable, gtabulate, gindex
  , FromColumns, ToColumns
  )
where

-- base
import Data.Kind ( Constraint, Type )
import Data.Proxy ( Proxy( Proxy ) )
import GHC.Generics
  ( (:*:), K1, M1, U1
  , D, C, S, Meta( MetaData, MetaCons, MetaSel )
  )
import GHC.TypeLits
  ( ErrorMessage( (:<>:), Text ), TypeError
  , Symbol, KnownSymbol
  )
import Prelude

-- rel8
import Rel8.FCF ( Eval, Exp )
import Rel8.Generic.Table.Record ( GColumns )
import Rel8.Schema.Context.Label ( HLabelable, hlabeler, hunlabeler )
import Rel8.Schema.HTable ( HTable )
import Rel8.Schema.HTable.Label ( hlabel, hunlabel )
import Rel8.Schema.HTable.Product ( HProduct( HProduct ) )
import qualified Rel8.Schema.Kind as K


type FromColumns
  :: (Type -> Exp Constraint)
  -> (Type -> Exp K.HTable)
  -> (Type -> Exp Type)
  -> K.HContext
  -> Type
type FromColumns _Table _Columns f context = forall proxy x.
  Eval (_Table x) => proxy x -> Eval (_Columns x) context -> Eval (f x)


type ToColumns
  :: (Type -> Exp Constraint)
  -> (Type -> Exp K.HTable)
  -> (Type -> Exp Type)
  -> K.HContext
  -> Type
type ToColumns _Table _Columns f context = forall proxy x.
  Eval (_Table x) => proxy x -> Eval (f x) -> Eval (_Columns x) context


type GConstructor :: (Type -> Type) -> Symbol
type family GConstructor rep where
  GConstructor (M1 D _ (M1 C ('MetaCons name _ _) _)) = name
  GConstructor (M1 D ('MetaData name _ _ _) _) = TypeError (
    'Text "`" ':<>:
    'Text name ':<>:
    'Text "` does not appear to have exactly 1 constructor"
   )


type GConstruct :: (Type -> Exp Type) -> (Type -> Type) -> Type -> Type
type family GConstruct f rep r where
  GConstruct f (M1 _ _ rep) r = GConstruct f rep r
  GConstruct f (a :*: b) r = GConstruct f a (GConstruct f b r)
  GConstruct _ U1 r = r
  GConstruct f (K1 _ a) r = Eval (f a) -> r


type GFields :: (Type -> Exp Type) -> (Type -> Type) -> Type
type family GFields f rep where
  GFields f (M1 _ _ rep) = GFields f rep
  GFields f (a :*: b) = (GFields f a, GFields f b)
  GFields _ U1 = ()
  GFields f (K1 _ a) = Eval (f a)


type Representable :: (Type -> Exp Type) -> (Type -> Type) -> Constraint
class Representable f rep where
  gtabulate :: (GFields f rep -> a) -> GConstruct f rep a
  gindex :: GConstruct f rep a -> GFields f rep -> a


instance Representable f rep => Representable f (M1 i meta rep) where
  gtabulate :: (GFields f (M1 i meta rep) -> a) -> GConstruct f (M1 i meta rep) a
gtabulate = forall a.
Representable f rep =>
(GFields f rep -> a) -> GConstruct f rep a
forall (f :: * -> Exp *) (rep :: Exp *) a.
Representable f rep =>
(GFields f rep -> a) -> GConstruct f rep a
gtabulate @f @rep
  gindex :: GConstruct f (M1 i meta rep) a -> GFields f (M1 i meta rep) -> a
gindex = forall a.
Representable f rep =>
GConstruct f rep a -> GFields f rep -> a
forall (f :: * -> Exp *) (rep :: Exp *) a.
Representable f rep =>
GConstruct f rep a -> GFields f rep -> a
gindex @f @rep


instance (Representable f a, Representable f b) =>
  Representable f (a :*: b)
 where
  gtabulate :: (GFields f (a :*: b) -> a) -> GConstruct f (a :*: b) a
gtabulate GFields f (a :*: b) -> a
f = (GFields f a -> GConstruct f b a)
-> GConstruct f a (GConstruct f b a)
forall (f :: * -> Exp *) (rep :: Exp *) a.
Representable f rep =>
(GFields f rep -> a) -> GConstruct f rep a
gtabulate @f @a \GFields f a
a -> (GFields f b -> a) -> GConstruct f b a
forall (f :: * -> Exp *) (rep :: Exp *) a.
Representable f rep =>
(GFields f rep -> a) -> GConstruct f rep a
gtabulate @f @b \GFields f b
b -> GFields f (a :*: b) -> a
f (GFields f a
a, GFields f b
b)
  gindex :: GConstruct f (a :*: b) a -> GFields f (a :*: b) -> a
gindex GConstruct f (a :*: b) a
f (a, b) = GConstruct f b a -> GFields f b -> a
forall (f :: * -> Exp *) (rep :: Exp *) a.
Representable f rep =>
GConstruct f rep a -> GFields f rep -> a
gindex @f @b (GConstruct f a (GConstruct f b a)
-> GFields f a -> GConstruct f b a
forall (f :: * -> Exp *) (rep :: Exp *) a.
Representable f rep =>
GConstruct f rep a -> GFields f rep -> a
gindex @f @a GConstruct f a (GConstruct f b a)
GConstruct f (a :*: b) a
f GFields f a
a) GFields f b
b


instance Representable f U1 where
  gtabulate :: (GFields f U1 -> a) -> GConstruct f U1 a
gtabulate = ((() -> a) -> () -> a
forall a b. (a -> b) -> a -> b
$ ())
  gindex :: GConstruct f U1 a -> GFields f U1 -> a
gindex = GConstruct f U1 a -> GFields f U1 -> a
forall a b. a -> b -> a
const


instance Representable f (K1 i a) where
  gtabulate :: (GFields f (K1 i a) -> a) -> GConstruct f (K1 i a) a
gtabulate = (GFields f (K1 i a) -> a) -> GConstruct f (K1 i a) a
forall a. a -> a
id
  gindex :: GConstruct f (K1 i a) a -> GFields f (K1 i a) -> a
gindex = GConstruct f (K1 i a) a -> GFields f (K1 i a) -> a
forall a. a -> a
id


type GConstructable
  :: (Type -> Exp Constraint)
  -> (Type -> Exp K.HTable)
  -> (Type -> Exp Type)
  -> K.HContext -> (Type -> Type) -> Constraint
class GConstructable _Table _Columns f context rep where
  gconstruct :: ()
    => ToColumns _Table _Columns f context
    -> GFields f rep
    -> GColumns _Columns rep context
  gdeconstruct :: ()
    => FromColumns _Table _Columns f context
    -> GColumns _Columns rep context
    -> GFields f rep


instance (GConstructable _Table _Columns f context rep) =>
  GConstructable _Table _Columns f context (M1 D meta rep)
 where
  gconstruct :: ToColumns _Table _Columns f context
-> GFields f (M1 D meta rep)
-> GColumns _Columns (M1 D meta rep) context
gconstruct = GConstructable _Table _Columns f context rep =>
ToColumns _Table _Columns f context
-> GFields f rep -> GColumns _Columns rep context
forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp HTable) (f :: * -> Exp *)
       (context :: HContext) (rep :: Exp *).
GConstructable _Table _Columns f context rep =>
ToColumns _Table _Columns f context
-> GFields f rep -> GColumns _Columns rep context
gconstruct @_Table @_Columns @f @context @rep
  gdeconstruct :: FromColumns _Table _Columns f context
-> GColumns _Columns (M1 D meta rep) context
-> GFields f (M1 D meta rep)
gdeconstruct = GConstructable _Table _Columns f context rep =>
FromColumns _Table _Columns f context
-> GColumns _Columns rep context -> GFields f rep
forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp HTable) (f :: * -> Exp *)
       (context :: HContext) (rep :: Exp *).
GConstructable _Table _Columns f context rep =>
FromColumns _Table _Columns f context
-> GColumns _Columns rep context -> GFields f rep
gdeconstruct @_Table @_Columns @f @context @rep


instance (GConstructable _Table _Columns f context rep) =>
  GConstructable _Table _Columns f context (M1 C meta rep)
 where
  gconstruct :: ToColumns _Table _Columns f context
-> GFields f (M1 C meta rep)
-> GColumns _Columns (M1 C meta rep) context
gconstruct = GConstructable _Table _Columns f context rep =>
ToColumns _Table _Columns f context
-> GFields f rep -> GColumns _Columns rep context
forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp HTable) (f :: * -> Exp *)
       (context :: HContext) (rep :: Exp *).
GConstructable _Table _Columns f context rep =>
ToColumns _Table _Columns f context
-> GFields f rep -> GColumns _Columns rep context
gconstruct @_Table @_Columns @f @context @rep
  gdeconstruct :: FromColumns _Table _Columns f context
-> GColumns _Columns (M1 C meta rep) context
-> GFields f (M1 C meta rep)
gdeconstruct = GConstructable _Table _Columns f context rep =>
FromColumns _Table _Columns f context
-> GColumns _Columns rep context -> GFields f rep
forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp HTable) (f :: * -> Exp *)
       (context :: HContext) (rep :: Exp *).
GConstructable _Table _Columns f context rep =>
FromColumns _Table _Columns f context
-> GColumns _Columns rep context -> GFields f rep
gdeconstruct @_Table @_Columns @f @context @rep


instance
  ( GConstructable _Table _Columns f context a
  , GConstructable _Table _Columns f context b
  )
  => GConstructable _Table _Columns f context (a :*: b)
 where
  gconstruct :: ToColumns _Table _Columns f context
-> GFields f (a :*: b) -> GColumns _Columns (a :*: b) context
gconstruct ToColumns _Table _Columns f context
toColumns (a, b) = GColumns _Columns a context
-> GColumns _Columns b context
-> HProduct (GColumns _Columns a) (GColumns _Columns b) context
forall (a :: HTable) (b :: HTable) (context :: HContext).
a context -> b context -> HProduct a b context
HProduct
    (ToColumns _Table _Columns f context
-> GFields f a -> GColumns _Columns a context
forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp HTable) (f :: * -> Exp *)
       (context :: HContext) (rep :: Exp *).
GConstructable _Table _Columns f context rep =>
ToColumns _Table _Columns f context
-> GFields f rep -> GColumns _Columns rep context
gconstruct @_Table @_Columns @f @context @a ToColumns _Table _Columns f context
toColumns GFields f a
a)
    (ToColumns _Table _Columns f context
-> GFields f b -> GColumns _Columns b context
forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp HTable) (f :: * -> Exp *)
       (context :: HContext) (rep :: Exp *).
GConstructable _Table _Columns f context rep =>
ToColumns _Table _Columns f context
-> GFields f rep -> GColumns _Columns rep context
gconstruct @_Table @_Columns @f @context @b ToColumns _Table _Columns f context
toColumns GFields f b
b)
  gdeconstruct :: FromColumns _Table _Columns f context
-> GColumns _Columns (a :*: b) context -> GFields f (a :*: b)
gdeconstruct FromColumns _Table _Columns f context
fromColumns (HProduct a b) =
    ( FromColumns _Table _Columns f context
-> GColumns _Columns a context -> GFields f a
forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp HTable) (f :: * -> Exp *)
       (context :: HContext) (rep :: Exp *).
GConstructable _Table _Columns f context rep =>
FromColumns _Table _Columns f context
-> GColumns _Columns rep context -> GFields f rep
gdeconstruct @_Table @_Columns @f @context @a FromColumns _Table _Columns f context
fromColumns GColumns _Columns a context
a
    , FromColumns _Table _Columns f context
-> GColumns _Columns b context -> GFields f b
forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp HTable) (f :: * -> Exp *)
       (context :: HContext) (rep :: Exp *).
GConstructable _Table _Columns f context rep =>
FromColumns _Table _Columns f context
-> GColumns _Columns rep context -> GFields f rep
gdeconstruct @_Table @_Columns @f @context @b FromColumns _Table _Columns f context
fromColumns GColumns _Columns b context
b
    )


instance
  ( Eval (_Table a)
  , HTable (Eval (_Columns a))
  , HLabelable context
  , KnownSymbol label
  , meta ~ 'MetaSel ('Just label) _su _ss _ds
  )
  => GConstructable _Table _Columns f context (M1 S meta (K1 i a))
 where
  gconstruct :: ToColumns _Table _Columns f context
-> GFields f (M1 S meta (K1 i a))
-> GColumns _Columns (M1 S meta (K1 i a)) context
gconstruct ToColumns _Table _Columns f context
toColumns = (forall (labels :: Labels) (necessity :: Necessity) a.
 context ('Spec labels necessity a)
 -> context ('Spec (label : labels) necessity a))
-> Eval (_Columns a) context
-> HLabel label (Eval (_Columns a)) context
forall (t :: HTable) (label :: Symbol) (context :: HContext).
(HTable t, KnownSymbol label) =>
(forall (labels :: Labels) (necessity :: Necessity) a.
 context ('Spec labels necessity a)
 -> context ('Spec (label : labels) necessity a))
-> t context -> HLabel label t context
hlabel forall (labels :: Labels) (necessity :: Necessity) a.
context ('Spec labels necessity a)
-> context ('Spec (label : labels) necessity a)
forall (context :: HContext) (labels :: Labels)
       (necessity :: Necessity) a (label :: Symbol).
HLabelable context =>
context ('Spec labels necessity a)
-> context ('Spec (label : labels) necessity a)
hlabeler (Eval (_Columns a) context
 -> HLabel label (Eval (_Columns a)) context)
-> (Eval (f a) -> Eval (_Columns a) context)
-> Eval (f a)
-> HLabel label (Eval (_Columns a)) context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> Eval (f a) -> Eval (_Columns a) context
ToColumns _Table _Columns f context
toColumns (Proxy a
forall k (t :: k). Proxy t
Proxy @a)
  gdeconstruct :: FromColumns _Table _Columns f context
-> GColumns _Columns (M1 S meta (K1 i a)) context
-> GFields f (M1 S meta (K1 i a))
gdeconstruct FromColumns _Table _Columns f context
fromColumns = Proxy a -> Eval (_Columns a) context -> Eval (f a)
FromColumns _Table _Columns f context
fromColumns (Proxy a
forall k (t :: k). Proxy t
Proxy @a) (Eval (_Columns a) context -> Eval (f a))
-> (HLabel label (Eval (_Columns a)) context
    -> Eval (_Columns a) context)
-> HLabel label (Eval (_Columns a)) context
-> Eval (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (labels :: Labels) (necessity :: Necessity) a.
 context ('Spec (label : labels) necessity a)
 -> context ('Spec labels necessity a))
-> HLabel label (Eval (_Columns a)) context
-> Eval (_Columns a) context
forall (t :: HTable) (label :: Symbol) (context :: HContext).
(HTable t, KnownSymbol label) =>
(forall (labels :: Labels) (necessity :: Necessity) a.
 context ('Spec (label : labels) necessity a)
 -> context ('Spec labels necessity a))
-> HLabel label t context -> t context
hunlabel forall (labels :: Labels) (necessity :: Necessity) a.
context ('Spec (label : labels) necessity a)
-> context ('Spec labels necessity a)
forall (context :: HContext) (label :: Symbol) (labels :: Labels)
       (necessity :: Necessity) a.
HLabelable context =>
context ('Spec (label : labels) necessity a)
-> context ('Spec labels necessity a)
hunlabeler