{-# language AllowAmbiguousTypes #-}
{-# language ConstraintKinds #-}
{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
{-# language ViewPatterns #-}

module Rel8.Generic.Construction
  ( GGBuildable
  , GGBuild, ggbuild
  , GGConstructable
  , GGConstruct, ggconstruct
  , GGDeconstruct, ggdeconstruct, ggdeconstructA
  , GGName, ggname
  )
where

-- base
import Data.Bifunctor ( first )
import Data.Functor ((<&>))
import Data.Kind ( Constraint, Type )
import Data.List.NonEmpty ( NonEmpty( (:|) ) )
import GHC.TypeLits ( Symbol )
import Prelude

-- rel8
import Rel8.Expr ( Expr )
import Rel8.Expr.Eq ( (==.) )
import Rel8.Expr.Null ( nullify, snull, unsafeUnnullify )
import Rel8.Expr.Serialize ( litExpr )
import Rel8.FCF ( Eval, Exp, Id )
import Rel8.Generic.Construction.ADT
  ( GConstructorADT, GMakeableADT, gmakeADT
  , GConstructableADT
  , GBuildADT, gbuildADT
  , GConstructADT, gconstructADT, gdeconstructADT
  , RepresentableConstructors, GConstructors, gcindex, gctabulate
  , RepresentableFields, gftabulate
  )
import Rel8.Generic.Construction.Record
  ( GConstructor
  , GConstructable, GConstruct, gconstruct, gdeconstruct
  , Representable, gindex, gtabulate
  )
import Rel8.Generic.Table ( GGColumns )
import Rel8.Kind.Algebra
  ( SAlgebra( SProduct, SSum )
  , KnownAlgebra, algebraSing
  )
import qualified Rel8.Kind.Algebra as K
import Rel8.Schema.HTable ( HTable )
import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
import qualified Rel8.Schema.Kind as K
import Rel8.Schema.Name ( Name( Name ) )
import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
import Rel8.Schema.Spec ( Spec( Spec, nullity, info ) )
import Rel8.Table
  ( TTable, TColumns
  , Table, fromColumns, toColumns
  )
import Rel8.Table.Bool ( case_ )
import Rel8.Type.Tag ( Tag )

-- semigroupoids
import Data.Functor.Apply (Apply)
import Data.Semigroup.Traversable (sequence1, traverse1)


type GGBuildable :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint
type GGBuildable algebra name rep =
  ( KnownAlgebra algebra
  , Eval (GGColumns algebra TColumns (Eval (rep Expr))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
  , Eval (GGColumns algebra TColumns (Eval (rep Name))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
  , HTable (Eval (GGColumns algebra TColumns (Eval (rep Expr))))
  , GGBuildable' algebra name rep
  )


type GGBuildable' :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint
type family GGBuildable' algebra name rep where
  GGBuildable' 'K.Product name rep =
    ( name ~ GConstructor (Eval (rep Expr))
    , Representable Id (Eval (rep Expr))
    , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))
    )
  GGBuildable' 'K.Sum name rep =
    ( Representable Id (GConstructorADT name (Eval (rep Expr)))
    , GMakeableADT (TTable Expr) TColumns Id Expr name (Eval (rep Expr))
    )


type GGBuild :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
type family GGBuild algebra name rep r where
  GGBuild 'K.Product _name rep r =
    GConstruct Id (Eval (rep Expr)) r
  GGBuild 'K.Sum name rep r =
    GConstruct Id (GConstructorADT name (Eval (rep Expr))) r


ggbuild :: forall algebra name rep a. GGBuildable algebra name rep
  => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
  -> GGBuild algebra name rep a
ggbuild :: forall (algebra :: Algebra) (name :: Symbol)
       (rep :: Context -> Exp Context) a.
GGBuildable algebra name rep =>
(Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
-> GGBuild algebra name rep a
ggbuild Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a
gfromColumns = case forall (algebra :: Algebra).
KnownAlgebra algebra =>
SAlgebra algebra
algebraSing @algebra of
  SAlgebra algebra
SProduct ->
    forall (f :: * -> Context) (rep :: Context) a.
Representable f rep =>
(GFields f rep -> a) -> GConstruct f rep a
gtabulate @Id @(Eval (rep Expr)) @a ((GFields Id (Eval (rep Expr)) -> a)
 -> GConstruct Id (Eval (rep Expr)) a)
-> (GFields Id (Eval (rep Expr)) -> a)
-> GConstruct Id (Eval (rep Expr)) a
forall a b. (a -> b) -> a -> b
$
    Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a
GColumns TColumns (Eval (rep Expr)) Expr -> a
gfromColumns (GColumns TColumns (Eval (rep Expr)) Expr -> a)
-> (GFields Id (Eval (rep Expr))
    -> GColumns TColumns (Eval (rep Expr)) Expr)
-> GFields Id (Eval (rep Expr))
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp (Exp Context)) (f :: * -> Context)
       (context :: Context) (rep :: Context).
GConstructable _Table _Columns f context rep =>
ToColumns _Table _Columns f context
-> GFields f rep -> GColumns _Columns rep context
gconstruct
      @(TTable Expr)
      @TColumns
      @Id
      @Expr
      @(Eval (rep Expr))
      ((x -> Columns x Expr) -> proxy x -> x -> Columns x Expr
forall a b. a -> b -> a
const x -> Columns x Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns)
  SAlgebra algebra
SSum ->
    forall (f :: * -> Context) (rep :: Context) a.
Representable f rep =>
(GFields f rep -> a) -> GConstruct f rep a
gtabulate @Id @(GConstructorADT name (Eval (rep Expr))) @a ((GFields Id (GConstructorADT name (Eval (rep Expr))) -> a)
 -> GConstruct Id (GConstructorADT name (Eval (rep Expr))) a)
-> (GFields Id (GConstructorADT name (Eval (rep Expr))) -> a)
-> GConstruct Id (GConstructorADT name (Eval (rep Expr))) a
forall a b. (a -> b) -> a -> b
$
    Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a
GColumnsADT TColumns (Eval (rep Expr)) Expr -> a
gfromColumns (GColumnsADT TColumns (Eval (rep Expr)) Expr -> a)
-> (GFields Id (GConstructorADT name (Eval (rep Expr)))
    -> GColumnsADT TColumns (Eval (rep Expr)) Expr)
-> GFields Id (GConstructorADT name (Eval (rep Expr)))
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp (Exp Context)) (f :: * -> Context)
       (context :: Context) (name :: Symbol) (rep :: Context).
GMakeableADT _Table _Columns f context name rep =>
ToColumns _Table _Columns f context
-> Null context
-> Nullifier context
-> (Tag -> HIdentity Tag context)
-> GFields f (GConstructorADT name rep)
-> GColumnsADT _Columns rep context
gmakeADT
      @(TTable Expr)
      @TColumns
      @Id
      @Expr
      @name
      @(Eval (rep Expr))
      ((x -> Columns x Expr) -> proxy x -> x -> Columns x Expr
forall a b. a -> b -> a
const x -> Columns x Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns)
      (\Spec {TypeInformation (Unnullify a)
info :: forall a. Spec a -> TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info} -> TypeInformation (Unnullify a) -> Expr (Nullify a)
forall a. TypeInformation a -> Expr (Maybe a)
snull TypeInformation (Unnullify a)
info)
      (\Spec {Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity :: Nullity a
nullity} -> case Nullity a
nullity of
        Nullity a
Null -> Expr a -> Expr a
Expr a -> Expr (Nullify a)
forall a. a -> a
id
        Nullity a
NotNull -> Expr a -> Expr (Maybe a)
Expr a -> Expr (Nullify a)
forall a. NotNull a => Expr a -> Expr (Maybe a)
nullify)
      (Expr Tag -> HIdentity Tag Expr
forall a (context :: Context). context a -> HIdentity a context
HIdentity (Expr Tag -> HIdentity Tag Expr)
-> (Tag -> Expr Tag) -> Tag -> HIdentity Tag Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Expr Tag
forall a. Sql DBType a => a -> Expr a
litExpr)


type GGConstructable :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint
type GGConstructable algebra rep =
  ( KnownAlgebra algebra
  , Eval (GGColumns algebra TColumns (Eval (rep Expr))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
  , Eval (GGColumns algebra TColumns (Eval (rep Name))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
  , HTable (Eval (GGColumns algebra TColumns (Eval (rep Expr))))
  , GGConstructable' algebra rep
  )


type GGConstructable' :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Constraint
type family GGConstructable' algebra rep where
  GGConstructable' 'K.Product rep =
    ( Representable Id (Eval (rep Expr))
    , Representable Id (Eval (rep Name))
    , GConstructable (TTable Expr) TColumns Id Expr (Eval (rep Expr))
    , GConstructable (TTable Name) TColumns Id Name (Eval (rep Name))
    )
  GGConstructable' 'K.Sum rep =
    ( RepresentableConstructors Id (Eval (rep Expr))
    , RepresentableFields Id (Eval (rep Expr))
    , RepresentableFields Id (Eval (rep Name))
    , Functor (GConstructors Id (Eval (rep Expr)))
    , GConstructableADT (TTable Expr) TColumns Id Expr (Eval (rep Expr))
    , GConstructableADT (TTable Name) TColumns Id Name (Eval (rep Name))
    )


type GGConstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
type family GGConstruct algebra rep r where
  GGConstruct 'K.Product rep r = GConstruct Id (Eval (rep Expr)) r -> r
  GGConstruct 'K.Sum rep r = GConstructADT Id (Eval (rep Expr)) r r


ggconstruct :: forall algebra rep a. GGConstructable algebra rep
  => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
  -> GGConstruct algebra rep a -> a
ggconstruct :: forall (algebra :: Algebra) (rep :: Context -> Exp Context) a.
GGConstructable algebra rep =>
(Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
-> GGConstruct algebra rep a -> a
ggconstruct Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a
gfromColumns GGConstruct algebra rep a
f = case forall (algebra :: Algebra).
KnownAlgebra algebra =>
SAlgebra algebra
algebraSing @algebra of
  SAlgebra algebra
SProduct ->
    GGConstruct algebra rep a
GConstruct Id (Eval (rep Expr)) a -> a
f (GConstruct Id (Eval (rep Expr)) a -> a)
-> GConstruct Id (Eval (rep Expr)) a -> a
forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> Context) (rep :: Context) a.
Representable f rep =>
(GFields f rep -> a) -> GConstruct f rep a
gtabulate @Id @(Eval (rep Expr)) @a ((GFields Id (Eval (rep Expr)) -> a)
 -> GConstruct Id (Eval (rep Expr)) a)
-> (GFields Id (Eval (rep Expr)) -> a)
-> GConstruct Id (Eval (rep Expr)) a
forall a b. (a -> b) -> a -> b
$
    Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a
GColumns TColumns (Eval (rep Expr)) Expr -> a
gfromColumns (GColumns TColumns (Eval (rep Expr)) Expr -> a)
-> (GFields Id (Eval (rep Expr))
    -> GColumns TColumns (Eval (rep Expr)) Expr)
-> GFields Id (Eval (rep Expr))
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp (Exp Context)) (f :: * -> Context)
       (context :: Context) (rep :: Context).
GConstructable _Table _Columns f context rep =>
ToColumns _Table _Columns f context
-> GFields f rep -> GColumns _Columns rep context
gconstruct
      @(TTable Expr)
      @TColumns
      @Id
      @Expr
      @(Eval (rep Expr))
      ((x -> Columns x Expr) -> proxy x -> x -> Columns x Expr
forall a b. a -> b -> a
const x -> Columns x Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns)
  SAlgebra algebra
SSum ->
    forall (f :: * -> Context) (rep :: Context) r a.
RepresentableConstructors f rep =>
GConstructADT f rep r a -> GConstructors f rep r -> a
gcindex @Id @(Eval (rep Expr)) @a GConstructADT Id (Eval (rep Expr)) a a
GGConstruct algebra rep a
f (GConstructors Id (Eval (rep Expr)) a -> a)
-> GConstructors Id (Eval (rep Expr)) a -> a
forall a b. (a -> b) -> a -> b
$
    (GColumnsADT TColumns (Eval (rep Expr)) Expr -> a)
-> GConstructors
     Id (Eval (rep Expr)) (GColumnsADT TColumns (Eval (rep Expr)) Expr)
-> GConstructors Id (Eval (rep Expr)) a
forall a b.
(a -> b)
-> GConstructors Id (Eval (rep Expr)) a
-> GConstructors Id (Eval (rep Expr)) b
forall (f :: Context) a b. Functor f => (a -> b) -> f a -> f b
fmap Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a
GColumnsADT TColumns (Eval (rep Expr)) Expr -> a
gfromColumns (GConstructors
   Id (Eval (rep Expr)) (GColumnsADT TColumns (Eval (rep Expr)) Expr)
 -> GConstructors Id (Eval (rep Expr)) a)
-> GConstructors
     Id (Eval (rep Expr)) (GColumnsADT TColumns (Eval (rep Expr)) Expr)
-> GConstructors Id (Eval (rep Expr)) a
forall a b. (a -> b) -> a -> b
$
    forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp (Exp Context)) (f :: * -> Context)
       (context :: Context) (rep :: Context).
GConstructableADT _Table _Columns f context rep =>
ToColumns _Table _Columns f context
-> Null context
-> Nullifier context
-> (Tag -> HIdentity Tag context)
-> GConstructors f rep (GColumnsADT _Columns rep context)
gconstructADT
      @(TTable Expr)
      @TColumns
      @Id
      @Expr
      @(Eval (rep Expr))
      ((x -> Columns x Expr) -> proxy x -> x -> Columns x Expr
forall a b. a -> b -> a
const x -> Columns x Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns)
      (\Spec {TypeInformation (Unnullify a)
info :: forall a. Spec a -> TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info} -> TypeInformation (Unnullify a) -> Expr (Nullify a)
forall a. TypeInformation a -> Expr (Maybe a)
snull TypeInformation (Unnullify a)
info)
      (\Spec {Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity :: Nullity a
nullity} -> case Nullity a
nullity of
        Nullity a
Null -> Expr a -> Expr a
Expr a -> Expr (Nullify a)
forall a. a -> a
id
        Nullity a
NotNull -> Expr a -> Expr (Maybe a)
Expr a -> Expr (Nullify a)
forall a. NotNull a => Expr a -> Expr (Maybe a)
nullify)
      (Expr Tag -> HIdentity Tag Expr
forall a (context :: Context). context a -> HIdentity a context
HIdentity (Expr Tag -> HIdentity Tag Expr)
-> (Tag -> Expr Tag) -> Tag -> HIdentity Tag Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Expr Tag
forall a. Sql DBType a => a -> Expr a
litExpr)


type GGDeconstruct :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type -> Type
type family GGDeconstruct algebra rep a r where
  GGDeconstruct 'K.Product rep a r =
    GConstruct Id (Eval (rep Expr)) r -> a -> r
  GGDeconstruct 'K.Sum rep a r =
    GConstructADT Id (Eval (rep Expr)) r (a -> r)


ggdeconstruct :: forall algebra rep a r. (GGConstructable algebra rep, Table Expr r)
  => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
  -> GGDeconstruct algebra rep a r
ggdeconstruct :: forall (algebra :: Algebra) (rep :: Context -> Exp Context) a r.
(GGConstructable algebra rep, Table Expr r) =>
(a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
-> GGDeconstruct algebra rep a r
ggdeconstruct a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr
gtoColumns = case forall (algebra :: Algebra).
KnownAlgebra algebra =>
SAlgebra algebra
algebraSing @algebra of
  SAlgebra algebra
SProduct -> \GConstruct Id (Eval (rep Expr)) r
build ->
    forall (f :: * -> Context) (rep :: Context) a.
Representable f rep =>
GConstruct f rep a -> GFields f rep -> a
gindex @Id @(Eval (rep Expr)) @r GConstruct Id (Eval (rep Expr)) r
build (GFields Id (Eval (rep Expr)) -> r)
-> (a -> GFields Id (Eval (rep Expr))) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp (Exp Context)) (f :: * -> Context)
       (context :: Context) (rep :: Context).
GConstructable _Table _Columns f context rep =>
FromColumns _Table _Columns f context
-> GColumns _Columns rep context -> GFields f rep
gdeconstruct
      @(TTable Expr)
      @TColumns
      @Id
      @Expr
      @(Eval (rep Expr))
      ((Columns x Expr -> x) -> proxy x -> Columns x Expr -> x
forall a b. a -> b -> a
const Columns x Expr -> x
forall (context :: Context) a.
Table context a =>
Columns a context -> a
fromColumns) (GColumns TColumns (Eval (rep Expr)) Expr
 -> GFields Id (Eval (rep Expr)))
-> (a -> GColumns TColumns (Eval (rep Expr)) Expr)
-> a
-> GFields Id (Eval (rep Expr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr
a -> GColumns TColumns (Eval (rep Expr)) Expr
gtoColumns
  SAlgebra algebra
SSum ->
    forall (f :: * -> Context) (rep :: Context) r a.
RepresentableConstructors f rep =>
(GConstructors f rep r -> a) -> GConstructADT f rep r a
gctabulate @Id @(Eval (rep Expr)) @r @(a -> r) ((GConstructors Id (Eval (rep Expr)) r -> a -> r)
 -> GConstructADT Id (Eval (rep Expr)) r (a -> r))
-> (GConstructors Id (Eval (rep Expr)) r -> a -> r)
-> GConstructADT Id (Eval (rep Expr)) r (a -> r)
forall a b. (a -> b) -> a -> b
$ \GConstructors Id (Eval (rep Expr)) r
constructors a
as ->
      let
        (HIdentity Expr Tag
tag, NonEmpty (Tag, r)
cases) =
          forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp (Exp Context)) (f :: * -> Context)
       (context :: Context) (rep :: Context) r.
GConstructableADT _Table _Columns f context rep =>
FromColumns _Table _Columns f context
-> Unnullifier context
-> GConstructors f rep r
-> GColumnsADT _Columns rep context
-> (HIdentity Tag context, NonEmpty (Tag, r))
gdeconstructADT
            @(TTable Expr)
            @TColumns
            @Id
            @Expr
            @(Eval (rep Expr))
            ((Columns x Expr -> x) -> proxy x -> Columns x Expr -> x
forall a b. a -> b -> a
const Columns x Expr -> x
forall (context :: Context) a.
Table context a =>
Columns a context -> a
fromColumns)
            (\Spec {Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity :: Nullity a
nullity} -> case Nullity a
nullity of
              Nullity a
Null -> Expr a -> Expr a
Expr (Nullify a) -> Expr a
forall a. a -> a
id
              Nullity a
NotNull -> Expr (Maybe a) -> Expr a
Expr (Nullify a) -> Expr a
forall a. Expr (Maybe a) -> Expr a
unsafeUnnullify)
            GConstructors Id (Eval (rep Expr)) r
constructors (GColumnsADT TColumns (Eval (rep Expr)) Expr
 -> (HIdentity Tag Expr, NonEmpty (Tag, r)))
-> GColumnsADT TColumns (Eval (rep Expr)) Expr
-> (HIdentity Tag Expr, NonEmpty (Tag, r))
forall a b. (a -> b) -> a -> b
$
          a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr
gtoColumns a
as
      in
        case NonEmpty (Tag, r)
cases of
          ((Tag
_, r
r) :| (((Tag, r) -> (Expr Bool, r)) -> [(Tag, r)] -> [(Expr Bool, r)]
forall a b. (a -> b) -> [a] -> [b]
map ((Tag -> Expr Bool) -> (Tag, r) -> (Expr Bool, r)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> Context) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Expr Tag
tag Expr Tag -> Expr Tag -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==.) (Expr Tag -> Expr Bool) -> (Tag -> Expr Tag) -> Tag -> Expr Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Expr Tag
forall a. Sql DBType a => a -> Expr a
litExpr)) -> [(Expr Bool, r)]
cases')) ->
            [(Expr Bool, r)] -> r -> r
forall a. Table Expr a => [(Expr Bool, a)] -> a -> a
case_ [(Expr Bool, r)]
cases' r
r


ggdeconstructA :: forall algebra rep a f r. (GGConstructable algebra rep, Apply f, Table Expr r)
  => (a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
  -> GGDeconstruct algebra rep a (f r)
ggdeconstructA :: forall (algebra :: Algebra) (rep :: Context -> Exp Context) a
       (f :: Context) r.
(GGConstructable algebra rep, Apply f, Table Expr r) =>
(a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
-> GGDeconstruct algebra rep a (f r)
ggdeconstructA a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr
gtoColumns = case forall (algebra :: Algebra).
KnownAlgebra algebra =>
SAlgebra algebra
algebraSing @algebra of
  SAlgebra algebra
SProduct -> \GConstruct Id (Eval (rep Expr)) (f r)
build ->
    forall (f :: * -> Context) (rep :: Context) a.
Representable f rep =>
GConstruct f rep a -> GFields f rep -> a
gindex @Id @(Eval (rep Expr)) @(f r) GConstruct Id (Eval (rep Expr)) (f r)
build (GFields Id (Eval (rep Expr)) -> f r)
-> (a -> GFields Id (Eval (rep Expr))) -> a -> f r
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp (Exp Context)) (f :: * -> Context)
       (context :: Context) (rep :: Context).
GConstructable _Table _Columns f context rep =>
FromColumns _Table _Columns f context
-> GColumns _Columns rep context -> GFields f rep
gdeconstruct
      @(TTable Expr)
      @TColumns
      @Id
      @Expr
      @(Eval (rep Expr))
      ((Columns x Expr -> x) -> proxy x -> Columns x Expr -> x
forall a b. a -> b -> a
const Columns x Expr -> x
forall (context :: Context) a.
Table context a =>
Columns a context -> a
fromColumns) (GColumns TColumns (Eval (rep Expr)) Expr
 -> GFields Id (Eval (rep Expr)))
-> (a -> GColumns TColumns (Eval (rep Expr)) Expr)
-> a
-> GFields Id (Eval (rep Expr))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr
a -> GColumns TColumns (Eval (rep Expr)) Expr
gtoColumns
  SAlgebra algebra
SSum ->
    forall (f :: * -> Context) (rep :: Context) r a.
RepresentableConstructors f rep =>
(GConstructors f rep r -> a) -> GConstructADT f rep r a
gctabulate @Id @(Eval (rep Expr)) @(f r) @(a -> f r) ((GConstructors Id (Eval (rep Expr)) (f r) -> a -> f r)
 -> GConstructADT Id (Eval (rep Expr)) (f r) (a -> f r))
-> (GConstructors Id (Eval (rep Expr)) (f r) -> a -> f r)
-> GConstructADT Id (Eval (rep Expr)) (f r) (a -> f r)
forall a b. (a -> b) -> a -> b
$ \GConstructors Id (Eval (rep Expr)) (f r)
constructors a
as ->
      let
        (HIdentity Expr Tag
tag, NonEmpty (Tag, f r)
cases) =
          forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp (Exp Context)) (f :: * -> Context)
       (context :: Context) (rep :: Context) r.
GConstructableADT _Table _Columns f context rep =>
FromColumns _Table _Columns f context
-> Unnullifier context
-> GConstructors f rep r
-> GColumnsADT _Columns rep context
-> (HIdentity Tag context, NonEmpty (Tag, r))
gdeconstructADT
            @(TTable Expr)
            @TColumns
            @Id
            @Expr
            @(Eval (rep Expr))
            ((Columns x Expr -> x) -> proxy x -> Columns x Expr -> x
forall a b. a -> b -> a
const Columns x Expr -> x
forall (context :: Context) a.
Table context a =>
Columns a context -> a
fromColumns)
            (\Spec {Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity :: Nullity a
nullity} -> case Nullity a
nullity of
              Nullity a
Null -> Expr a -> Expr a
Expr (Nullify a) -> Expr a
forall a. a -> a
id
              Nullity a
NotNull -> Expr (Maybe a) -> Expr a
Expr (Nullify a) -> Expr a
forall a. Expr (Maybe a) -> Expr a
unsafeUnnullify)
            GConstructors Id (Eval (rep Expr)) (f r)
constructors (GColumnsADT TColumns (Eval (rep Expr)) Expr
 -> (HIdentity Tag Expr, NonEmpty (Tag, f r)))
-> GColumnsADT TColumns (Eval (rep Expr)) Expr
-> (HIdentity Tag Expr, NonEmpty (Tag, f r))
forall a b. (a -> b) -> a -> b
$
          a -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr
gtoColumns a
as
        fcases :: f (NonEmpty (Tag, r))
fcases = ((Tag, f r) -> f (Tag, r))
-> NonEmpty (Tag, f r) -> f (NonEmpty (Tag, r))
forall (t :: Context) (f :: Context) a b.
(Traversable1 t, Apply f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Context) a b.
Apply f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse1 (Tag, f r) -> f (Tag, r)
forall (t :: Context) (f :: Context) b.
(Traversable1 t, Apply f) =>
t (f b) -> f (t b)
forall (f :: Context) b. Apply f => (Tag, f b) -> f (Tag, b)
sequence1 NonEmpty (Tag, f r)
cases
      in
        f (NonEmpty (Tag, r))
fcases
          f (NonEmpty (Tag, r)) -> (NonEmpty (Tag, r) -> r) -> f r
forall (f :: Context) a b. Functor f => f a -> (a -> b) -> f b
<&> \((Tag
_, r
r) :| (((Tag, r) -> (Expr Bool, r)) -> [(Tag, r)] -> [(Expr Bool, r)]
forall a b. (a -> b) -> [a] -> [b]
map ((Tag -> Expr Bool) -> (Tag, r) -> (Expr Bool, r)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> Context) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Expr Tag
tag Expr Tag -> Expr Tag -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==.) (Expr Tag -> Expr Bool) -> (Tag -> Expr Tag) -> Tag -> Expr Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> Expr Tag
forall a. Sql DBType a => a -> Expr a
litExpr)) -> [(Expr Bool, r)]
cases')) ->
            [(Expr Bool, r)] -> r -> r
forall a. Table Expr a => [(Expr Bool, a)] -> a -> a
case_ [(Expr Bool, r)]
cases' r
r


type GGName :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
type family GGName algebra rep a where
  GGName 'K.Product rep a = GConstruct Id (Eval (rep Name)) a
  GGName 'K.Sum rep a = Name Tag -> GBuildADT Id (Eval (rep Name)) a


ggname :: forall algebra rep a. GGConstructable algebra rep
  => (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a)
  -> GGName algebra rep a
ggname :: forall (algebra :: Algebra) (rep :: Context -> Exp Context) a.
GGConstructable algebra rep =>
(Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a)
-> GGName algebra rep a
ggname Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a
gfromColumns = case forall (algebra :: Algebra).
KnownAlgebra algebra =>
SAlgebra algebra
algebraSing @algebra of
  SAlgebra algebra
SProduct ->
    forall (f :: * -> Context) (rep :: Context) a.
Representable f rep =>
(GFields f rep -> a) -> GConstruct f rep a
gtabulate @Id @(Eval (rep Name)) @a ((GFields Id (Eval (rep Name)) -> a)
 -> GConstruct Id (Eval (rep Name)) a)
-> (GFields Id (Eval (rep Name)) -> a)
-> GConstruct Id (Eval (rep Name)) a
forall a b. (a -> b) -> a -> b
$
    Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a
GColumns TColumns (Eval (rep Expr)) Name -> a
gfromColumns (GColumns TColumns (Eval (rep Expr)) Name -> a)
-> (GFields Id (Eval (rep Name))
    -> GColumns TColumns (Eval (rep Expr)) Name)
-> GFields Id (Eval (rep Name))
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp (Exp Context)) (f :: * -> Context)
       (context :: Context) (rep :: Context).
GConstructable _Table _Columns f context rep =>
ToColumns _Table _Columns f context
-> GFields f rep -> GColumns _Columns rep context
gconstruct
      @(TTable Name)
      @TColumns
      @Id
      @Name
      @(Eval (rep Name))
      ((x -> Columns x Name) -> proxy x -> x -> Columns x Name
forall a b. a -> b -> a
const x -> Columns x Name
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns)
  SAlgebra algebra
SSum -> \Name Tag
tag ->
    forall (f :: * -> Context) (rep :: Context) a.
RepresentableFields f rep =>
(GFieldsADT f rep -> a) -> GBuildADT f rep a
gftabulate @Id @(Eval (rep Name)) @a ((GFieldsADT Id (Eval (rep Name)) -> a)
 -> GBuildADT Id (Eval (rep Name)) a)
-> (GFieldsADT Id (Eval (rep Name)) -> a)
-> GBuildADT Id (Eval (rep Name)) a
forall a b. (a -> b) -> a -> b
$
    Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a
GColumnsADT TColumns (Eval (rep Expr)) Name -> a
gfromColumns (GColumnsADT TColumns (Eval (rep Expr)) Name -> a)
-> (GFieldsADT Id (Eval (rep Name))
    -> GColumnsADT TColumns (Eval (rep Expr)) Name)
-> GFieldsADT Id (Eval (rep Name))
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp (Exp Context)) (f :: * -> Context)
       (context :: Context) (rep :: Context).
GConstructableADT _Table _Columns f context rep =>
ToColumns _Table _Columns f context
-> (Tag -> Nullifier context)
-> HIdentity Tag context
-> GFieldsADT f rep
-> GColumnsADT _Columns rep context
gbuildADT
      @(TTable Name)
      @TColumns
      @Id
      @Name
      @(Eval (rep Name))
      ((x -> Columns x Name) -> proxy x -> x -> Columns x Name
forall a b. a -> b -> a
const x -> Columns x Name
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns)
      (\Tag
_ Spec a
_ (Name String
a) -> String -> Name (Nullify a)
forall a. String -> Name a
Name String
a)
      (Name Tag -> HIdentity Tag Name
forall a (context :: Context). context a -> HIdentity a context
HIdentity Name Tag
tag)