content: {-# 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
    )
  import Prelude
  
  -- rel8
  import Rel8.FCF ( Eval, Exp )
  import Rel8.Generic.Table.Record ( GColumns )
  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.Context
    -> 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.Context
    -> 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 = gtabulate @f @rep
    gindex = gindex @f @rep
  
  
  instance (Representable f a, Representable f b) =>
    Representable f (a :*: b)
   where
    gtabulate f = gtabulate @f @a \a -> gtabulate @f @b \b -> f (a, b)
    gindex f (a, b) = gindex @f @b (gindex @f @a f a) b
  
  
  instance Representable f U1 where
    gtabulate = ($ ())
    gindex = const
  
  
  instance Representable f (K1 i a) where
    gtabulate = id
    gindex = id
  
  
  type GConstructable
    :: (Type -> Exp Constraint)
    -> (Type -> Exp K.HTable)
    -> (Type -> Exp Type)
    -> K.Context -> (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 = gconstruct @_Table @_Columns @f @context @rep
    gdeconstruct = gdeconstruct @_Table @_Columns @f @context @rep
  
  
  instance (GConstructable _Table _Columns f context rep) =>
    GConstructable _Table _Columns f context (M1 C meta rep)
   where
    gconstruct = gconstruct @_Table @_Columns @f @context @rep
    gdeconstruct = 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 (a, b) = HProduct
      (gconstruct @_Table @_Columns @f @context @a toColumns a)
      (gconstruct @_Table @_Columns @f @context @b toColumns b)
    gdeconstruct fromColumns (HProduct a b) =
      ( gdeconstruct @_Table @_Columns @f @context @a fromColumns a
      , gdeconstruct @_Table @_Columns @f @context @b fromColumns b
      )
  
  
  instance
    ( Eval (_Table a)
    , meta ~ 'MetaSel ('Just label) _su _ss _ds
    )
    => GConstructable _Table _Columns f context (M1 S meta (K1 i a))
   where
    gconstruct toColumns = hlabel . toColumns (Proxy @a)
    gdeconstruct fromColumns = fromColumns (Proxy @a) . hunlabel
  