{-# language AllowAmbiguousTypes #-}
{-# language ConstraintKinds #-}
{-# language DataKinds #-}
{-# language FlexibleContexts #-}
{-# language NamedFieldPuns #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}
{-# language ViewPatterns #-}
module Rel8.Generic.Construction
( GGBuildable
, GGBuild, ggbuild
, GGConstructable
, GGConstruct, ggconstruct
, GGDeconstruct, ggdeconstruct
, GGName, ggname
, GGAggregate, ggaggregate
)
where
import Data.Bifunctor ( first )
import Data.Kind ( Constraint, Type )
import Data.List.NonEmpty ( NonEmpty( (:|) ) )
import GHC.TypeLits ( Symbol )
import Prelude
import Rel8.Aggregate ( Aggregate( Aggregate ) )
import Rel8.Expr ( Expr )
import Rel8.Expr.Aggregate ( groupByExpr )
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, gunbuildADT
, GConstructADT, gconstructADT, gdeconstructADT
, RepresentableConstructors, GConstructors, gcindex, gctabulate
, RepresentableFields, gfindex, 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.Context.Nullify ( sguard, snullify )
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 )
type GGBuildable :: K.Algebra -> Symbol -> (K.Context -> Exp (Type -> Type)) -> Constraint
type GGBuildable algebra name rep =
( KnownAlgebra algebra
, Eval (GGColumns algebra TColumns (Eval (rep Aggregate))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
, 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 :: (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 KnownAlgebra algebra => SAlgebra algebra
forall (algebra :: Algebra).
KnownAlgebra algebra =>
SAlgebra algebra
algebraSing @algebra of
SAlgebra algebra
SProduct ->
(GFields Id (Eval (rep Expr)) -> a)
-> GConstruct Id (Eval (rep Expr)) a
forall (f :: * -> * -> *) (rep :: * -> *) 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
gfromColumns (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
-> (GFields Id (Eval (rep Expr))
-> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
-> GFields Id (Eval (rep Expr))
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ToColumns (TTable Expr) TColumns Id Expr
-> GFields Id (Eval (rep Expr))
-> GColumns TColumns (Eval (rep Expr)) Expr
forall (_Table :: * -> Exp Constraint)
(_Columns :: * -> Exp HTable) (f :: * -> * -> *)
(context :: * -> *) (rep :: * -> *).
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 :: * -> *) a.
Table context a =>
a -> Columns a context
toColumns)
SAlgebra algebra
SSum ->
(GFields Id (GConstructorADT name (Eval (rep Expr))) -> a)
-> GConstruct Id (GConstructorADT name (Eval (rep Expr))) a
forall (f :: * -> * -> *) (rep :: * -> *) 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
gfromColumns (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
-> (GFields Id (GConstructorADT name (Eval (rep Expr)))
-> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
-> GFields Id (GConstructorADT name (Eval (rep Expr)))
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ToColumns (TTable Expr) TColumns Id Expr
-> Null Expr
-> Nullifier Expr
-> (Tag -> HIdentity Tag Expr)
-> GFields Id (GConstructorADT name (Eval (rep Expr)))
-> GColumnsADT TColumns (Eval (rep Expr)) Expr
forall (_Table :: * -> Exp Constraint)
(_Columns :: * -> Exp HTable) (f :: * -> * -> *)
(context :: * -> *) (name :: Symbol) (rep :: * -> *).
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 :: * -> *) a.
Table context a =>
a -> Columns a context
toColumns)
(\Spec {TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info :: forall a. Spec a -> 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 :: Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity} -> case Nullity a
nullity of
Nullity a
Null -> Expr a -> Expr (Nullify a)
forall a. a -> a
id
Nullity a
NotNull -> Expr a -> Expr (Nullify a)
forall a. NotNull a => Expr a -> Expr (Maybe a)
nullify)
(Expr Tag -> HIdentity Tag Expr
forall a (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 Aggregate))) ~ Eval (GGColumns algebra TColumns (Eval (rep Expr)))
, 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 Aggregate))
, Representable Id (Eval (rep Expr))
, Representable Id (Eval (rep Name))
, GConstructable (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))
, 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 Aggregate))
, RepresentableFields Id (Eval (rep Expr))
, RepresentableFields Id (Eval (rep Name))
, Functor (GConstructors Id (Eval (rep Expr)))
, GConstructableADT (TTable Aggregate) TColumns Id Aggregate (Eval (rep Aggregate))
, 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 :: (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 KnownAlgebra algebra => SAlgebra algebra
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
$
(GFields Id (Eval (rep Expr)) -> a)
-> GConstruct Id (Eval (rep Expr)) a
forall (f :: * -> * -> *) (rep :: * -> *) 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
gfromColumns (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
-> (GFields Id (Eval (rep Expr))
-> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
-> GFields Id (Eval (rep Expr))
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ToColumns (TTable Expr) TColumns Id Expr
-> GFields Id (Eval (rep Expr))
-> GColumns TColumns (Eval (rep Expr)) Expr
forall (_Table :: * -> Exp Constraint)
(_Columns :: * -> Exp HTable) (f :: * -> * -> *)
(context :: * -> *) (rep :: * -> *).
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 :: * -> *) a.
Table context a =>
a -> Columns a context
toColumns)
SAlgebra algebra
SSum ->
GConstructADT Id (Eval (rep Expr)) a a
-> GConstructors Id (Eval (rep Expr)) a -> a
forall (f :: * -> * -> *) (rep :: * -> *) 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
$
(Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a)
-> GConstructors
Id
(Eval (rep Expr))
(Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
-> GConstructors Id (Eval (rep Expr)) a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr -> a
gfromColumns (GConstructors
Id
(Eval (rep Expr))
(Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
-> GConstructors Id (Eval (rep Expr)) a)
-> GConstructors
Id
(Eval (rep Expr))
(Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
-> GConstructors Id (Eval (rep Expr)) a
forall a b. (a -> b) -> a -> b
$
ToColumns (TTable Expr) TColumns Id Expr
-> Null Expr
-> Nullifier Expr
-> (Tag -> HIdentity Tag Expr)
-> GConstructors
Id (Eval (rep Expr)) (GColumnsADT TColumns (Eval (rep Expr)) Expr)
forall (_Table :: * -> Exp Constraint)
(_Columns :: * -> Exp HTable) (f :: * -> * -> *)
(context :: * -> *) (rep :: * -> *).
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 :: * -> *) a.
Table context a =>
a -> Columns a context
toColumns)
(\Spec {TypeInformation (Unnullify a)
info :: TypeInformation (Unnullify a)
info :: forall a. Spec a -> 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 :: Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity} -> case Nullity a
nullity of
Nullity a
Null -> Expr a -> Expr (Nullify a)
forall a. a -> a
id
Nullity a
NotNull -> Expr a -> Expr (Nullify a)
forall a. NotNull a => Expr a -> Expr (Maybe a)
nullify)
(Expr Tag -> HIdentity Tag Expr
forall a (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 :: (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 KnownAlgebra algebra => SAlgebra algebra
forall (algebra :: Algebra).
KnownAlgebra algebra =>
SAlgebra algebra
algebraSing @algebra of
SAlgebra algebra
SProduct -> \GConstruct Id (Eval (rep Expr)) r
build ->
GConstruct Id (Eval (rep Expr)) r
-> GFields Id (Eval (rep Expr)) -> r
forall (f :: * -> * -> *) (rep :: * -> *) 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
.
FromColumns (TTable Expr) TColumns Id Expr
-> GColumns TColumns (Eval (rep Expr)) Expr
-> GFields Id (Eval (rep Expr))
forall (_Table :: * -> Exp Constraint)
(_Columns :: * -> Exp HTable) (f :: * -> * -> *)
(context :: * -> *) (rep :: * -> *).
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 :: * -> *) a.
Table context a =>
Columns a context -> a
fromColumns) (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr
-> GFields Id (Eval (rep Expr)))
-> (a -> Eval (GGColumns algebra 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
gtoColumns
SAlgebra algebra
SSum ->
(GConstructors Id (Eval (rep Expr)) r -> a -> r)
-> GConstructADT Id (Eval (rep Expr)) r (a -> r)
forall (f :: * -> * -> *) (rep :: * -> *) 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) =
FromColumns (TTable Expr) TColumns Id Expr
-> Unnullifier Expr
-> GConstructors Id (Eval (rep Expr)) r
-> GColumnsADT TColumns (Eval (rep Expr)) Expr
-> (HIdentity Tag Expr, NonEmpty (Tag, r))
forall (_Table :: * -> Exp Constraint)
(_Columns :: * -> Exp HTable) (f :: * -> * -> *)
(context :: * -> *) (rep :: * -> *) 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 :: * -> *) a.
Table context a =>
Columns a context -> a
fromColumns)
(\Spec {Nullity a
nullity :: Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity} -> case Nullity a
nullity of
Nullity a
Null -> Expr (Nullify a) -> Expr a
forall a. a -> a
id
Nullity a
NotNull -> 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 (p :: * -> * -> *) 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 :: (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 KnownAlgebra algebra => SAlgebra algebra
forall (algebra :: Algebra).
KnownAlgebra algebra =>
SAlgebra algebra
algebraSing @algebra of
SAlgebra algebra
SProduct ->
(GFields Id (Eval (rep Name)) -> a)
-> GConstruct Id (Eval (rep Name)) a
forall (f :: * -> * -> *) (rep :: * -> *) 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
gfromColumns (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a)
-> (GFields Id (Eval (rep Name))
-> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name)
-> GFields Id (Eval (rep Name))
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ToColumns (TTable Name) TColumns Id Name
-> GFields Id (Eval (rep Name))
-> GColumns TColumns (Eval (rep Name)) Name
forall (_Table :: * -> Exp Constraint)
(_Columns :: * -> Exp HTable) (f :: * -> * -> *)
(context :: * -> *) (rep :: * -> *).
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 :: * -> *) a.
Table context a =>
a -> Columns a context
toColumns)
SAlgebra algebra
SSum -> \Name Tag
tag ->
(GFieldsADT Id (Eval (rep Name)) -> a)
-> GBuildADT Id (Eval (rep Name)) a
forall (f :: * -> * -> *) (rep :: * -> *) 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
gfromColumns (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name -> a)
-> (GFieldsADT Id (Eval (rep Name))
-> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Name)
-> GFieldsADT Id (Eval (rep Name))
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ToColumns (TTable Name) TColumns Id Name
-> (Tag -> Nullifier Name)
-> HIdentity Tag Name
-> GFieldsADT Id (Eval (rep Name))
-> GColumnsADT TColumns (Eval (rep Name)) Name
forall (_Table :: * -> Exp Constraint)
(_Columns :: * -> Exp HTable) (f :: * -> * -> *)
(context :: * -> *) (rep :: * -> *).
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 :: * -> *) 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 a -> HIdentity a context
HIdentity Name Tag
tag)
type GGAggregate :: K.Algebra -> (K.Context -> Exp (Type -> Type)) -> Type -> Type
type family GGAggregate algebra rep r where
GGAggregate 'K.Product rep r =
GConstruct Id (Eval (rep Aggregate)) r ->
GConstruct Id (Eval (rep Expr)) r
GGAggregate 'K.Sum rep r =
GBuildADT Id (Eval (rep Aggregate)) r ->
GBuildADT Id (Eval (rep Expr)) r
ggaggregate :: forall algebra rep exprs agg. GGConstructable algebra rep
=> (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate -> agg)
-> (exprs -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
-> GGAggregate algebra rep agg -> exprs -> agg
ggaggregate :: (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate
-> agg)
-> (exprs
-> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr)
-> GGAggregate algebra rep agg
-> exprs
-> agg
ggaggregate Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate
-> agg
gfromColumns exprs -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr
gtoColumns GGAggregate algebra rep agg
agg exprs
es = case KnownAlgebra algebra => SAlgebra algebra
forall (algebra :: Algebra).
KnownAlgebra algebra =>
SAlgebra algebra
algebraSing @algebra of
SAlgebra algebra
SProduct -> ((GFields Id (Eval (rep Aggregate)) -> agg)
-> GFields Id (Eval (rep Expr)) -> agg)
-> GFields Id (Eval (rep Expr))
-> (GFields Id (Eval (rep Aggregate)) -> agg)
-> agg
forall a b c. (a -> b -> c) -> b -> a -> c
flip (GFields Id (Eval (rep Aggregate)) -> agg)
-> GFields Id (Eval (rep Expr)) -> agg
f GFields Id (Eval (rep Expr))
exprs ((GFields Id (Eval (rep Aggregate)) -> agg) -> agg)
-> (GFields Id (Eval (rep Aggregate)) -> agg) -> agg
forall a b. (a -> b) -> a -> b
$
Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate
-> agg
gfromColumns (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate
-> agg)
-> (GFields Id (Eval (rep Aggregate))
-> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate)
-> GFields Id (Eval (rep Aggregate))
-> agg
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ToColumns (TTable Aggregate) TColumns Id Aggregate
-> GFields Id (Eval (rep Aggregate))
-> GColumns TColumns (Eval (rep Aggregate)) Aggregate
forall (_Table :: * -> Exp Constraint)
(_Columns :: * -> Exp HTable) (f :: * -> * -> *)
(context :: * -> *) (rep :: * -> *).
GConstructable _Table _Columns f context rep =>
ToColumns _Table _Columns f context
-> GFields f rep -> GColumns _Columns rep context
gconstruct
@(TTable Aggregate)
@TColumns
@Id
@Aggregate
@(Eval (rep Aggregate))
((x -> Columns x Aggregate) -> proxy x -> x -> Columns x Aggregate
forall a b. a -> b -> a
const x -> Columns x Aggregate
forall (context :: * -> *) a.
Table context a =>
a -> Columns a context
toColumns)
where
f :: (GFields Id (Eval (rep Aggregate)) -> agg)
-> GFields Id (Eval (rep Expr)) -> agg
f =
GConstruct Id (Eval (rep Expr)) agg
-> GFields Id (Eval (rep Expr)) -> agg
forall (f :: * -> * -> *) (rep :: * -> *) a.
Representable f rep =>
GConstruct f rep a -> GFields f rep -> a
gindex @Id @(Eval (rep Expr)) @agg (GConstruct Id (Eval (rep Expr)) agg
-> GFields Id (Eval (rep Expr)) -> agg)
-> ((GFields Id (Eval (rep Aggregate)) -> agg)
-> GConstruct Id (Eval (rep Expr)) agg)
-> (GFields Id (Eval (rep Aggregate)) -> agg)
-> GFields Id (Eval (rep Expr))
-> agg
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
GGAggregate algebra rep agg
GConstruct Id (Eval (rep Aggregate)) agg
-> GConstruct Id (Eval (rep Expr)) agg
agg (GConstruct Id (Eval (rep Aggregate)) agg
-> GConstruct Id (Eval (rep Expr)) agg)
-> ((GFields Id (Eval (rep Aggregate)) -> agg)
-> GConstruct Id (Eval (rep Aggregate)) agg)
-> (GFields Id (Eval (rep Aggregate)) -> agg)
-> GConstruct Id (Eval (rep Expr)) agg
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(GFields Id (Eval (rep Aggregate)) -> agg)
-> GConstruct Id (Eval (rep Aggregate)) agg
forall (f :: * -> * -> *) (rep :: * -> *) a.
Representable f rep =>
(GFields f rep -> a) -> GConstruct f rep a
gtabulate @Id @(Eval (rep Aggregate)) @agg
exprs :: GFields Id (Eval (rep Expr))
exprs =
FromColumns (TTable Expr) TColumns Id Expr
-> GColumns TColumns (Eval (rep Expr)) Expr
-> GFields Id (Eval (rep Expr))
forall (_Table :: * -> Exp Constraint)
(_Columns :: * -> Exp HTable) (f :: * -> * -> *)
(context :: * -> *) (rep :: * -> *).
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 :: * -> *) a.
Table context a =>
Columns a context -> a
fromColumns) (GColumns TColumns (Eval (rep Expr)) Expr
-> GFields Id (Eval (rep Expr)))
-> GColumns TColumns (Eval (rep Expr)) Expr
-> GFields Id (Eval (rep Expr))
forall a b. (a -> b) -> a -> b
$
exprs -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr
gtoColumns exprs
es
SAlgebra algebra
SSum -> ((GFieldsADT Id (Eval (rep Aggregate)) -> agg)
-> GFieldsADT Id (Eval (rep Expr)) -> agg)
-> GFieldsADT Id (Eval (rep Expr))
-> (GFieldsADT Id (Eval (rep Aggregate)) -> agg)
-> agg
forall a b c. (a -> b -> c) -> b -> a -> c
flip (GFieldsADT Id (Eval (rep Aggregate)) -> agg)
-> GFieldsADT Id (Eval (rep Expr)) -> agg
f GFieldsADT Id (Eval (rep Expr))
exprs ((GFieldsADT Id (Eval (rep Aggregate)) -> agg) -> agg)
-> (GFieldsADT Id (Eval (rep Aggregate)) -> agg) -> agg
forall a b. (a -> b) -> a -> b
$
Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate
-> agg
gfromColumns (Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate
-> agg)
-> (GFieldsADT Id (Eval (rep Aggregate))
-> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Aggregate)
-> GFieldsADT Id (Eval (rep Aggregate))
-> agg
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
ToColumns (TTable Aggregate) TColumns Id Aggregate
-> (Tag -> Nullifier Aggregate)
-> HIdentity Tag Aggregate
-> GFieldsADT Id (Eval (rep Aggregate))
-> GColumnsADT TColumns (Eval (rep Aggregate)) Aggregate
forall (_Table :: * -> Exp Constraint)
(_Columns :: * -> Exp HTable) (f :: * -> * -> *)
(context :: * -> *) (rep :: * -> *).
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 Aggregate)
@TColumns
@Id
@Aggregate
@(Eval (rep Aggregate))
((x -> Columns x Aggregate) -> proxy x -> x -> Columns x Aggregate
forall a b. a -> b -> a
const x -> Columns x Aggregate
forall (context :: * -> *) a.
Table context a =>
a -> Columns a context
toColumns)
(\Tag
tag' Spec {Nullity a
nullity :: Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity} (Aggregate Aggregator () (Expr a)
a) ->
Aggregator () (Expr (Nullify a)) -> Aggregate (Nullify a)
forall a. Aggregator () (Expr a) -> Aggregate a
Aggregate (Aggregator () (Expr (Nullify a)) -> Aggregate (Nullify a))
-> Aggregator () (Expr (Nullify a)) -> Aggregate (Nullify a)
forall a b. (a -> b) -> a -> b
$ Expr Bool -> Expr (Nullify a) -> Expr (Nullify a)
forall a. Expr Bool -> Expr (Maybe a) -> Expr (Maybe a)
sguard (Expr Tag
tag Expr Tag -> Expr Tag -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==. Tag -> Expr Tag
forall a. Sql DBType a => a -> Expr a
litExpr Tag
tag') (Expr (Nullify a) -> Expr (Nullify a))
-> (Expr a -> Expr (Nullify a)) -> Expr a -> Expr (Nullify a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nullity a -> Expr a -> Expr (Nullify a)
forall a. Nullity a -> Expr a -> Expr (Nullify a)
snullify Nullity a
nullity (Expr a -> Expr (Nullify a))
-> Aggregator () (Expr a) -> Aggregator () (Expr (Nullify a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Aggregator () (Expr a)
a)
(Aggregate Tag -> HIdentity Tag Aggregate
forall a (context :: * -> *). context a -> HIdentity a context
HIdentity (Expr Tag -> Aggregate Tag
forall a. Sql DBEq a => Expr a -> Aggregate a
groupByExpr Expr Tag
tag))
where
f :: (GFieldsADT Id (Eval (rep Aggregate)) -> agg)
-> GFieldsADT Id (Eval (rep Expr)) -> agg
f =
GBuildADT Id (Eval (rep Expr)) agg
-> GFieldsADT Id (Eval (rep Expr)) -> agg
forall (f :: * -> * -> *) (rep :: * -> *) a.
RepresentableFields f rep =>
GBuildADT f rep a -> GFieldsADT f rep -> a
gfindex @Id @(Eval (rep Expr)) @agg (GBuildADT Id (Eval (rep Expr)) agg
-> GFieldsADT Id (Eval (rep Expr)) -> agg)
-> ((GFieldsADT Id (Eval (rep Aggregate)) -> agg)
-> GBuildADT Id (Eval (rep Expr)) agg)
-> (GFieldsADT Id (Eval (rep Aggregate)) -> agg)
-> GFieldsADT Id (Eval (rep Expr))
-> agg
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
GGAggregate algebra rep agg
GBuildADT Id (Eval (rep Aggregate)) agg
-> GBuildADT Id (Eval (rep Expr)) agg
agg (GBuildADT Id (Eval (rep Aggregate)) agg
-> GBuildADT Id (Eval (rep Expr)) agg)
-> ((GFieldsADT Id (Eval (rep Aggregate)) -> agg)
-> GBuildADT Id (Eval (rep Aggregate)) agg)
-> (GFieldsADT Id (Eval (rep Aggregate)) -> agg)
-> GBuildADT Id (Eval (rep Expr)) agg
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(GFieldsADT Id (Eval (rep Aggregate)) -> agg)
-> GBuildADT Id (Eval (rep Aggregate)) agg
forall (f :: * -> * -> *) (rep :: * -> *) a.
RepresentableFields f rep =>
(GFieldsADT f rep -> a) -> GBuildADT f rep a
gftabulate @Id @(Eval (rep Aggregate)) @agg
(HIdentity Expr Tag
tag, GFieldsADT Id (Eval (rep Expr))
exprs) =
FromColumns (TTable Expr) TColumns Id Expr
-> Unnullifier Expr
-> GColumnsADT TColumns (Eval (rep Expr)) Expr
-> (HIdentity Tag Expr, GFieldsADT Id (Eval (rep Expr)))
forall (_Table :: * -> Exp Constraint)
(_Columns :: * -> Exp HTable) (f :: * -> * -> *)
(context :: * -> *) (rep :: * -> *).
GConstructableADT _Table _Columns f context rep =>
FromColumns _Table _Columns f context
-> Unnullifier context
-> GColumnsADT _Columns rep context
-> (HIdentity Tag context, GFieldsADT f rep)
gunbuildADT
@(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 :: * -> *) a.
Table context a =>
Columns a context -> a
fromColumns)
(\Spec {Nullity a
nullity :: Nullity a
nullity :: forall a. Spec a -> Nullity a
nullity} -> case Nullity a
nullity of
Nullity a
Null -> Expr (Nullify a) -> Expr a
forall a. a -> a
id
Nullity a
NotNull -> Expr (Nullify a) -> Expr a
forall a. Expr (Maybe a) -> Expr a
unsafeUnnullify) (GColumnsADT TColumns (Eval (rep Expr)) Expr
-> (HIdentity Tag Expr, GFieldsADT Id (Eval (rep Expr))))
-> GColumnsADT TColumns (Eval (rep Expr)) Expr
-> (HIdentity Tag Expr, GFieldsADT Id (Eval (rep Expr)))
forall a b. (a -> b) -> a -> b
$
exprs -> Eval (GGColumns algebra TColumns (Eval (rep Expr))) Expr
gtoColumns exprs
es