{-# 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
import Data.Bifunctor ( first )
import Data.Functor ((<&>))
import Data.Kind ( Constraint, Type )
import Data.List.NonEmpty ( NonEmpty( (:|) ) )
import GHC.TypeLits ( Symbol )
import Prelude
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 )
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)