mirror of
https://github.com/circuithub/rel8.git
synced 2024-09-12 00:07:34 +03:00
Stop At leaking into user tables (instead use it only on internal tables) (also rename it to Context)
This commit is contained in:
parent
7aeb652e61
commit
8fb5051c1d
298
src/Rel8.hs
298
src/Rel8.hs
@ -49,13 +49,14 @@ module Rel8
|
|||||||
, HigherKindedTable
|
, HigherKindedTable
|
||||||
, GHigherKindedTable(..)
|
, GHigherKindedTable(..)
|
||||||
, Congruent
|
, Congruent
|
||||||
|
, KContext
|
||||||
|
, Context
|
||||||
|
|
||||||
-- ** Table schemas
|
-- ** Table schemas
|
||||||
, Column
|
, Column
|
||||||
, OuterJoin
|
, OuterJoin
|
||||||
, TableSchema(..)
|
, TableSchema(..)
|
||||||
, ColumnSchema
|
, ColumnSchema
|
||||||
, At(..)
|
|
||||||
|
|
||||||
-- * Expressions
|
-- * Expressions
|
||||||
, Expr
|
, Expr
|
||||||
@ -661,10 +662,17 @@ writing higher-kinded data types is usually more convenient. See also:
|
|||||||
|
|
||||||
-}
|
-}
|
||||||
class HigherKindedTable (Columns t) => Table (context :: Type -> Type) (t :: Type) | t -> context where
|
class HigherKindedTable (Columns t) => Table (context :: Type -> Type) (t :: Type) | t -> context where
|
||||||
type Columns t :: (Type -> Type) -> Type
|
type Columns t :: KContext -> Type
|
||||||
|
|
||||||
toColumns :: t -> Columns t context
|
toColumns :: t -> Columns t (Context context)
|
||||||
fromColumns :: Columns t context -> t
|
fromColumns :: Columns t (Context context) -> t
|
||||||
|
|
||||||
|
|
||||||
|
data KContext where
|
||||||
|
Context :: (Type -> Type) -> KContext
|
||||||
|
|
||||||
|
|
||||||
|
type Context = 'Context
|
||||||
|
|
||||||
|
|
||||||
{-| Higher-kinded data types.
|
{-| Higher-kinded data types.
|
||||||
@ -712,94 +720,94 @@ data MyType f = MyType { fieldA :: Column f T }
|
|||||||
@
|
@
|
||||||
|
|
||||||
-}
|
-}
|
||||||
class HigherKindedTable (t :: (Type -> Type) -> Type) where
|
class HigherKindedTable (t :: KContext -> Type) where
|
||||||
type HField t = (field :: Type -> Type) | field -> t
|
type HField t = (field :: Type -> Type) | field -> t
|
||||||
type HConstrainTable t (c :: Type -> Constraint) :: Constraint
|
type HConstrainTable t (c :: Type -> Constraint) :: Constraint
|
||||||
|
|
||||||
hfield :: t f -> HField t x -> C f x
|
hfield :: t (Context f) -> HField t x -> C f x
|
||||||
htabulate :: forall f. (forall x. HField t x -> C f x) -> t f
|
htabulate :: forall f. (forall x. HField t x -> C f x) -> t (Context f)
|
||||||
htraverse :: forall f g m. Applicative m => (forall x. C f x -> m (C g x)) -> t f -> m (t g)
|
htraverse :: forall f g m. Applicative m => (forall x. C f x -> m (C g x)) -> t (Context f) -> m (t (Context g))
|
||||||
hdicts :: forall c. HConstrainTable t c => t (Dict c)
|
hdicts :: forall c. HConstrainTable t c => t (Context (Dict c))
|
||||||
hdbtype :: t (Dict DBType)
|
hdbtype :: t (Context (Dict DBType))
|
||||||
|
|
||||||
type HField t = GenericHField t
|
type HField t = GenericHField t
|
||||||
type HConstrainTable t c = HConstrainTable (Columns (WithShape IsColumn (Rep (t IsColumn)) (Rep (t IsColumn) ()))) c
|
type HConstrainTable t c = HConstrainTable (Columns (WithShape IsColumn (Rep (t (Context IsColumn))) (Rep (t (Context IsColumn)) ()))) c
|
||||||
|
|
||||||
default hfield
|
default hfield
|
||||||
:: forall f x
|
:: forall f x
|
||||||
. ( Generic (t f)
|
. ( Generic (t (Context f))
|
||||||
, HField t ~ GenericHField t
|
, HField t ~ GenericHField t
|
||||||
, Congruent (WithShape f (Rep (t IsColumn)) (Rep (t f) ())) (WithShape IsColumn (Rep (t IsColumn)) (Rep (t f) ()))
|
, Congruent (WithShape f (Rep (t (Context IsColumn))) (Rep (t (Context f)) ())) (WithShape IsColumn (Rep (t (Context IsColumn))) (Rep (t (Context f)) ()))
|
||||||
, HField (Columns (WithShape IsColumn (Rep (t IsColumn)) (Rep (t f) ()))) ~ HField (Columns (WithShape IsColumn (Rep (t IsColumn)) (Rep (t IsColumn) ())))
|
, HField (Columns (WithShape IsColumn (Rep (t (Context IsColumn))) (Rep (t (Context f)) ()))) ~ HField (Columns (WithShape IsColumn (Rep (t (Context IsColumn))) (Rep (t (Context IsColumn)) ())))
|
||||||
, HigherKindedTable (Columns (WithShape IsColumn (Rep (t IsColumn)) (Rep (t f) ())))
|
, HigherKindedTable (Columns (WithShape IsColumn (Rep (t (Context IsColumn))) (Rep (t (Context f)) ())))
|
||||||
, Table f (WithShape f (Rep (t IsColumn)) (Rep (t f) ()))
|
, Table f (WithShape f (Rep (t (Context IsColumn))) (Rep (t (Context f)) ()))
|
||||||
)
|
)
|
||||||
=> t f -> HField t x -> C f x
|
=> t (Context f) -> HField t x -> C f x
|
||||||
hfield x (GenericHField i) =
|
hfield x (GenericHField i) =
|
||||||
hfield (toColumns (WithShape @f @(Rep (t IsColumn)) (GHC.Generics.from @_ @() x))) i
|
hfield (toColumns (WithShape @f @(Rep (t (Context IsColumn))) (GHC.Generics.from @_ @() x))) i
|
||||||
|
|
||||||
default htabulate
|
default htabulate
|
||||||
:: forall f
|
:: forall f
|
||||||
. ( Generic (t f)
|
. ( Generic (t (Context f))
|
||||||
, HField t ~ GenericHField t
|
, HField t ~ GenericHField t
|
||||||
, Congruent (WithShape f (Rep (t IsColumn)) (Rep (t f) ())) (WithShape IsColumn (Rep (t IsColumn)) (Rep (t f) ()))
|
, Congruent (WithShape f (Rep (t (Context IsColumn))) (Rep (t (Context f)) ())) (WithShape IsColumn (Rep (t (Context IsColumn))) (Rep (t (Context f)) ()))
|
||||||
, HField (Columns (WithShape IsColumn (Rep (t IsColumn)) (Rep (t f) ()))) ~ HField (Columns (WithShape IsColumn (Rep (t IsColumn)) (Rep (t IsColumn) ())))
|
, HField (Columns (WithShape IsColumn (Rep (t (Context IsColumn))) (Rep (t (Context f)) ()))) ~ HField (Columns (WithShape IsColumn (Rep (t (Context IsColumn))) (Rep (t (Context IsColumn)) ())))
|
||||||
, HigherKindedTable (Columns (WithShape IsColumn (Rep (t IsColumn)) (Rep (t f) ())))
|
, HigherKindedTable (Columns (WithShape IsColumn (Rep (t (Context IsColumn))) (Rep (t (Context f)) ())))
|
||||||
, Table f (WithShape f (Rep (t IsColumn)) (Rep (t f) ()))
|
, Table f (WithShape f (Rep (t (Context IsColumn))) (Rep (t (Context f)) ()))
|
||||||
)
|
)
|
||||||
=> (forall a. HField t a -> C f a) -> t f
|
=> (forall a. HField t a -> C f a) -> t (Context f)
|
||||||
htabulate f =
|
htabulate f =
|
||||||
to @_ @() $ forgetShape @f @(Rep (t IsColumn)) $ fromColumns $ htabulate (f . GenericHField)
|
to @_ @() $ forgetShape @f @(Rep (t (Context IsColumn))) $ fromColumns $ htabulate (f . GenericHField)
|
||||||
|
|
||||||
default htraverse
|
default htraverse
|
||||||
:: forall f g m
|
:: forall f g m
|
||||||
. ( Applicative m
|
. ( Applicative m
|
||||||
, Generic (t f)
|
, Generic (t (Context f))
|
||||||
, Generic (t g)
|
, Generic (t (Context g))
|
||||||
, Congruent (WithShape f (Rep (t IsColumn)) (Rep (t f) ())) (WithShape IsColumn (Rep (t IsColumn)) (Rep (t f) ()))
|
, Congruent (WithShape f (Rep (t (Context IsColumn))) (Rep (t (Context f)) ())) (WithShape IsColumn (Rep (t (Context IsColumn))) (Rep (t (Context f)) ()))
|
||||||
, HigherKindedTable (Columns (WithShape IsColumn (Rep (t IsColumn)) (Rep (t f) ())))
|
, HigherKindedTable (Columns (WithShape IsColumn (Rep (t (Context IsColumn))) (Rep (t (Context f)) ())))
|
||||||
, Table f (WithShape f (Rep (t IsColumn)) (Rep (t f) ()))
|
, Table f (WithShape f (Rep (t (Context IsColumn))) (Rep (t (Context f)) ()))
|
||||||
, Table g (WithShape g (Rep (t IsColumn)) (Rep (t g) ()))
|
, Table g (WithShape g (Rep (t (Context IsColumn))) (Rep (t (Context g)) ()))
|
||||||
, Congruent (WithShape g (Rep (t IsColumn)) (Rep (t g) ())) (WithShape IsColumn (Rep (t IsColumn)) (Rep (t f) ()))
|
, Congruent (WithShape g (Rep (t (Context IsColumn))) (Rep (t (Context g)) ())) (WithShape IsColumn (Rep (t (Context IsColumn))) (Rep (t (Context f)) ()))
|
||||||
)
|
)
|
||||||
=> (forall a. C f a -> m (C g a)) -> t f -> m (t g)
|
=> (forall a. C f a -> m (C g a)) -> t (Context f) -> m (t (Context g))
|
||||||
htraverse f x =
|
htraverse f x =
|
||||||
fmap (to @_ @() . forgetShape @g @(Rep (t IsColumn)) . fromColumns)
|
fmap (to @_ @() . forgetShape @g @(Rep (t (Context IsColumn))) . fromColumns)
|
||||||
$ htraverse f
|
$ htraverse f
|
||||||
$ toColumns
|
$ toColumns
|
||||||
$ WithShape @f @(Rep (t IsColumn))
|
$ WithShape @f @(Rep (t (Context IsColumn)))
|
||||||
$ GHC.Generics.from @_ @() x
|
$ GHC.Generics.from @_ @() x
|
||||||
|
|
||||||
default hdicts
|
default hdicts
|
||||||
:: forall c
|
:: forall c
|
||||||
. ( Generic (t (Dict c))
|
. ( Generic (t (Context (Dict c)))
|
||||||
, Table (Dict c) (WithShape (Dict c) (Rep (t IsColumn)) (Rep (t (Dict c)) ()))
|
, Table (Dict c) (WithShape (Dict c) (Rep (t (Context IsColumn))) (Rep (t (Context (Dict c))) ()))
|
||||||
, HConstrainTable (Columns (WithShape (Dict c) (Rep (t IsColumn)) (Rep (t (Dict c)) ()))) c
|
, HConstrainTable (Columns (WithShape (Dict c) (Rep (t (Context IsColumn))) (Rep (t (Context (Dict c))) ()))) c
|
||||||
)
|
)
|
||||||
=> t (Dict c)
|
=> t (Context (Dict c))
|
||||||
hdicts =
|
hdicts =
|
||||||
to @_ @() $
|
to @_ @() $
|
||||||
forgetShape @(Dict c) @(Rep (t IsColumn)) $
|
forgetShape @(Dict c) @(Rep (t (Context IsColumn))) $
|
||||||
fromColumns $
|
fromColumns $
|
||||||
hdicts @(Columns (WithShape (Dict c) (Rep (t IsColumn)) (Rep (t (Dict c)) ()))) @c
|
hdicts @(Columns (WithShape (Dict c) (Rep (t (Context IsColumn))) (Rep (t (Context (Dict c))) ()))) @c
|
||||||
|
|
||||||
default hdbtype ::
|
default hdbtype ::
|
||||||
( Generic (t (Dict DBType))
|
( Generic (t (Context (Dict DBType)))
|
||||||
, Table (Dict DBType) (WithShape (Dict DBType) (Rep (t IsColumn)) (Rep (t (Dict DBType)) ()))
|
, Table (Dict DBType) (WithShape (Dict DBType) (Rep (t (Context IsColumn))) (Rep (t (Context (Dict DBType))) ()))
|
||||||
)
|
)
|
||||||
=> t (Dict DBType)
|
=> t (Context (Dict DBType))
|
||||||
hdbtype =
|
hdbtype =
|
||||||
to @_ @() $
|
to @_ @() $
|
||||||
forgetShape @(Dict DBType) @(Rep (t IsColumn)) $
|
forgetShape @(Dict DBType) @(Rep (t (Context IsColumn))) $
|
||||||
fromColumns $
|
fromColumns $
|
||||||
hdbtype @(Columns (WithShape (Dict DBType) (Rep (t IsColumn)) (Rep (t (Dict DBType)) ())))
|
hdbtype @(Columns (WithShape (Dict DBType) (Rep (t (Context IsColumn))) (Rep (t (Context (Dict DBType))) ())))
|
||||||
|
|
||||||
|
|
||||||
hmap :: HigherKindedTable t => (forall x. C f x -> C g x) -> t f -> t g
|
hmap :: HigherKindedTable t => (forall x. C f x -> C g x) -> t (Context f) -> t (Context g)
|
||||||
hmap f t = htabulate $ f <$> hfield t
|
hmap f t = htabulate $ f <$> hfield t
|
||||||
|
|
||||||
|
|
||||||
hzipWith :: HigherKindedTable t => (forall x. C f x -> C g x -> C h x) -> t f -> t g -> t h
|
hzipWith :: HigherKindedTable t => (forall x. C f x -> C g x -> C h x) -> t (Context f) -> t (Context g) -> t (Context h)
|
||||||
hzipWith f t u = htabulate $ f <$> hfield t <*> hfield u
|
hzipWith f t u = htabulate $ f <$> hfield t <*> hfield u
|
||||||
|
|
||||||
|
|
||||||
@ -868,103 +876,103 @@ In @rel8@ we try hard to always know what @f@ is, which means holes should
|
|||||||
mention precise types, rather than the @Column@ type family. You should only
|
mention precise types, rather than the @Column@ type family. You should only
|
||||||
need to be aware of the type family when defining your table types.
|
need to be aware of the type family when defining your table types.
|
||||||
-}
|
-}
|
||||||
type family Column (context :: At (Type -> Type)) (a :: Type) :: Type where
|
type family Column (context :: (Type -> Type)) (a :: Type) :: Type where
|
||||||
Column ('At Identity) a = a
|
Column Identity a = a
|
||||||
Column ('At f) a = f a
|
Column f a = f a
|
||||||
|
|
||||||
|
|
||||||
type family OuterJoin (context :: At (Type -> Type)) (t :: At (Type -> Type) -> Type) :: Type where
|
type family OuterJoin (context :: Type -> Type) (t :: (Type -> Type) -> Type) :: Type where
|
||||||
OuterJoin ('At Identity) t = Maybe (t ('At Identity))
|
OuterJoin Identity t = Maybe (t Identity)
|
||||||
OuterJoin ('At Expr) t = MaybeTable (t ('At Expr))
|
OuterJoin Expr t = MaybeTable (t Expr)
|
||||||
OuterJoin ('At ColumnSchema) t = HMaybeTable (GRep t) ColumnSchema
|
OuterJoin f t = HMaybeTable (GRep t) (Context f)
|
||||||
|
|
||||||
|
|
||||||
-- | The @C@ newtype simply wraps 'Column', but this allows us to work around
|
-- | The @C@ newtype simply wraps 'Column', but this allows us to work around
|
||||||
-- injectivity problems of functions that return type family applications.
|
-- injectivity problems of functions that return type family applications.
|
||||||
newtype C f x = MkC { toColumn :: Column ('At f) x }
|
newtype C f x = MkC { toColumn :: Column f x }
|
||||||
|
|
||||||
|
|
||||||
-- | Lift functions that map between 'Column's to functions that map between
|
-- | Lift functions that map between 'Column's to functions that map between
|
||||||
-- 'C's.
|
-- 'C's.
|
||||||
mapC :: (Column ('At f) x -> Column ('At g) y) -> C f x -> C g y
|
mapC :: (Column f x -> Column g y) -> C f x -> C g y
|
||||||
mapC f (MkC x) = MkC $ f x
|
mapC f (MkC x) = MkC $ f x
|
||||||
|
|
||||||
|
|
||||||
-- | Effectfully map from one column to another.
|
-- | Effectfully map from one column to another.
|
||||||
traverseC :: Applicative m => (Column ('At f) x -> m (Column ('At g) y)) -> C f x -> m (C g y)
|
traverseC :: Applicative m => (Column f x -> m (Column g y)) -> C f x -> m (C g y)
|
||||||
traverseC f (MkC x) = MkC <$> f x
|
traverseC f (MkC x) = MkC <$> f x
|
||||||
|
|
||||||
|
|
||||||
-- | Zip two columns together.
|
-- | Zip two columns together.
|
||||||
zipCWith :: (Column ('At f) x -> Column ('At g) y -> Column ('At h) z) -> C f x -> C g y -> C h z
|
zipCWith :: (Column f x -> Column g y -> Column h z) -> C f x -> C g y -> C h z
|
||||||
zipCWith f (MkC x) (MkC y) = MkC (f x y)
|
zipCWith f (MkC x) (MkC y) = MkC (f x y)
|
||||||
|
|
||||||
|
|
||||||
-- | Zip two columns together under an effectful context.
|
-- | Zip two columns together under an effectful context.
|
||||||
zipCWithM :: Applicative m => (Column ('At f) x -> Column ('At g) y -> m (Column ('At h) z)) -> C f x -> C g y -> m (C h z)
|
zipCWithM :: Applicative m => (Column f x -> Column g y -> m (Column h z)) -> C f x -> C g y -> m (C h z)
|
||||||
zipCWithM f (MkC x) (MkC y) = MkC <$> f x y
|
zipCWithM f (MkC x) (MkC y) = MkC <$> f x y
|
||||||
|
|
||||||
|
|
||||||
class HigherKindedTable (GRep t) => GHigherKindedTable (t :: At (Type -> Type) -> Type) where
|
class HigherKindedTable (GRep t) => GHigherKindedTable (t :: (Type -> Type) -> Type) where
|
||||||
type GRep t :: (Type -> Type) -> Type
|
type GRep t :: KContext -> Type
|
||||||
type GRep t = GColumns (Rep (t ('At Expr)))
|
type GRep t = GColumns (Rep (t Expr))
|
||||||
|
|
||||||
toExprs :: t ('At Expr) -> GRep t Expr
|
toExprs :: t Expr -> GRep t (Context Expr)
|
||||||
fromExprs :: GRep t Expr -> t ('At Expr)
|
fromExprs :: GRep t (Context Expr) -> t Expr
|
||||||
|
|
||||||
default toExprs
|
default toExprs
|
||||||
:: ( GColumns (Rep (t ('At Expr))) ~ GRep t
|
:: ( GColumns (Rep (t Expr)) ~ GRep t
|
||||||
, GHigherKindedTableImpl Expr (Rep (t ('At Expr)))
|
, GHigherKindedTableImpl Expr (Rep (t Expr))
|
||||||
, Generic (t ('At Expr))
|
, Generic (t Expr)
|
||||||
)
|
)
|
||||||
=> t ('At Expr) -> GRep t Expr
|
=> t Expr -> GRep t (Context Expr)
|
||||||
toExprs = ghigherKindedTo @Expr @(Rep (t ('At Expr))) . GHC.Generics.from @_ @()
|
toExprs = ghigherKindedTo @Expr @(Rep (t Expr)) . GHC.Generics.from @_ @()
|
||||||
|
|
||||||
default fromExprs
|
default fromExprs
|
||||||
:: ( GColumns (Rep (t ('At Expr))) ~ GRep t
|
:: ( GColumns (Rep (t Expr)) ~ GRep t
|
||||||
, GHigherKindedTableImpl Expr (Rep (t ('At Expr)))
|
, GHigherKindedTableImpl Expr (Rep (t Expr))
|
||||||
, Generic (t ('At Expr))
|
, Generic (t Expr)
|
||||||
)
|
)
|
||||||
=> GRep t Expr -> t ('At Expr)
|
=> GRep t (Context Expr) -> t Expr
|
||||||
fromExprs = to @_ @() . ghigherKindedFrom @Expr @(Rep (t ('At Expr)))
|
fromExprs = to @_ @() . ghigherKindedFrom @Expr @(Rep (t Expr))
|
||||||
|
|
||||||
toColumnSchemas :: t ('At ColumnSchema) -> GRep t ColumnSchema
|
toColumnSchemas :: t ColumnSchema -> GRep t (Context ColumnSchema)
|
||||||
fromColumnSchemas :: GRep t ColumnSchema -> t ('At ColumnSchema)
|
fromColumnSchemas :: GRep t (Context ColumnSchema) -> t ColumnSchema
|
||||||
|
|
||||||
default toColumnSchemas
|
default toColumnSchemas
|
||||||
:: ( GColumns (Rep (t ('At ColumnSchema))) ~ GRep t
|
:: ( GColumns (Rep (t ColumnSchema)) ~ GRep t
|
||||||
, GHigherKindedTableImpl ColumnSchema (Rep (t ('At ColumnSchema)))
|
, GHigherKindedTableImpl ColumnSchema (Rep (t ColumnSchema))
|
||||||
, Generic (t ('At ColumnSchema))
|
, Generic (t ColumnSchema)
|
||||||
)
|
)
|
||||||
=> t ('At ColumnSchema) -> GRep t ColumnSchema
|
=> t ColumnSchema -> GRep t (Context ColumnSchema)
|
||||||
toColumnSchemas = ghigherKindedTo @ColumnSchema @(Rep (t ('At ColumnSchema))) . GHC.Generics.from @_ @()
|
toColumnSchemas = ghigherKindedTo @ColumnSchema @(Rep (t ColumnSchema)) . GHC.Generics.from @_ @()
|
||||||
|
|
||||||
default fromColumnSchemas
|
default fromColumnSchemas
|
||||||
:: ( GColumns (Rep (t ('At ColumnSchema))) ~ GRep t
|
:: ( GColumns (Rep (t ColumnSchema)) ~ GRep t
|
||||||
, GHigherKindedTableImpl ColumnSchema (Rep (t ('At ColumnSchema)))
|
, GHigherKindedTableImpl ColumnSchema (Rep (t ColumnSchema))
|
||||||
, Generic (t ('At ColumnSchema))
|
, Generic (t ColumnSchema)
|
||||||
)
|
)
|
||||||
=> GRep t ColumnSchema -> t ('At ColumnSchema)
|
=> GRep t (Context ColumnSchema) -> t ColumnSchema
|
||||||
fromColumnSchemas = to @_ @() . ghigherKindedFrom @ColumnSchema @(Rep (t ('At ColumnSchema)))
|
fromColumnSchemas = to @_ @() . ghigherKindedFrom @ColumnSchema @(Rep (t ColumnSchema))
|
||||||
|
|
||||||
glit :: t ('At Identity) -> t ('At Expr)
|
glit :: t Identity -> t Expr
|
||||||
default glit
|
default glit
|
||||||
:: ( Generic (t ('At Identity))
|
:: ( Generic (t Identity)
|
||||||
, Generic (t ('At Expr))
|
, Generic (t Expr)
|
||||||
, GSerializable (Rep (t ('At Expr))) (Rep (t ('At Identity)))
|
, GSerializable (Rep (t Expr)) (Rep (t Identity))
|
||||||
)
|
)
|
||||||
=> t ('At Identity) -> t ('At Expr)
|
=> t Identity -> t Expr
|
||||||
glit = to @_ @() . glitImpl @(Rep (t ('At Expr))) @(Rep (t ('At Identity))) . GHC.Generics.from @_ @()
|
glit = to @_ @() . glitImpl @(Rep (t Expr)) @(Rep (t Identity)) . GHC.Generics.from @_ @()
|
||||||
|
|
||||||
growParser :: Applicative f => (forall a. Typeable a => FieldParser a -> FieldParser (f a)) -> RowParser (f (t ('At Identity)))
|
growParser :: Applicative f => (forall a. Typeable a => FieldParser a -> FieldParser (f a)) -> RowParser (f (t Identity))
|
||||||
default growParser
|
default growParser
|
||||||
:: ( Generic (t ('At Identity))
|
:: ( Generic (t Identity)
|
||||||
, GSerializable (Rep (t ('At Expr))) (Rep (t ('At Identity)))
|
, GSerializable (Rep (t Expr)) (Rep (t Identity))
|
||||||
, Applicative f
|
, Applicative f
|
||||||
)
|
)
|
||||||
=> (forall a. Typeable a => FieldParser a -> FieldParser (f a))
|
=> (forall a. Typeable a => FieldParser a -> FieldParser (f a))
|
||||||
-> RowParser (f (t ('At Identity)))
|
-> RowParser (f (t Identity))
|
||||||
growParser f = fmap (to @_ @()) <$> growParserImpl @(Rep (t ('At Expr))) @(Rep (t ('At Identity))) f
|
growParser f = fmap (to @_ @()) <$> growParserImpl @(Rep (t Expr)) @(Rep (t Identity)) f
|
||||||
|
|
||||||
|
|
||||||
class GSerializable (expr :: Type -> Type) (haskell :: Type -> Type) where
|
class GSerializable (expr :: Type -> Type) (haskell :: Type -> Type) where
|
||||||
@ -991,9 +999,9 @@ instance Serializable expr haskell => GSerializable (K1 i expr) (K1 i haskell) w
|
|||||||
|
|
||||||
|
|
||||||
class GHigherKindedTableImpl (context :: Type -> Type) (rep :: Type -> Type) where
|
class GHigherKindedTableImpl (context :: Type -> Type) (rep :: Type -> Type) where
|
||||||
type GColumns rep :: (Type -> Type) -> Type
|
type GColumns rep :: KContext -> Type
|
||||||
ghigherKindedTo :: rep x -> GColumns rep context
|
ghigherKindedTo :: rep x -> GColumns rep (Context context)
|
||||||
ghigherKindedFrom :: GColumns rep context -> rep x
|
ghigherKindedFrom :: GColumns rep (Context context) -> rep x
|
||||||
|
|
||||||
|
|
||||||
instance GHigherKindedTableImpl context f => GHigherKindedTableImpl context (M1 i c f) where
|
instance GHigherKindedTableImpl context f => GHigherKindedTableImpl context (M1 i c f) where
|
||||||
@ -1013,15 +1021,12 @@ instance Table context a => GHigherKindedTableImpl context (K1 i a) where
|
|||||||
ghigherKindedFrom = K1 . fromColumns
|
ghigherKindedFrom = K1 . fromColumns
|
||||||
|
|
||||||
|
|
||||||
data At a = At a
|
|
||||||
|
|
||||||
|
|
||||||
class Helper f t where
|
class Helper f t where
|
||||||
helperTo :: t ('At f) -> GRep t f
|
helperTo :: t f -> GRep t (Context f)
|
||||||
helperFrom :: GRep t f -> t ('At f)
|
helperFrom :: GRep t (Context f) -> t f
|
||||||
|
|
||||||
|
|
||||||
instance (x ~ 'At f, GHigherKindedTable t, Helper f t) => Table f (t x) where
|
instance (x ~ f, GHigherKindedTable t, Helper f t) => Table f (t x) where
|
||||||
type Columns (t x) = GRep t
|
type Columns (t x) = GRep t
|
||||||
toColumns = helperTo
|
toColumns = helperTo
|
||||||
fromColumns = helperFrom
|
fromColumns = helperFrom
|
||||||
@ -1046,7 +1051,7 @@ but this will violate the injectivity of the HField type (as there might be
|
|||||||
two 't's with the same 'Rep'). This newtype restores that injectivity.
|
two 't's with the same 'Rep'). This newtype restores that injectivity.
|
||||||
-}
|
-}
|
||||||
newtype GenericHField t a where
|
newtype GenericHField t a where
|
||||||
GenericHField :: HField (Columns (WithShape IsColumn (Rep (t IsColumn)) (Rep (t IsColumn) ()))) a -> GenericHField t a
|
GenericHField :: HField (Columns (WithShape IsColumn (Rep (t (Context IsColumn))) (Rep (t (Context IsColumn)) ()))) a -> GenericHField t a
|
||||||
|
|
||||||
|
|
||||||
{-| To facilitate generic deriving for higher-kinded table, we work through
|
{-| To facilitate generic deriving for higher-kinded table, we work through
|
||||||
@ -1109,26 +1114,26 @@ type family IsColumnApplication (a :: Type) :: Bool where
|
|||||||
'nestedTable :: t f' fields in higher kinded tables.
|
'nestedTable :: t f' fields in higher kinded tables.
|
||||||
-}
|
-}
|
||||||
class (isColumnApplication ~ IsColumnApplication shape, HigherKindedTable (K1Columns isColumnApplication shape a)) => K1Helper (isColumnApplication :: Bool) (context :: Type -> Type) (shape :: Type) (a :: Type) where
|
class (isColumnApplication ~ IsColumnApplication shape, HigherKindedTable (K1Columns isColumnApplication shape a)) => K1Helper (isColumnApplication :: Bool) (context :: Type -> Type) (shape :: Type) (a :: Type) where
|
||||||
type K1Columns isColumnApplication shape a :: (Type -> Type) -> Type
|
type K1Columns isColumnApplication shape a :: KContext -> Type
|
||||||
toColumnsHelper :: a -> K1Columns isColumnApplication shape a context
|
toColumnsHelper :: a -> K1Columns isColumnApplication shape a (Context context)
|
||||||
fromColumnsHelper :: K1Columns isColumnApplication shape a context -> a
|
fromColumnsHelper :: K1Columns isColumnApplication shape a (Context context) -> a
|
||||||
|
|
||||||
|
|
||||||
instance (Table context a, IsColumnApplication shape ~ 'False) => K1Helper 'False context shape a where
|
instance (Table f a, IsColumnApplication shape ~ 'False) => K1Helper 'False f shape a where
|
||||||
type K1Columns 'False shape a = Columns a
|
type K1Columns 'False shape a = Columns a
|
||||||
toColumnsHelper = toColumns
|
toColumnsHelper = toColumns
|
||||||
fromColumnsHelper = fromColumns
|
fromColumnsHelper = fromColumns
|
||||||
|
|
||||||
|
|
||||||
instance (DBType a, f ~ context, g ~ Column ('At context) a) => K1Helper 'True context (IsColumn a) g where
|
instance (DBType a, g ~ Column f a) => K1Helper 'True f (IsColumn a) g where
|
||||||
type K1Columns 'True (IsColumn a) g = HIdentity a
|
type K1Columns 'True (IsColumn a) g = HIdentity a
|
||||||
toColumnsHelper = HIdentity
|
toColumnsHelper = HIdentity
|
||||||
fromColumnsHelper = unHIdentity
|
fromColumnsHelper = unHIdentity
|
||||||
|
|
||||||
|
|
||||||
-- | Any 'HigherKindedTable' is also a 'Table'.
|
-- | Any 'HigherKindedTable' is also a 'Table'.
|
||||||
instance (HigherKindedTable t, f ~ g) => Table f (t g) where
|
instance (HigherKindedTable t, f ~ g) => Table f (t (Context g)) where
|
||||||
type Columns (t g) = t
|
type Columns (t (Context g)) = t
|
||||||
toColumns = id
|
toColumns = id
|
||||||
fromColumns = id
|
fromColumns = id
|
||||||
|
|
||||||
@ -1137,7 +1142,7 @@ instance (HigherKindedTable t, f ~ g) => Table f (t g) where
|
|||||||
deriving of higher-kinded tables with more than 1 field (it deals with the
|
deriving of higher-kinded tables with more than 1 field (it deals with the
|
||||||
@:*:@ case).
|
@:*:@ case).
|
||||||
-}
|
-}
|
||||||
data HPair x y (f :: Type -> Type) = HPair { hfst :: x f, hsnd :: y f }
|
data HPair x y (f :: KContext) = HPair { hfst :: x f, hsnd :: y f }
|
||||||
deriving stock (Generic)
|
deriving stock (Generic)
|
||||||
|
|
||||||
|
|
||||||
@ -1173,7 +1178,8 @@ instance (Table f a, Table f b) => Table f (a, b) where
|
|||||||
{-| A single-column higher-kinded table. This is primarily useful for
|
{-| A single-column higher-kinded table. This is primarily useful for
|
||||||
facilitating generic-deriving of higher kinded tables.
|
facilitating generic-deriving of higher kinded tables.
|
||||||
-}
|
-}
|
||||||
newtype HIdentity a f = HIdentity { unHIdentity :: Column ('At f) a }
|
data HIdentity a context where
|
||||||
|
HIdentity :: { unHIdentity :: Column f a } -> HIdentity a (Context f)
|
||||||
|
|
||||||
|
|
||||||
data HIdentityField x y where
|
data HIdentityField x y where
|
||||||
@ -1189,7 +1195,7 @@ instance DBType a => HigherKindedTable (HIdentity a) where
|
|||||||
hdicts = HIdentity Dict
|
hdicts = HIdentity Dict
|
||||||
hdbtype = HIdentity Dict
|
hdbtype = HIdentity Dict
|
||||||
|
|
||||||
htraverse :: forall f g m. Applicative m => (forall x. C f x -> m (C g x)) -> HIdentity a f -> m (HIdentity a g)
|
htraverse :: forall f g m. Applicative m => (forall x. C f x -> m (C g x)) -> HIdentity a (Context f) -> m (HIdentity a (Context g))
|
||||||
htraverse f (HIdentity a) = HIdentity . toColumn @g <$> f (MkC a :: C f a)
|
htraverse f (HIdentity a) = HIdentity . toColumn @g <$> f (MkC a :: C f a)
|
||||||
|
|
||||||
|
|
||||||
@ -1218,19 +1224,19 @@ their to be multiple expression types. Usually this is not the case, but for
|
|||||||
@ExprFor a' a@), or just @Expr (Maybe a)@ (if @a@ is a single column).
|
@ExprFor a' a@), or just @Expr (Maybe a)@ (if @a@ is a single column).
|
||||||
-}
|
-}
|
||||||
class Table Expr expr => ExprFor expr haskell
|
class Table Expr expr => ExprFor expr haskell
|
||||||
instance {-# OVERLAPPABLE #-} (DBType b, a ~ Expr b) => ExprFor a b
|
instance {-# OVERLAPPABLE #-} (DBType b, a ~ Expr b) => ExprFor a b
|
||||||
instance DBType a => ExprFor (Expr (Maybe a)) (Maybe a)
|
instance DBType a => ExprFor (Expr (Maybe a)) (Maybe a)
|
||||||
instance (ExprFor a b, Table Expr a) => ExprFor (MaybeTable a) (Maybe b)
|
instance (ExprFor a b, Table Expr a) => ExprFor (MaybeTable a) (Maybe b)
|
||||||
instance (a ~ ListTable x, Table Expr (ListTable x), ExprFor x b) => ExprFor a [b]
|
instance (a ~ ListTable x, Table Expr (ListTable x), ExprFor x b) => ExprFor a [b]
|
||||||
instance (a ~ NonEmptyTable x, Table Expr (NonEmptyTable x), ExprFor x b) => ExprFor a (NonEmpty b)
|
instance (a ~ NonEmptyTable x, Table Expr (NonEmptyTable x), ExprFor x b) => ExprFor a (NonEmpty b)
|
||||||
instance (a ~ (a1, a2), ExprFor a1 b1, ExprFor a2 b2) => ExprFor a (b1, b2)
|
instance (a ~ (a1, a2), ExprFor a1 b1, ExprFor a2 b2) => ExprFor a (b1, b2)
|
||||||
instance (HigherKindedTable t, a ~ t Expr, identity ~ Identity) => ExprFor a (t identity)
|
instance (HigherKindedTable t, a ~ t (Context Expr), identity ~ (Context Identity)) => ExprFor a (t identity)
|
||||||
instance (GHigherKindedTable t, a ~ t ('At Expr), identity ~ ('At Identity)) => ExprFor a (t identity)
|
instance (GHigherKindedTable t, a ~ t Expr, identity ~ Identity) => ExprFor a (t identity)
|
||||||
|
|
||||||
|
|
||||||
-- | Any higher-kinded records can be @SELECT@ed, as long as we know how to
|
-- | Any higher-kinded records can be @SELECT@ed, as long as we know how to
|
||||||
-- decode all of the records constituent part's.
|
-- decode all of the records constituent part's.
|
||||||
instance (s ~ t, expr ~ Expr, identity ~ Identity, HigherKindedTable t) => Serializable (s expr) (t identity) where
|
instance (s ~ t, expr ~ Context Expr, identity ~ Context Identity, HigherKindedTable t) => Serializable (s expr) (t identity) where
|
||||||
rowParser :: forall f. Applicative f => (forall a. Typeable a => FieldParser a -> FieldParser (f a)) -> RowParser (f (t identity))
|
rowParser :: forall f. Applicative f => (forall a. Typeable a => FieldParser a -> FieldParser (f a)) -> RowParser (f (t identity))
|
||||||
rowParser inject = getCompose $ htraverse (traverseC getComposeOuter) $ hmap f hdbtype
|
rowParser inject = getCompose $ htraverse (traverseC getComposeOuter) $ hmap f hdbtype
|
||||||
where
|
where
|
||||||
@ -1243,7 +1249,7 @@ instance (s ~ t, expr ~ Expr, identity ~ Identity, HigherKindedTable t) => Seria
|
|||||||
(MkC Dict, MkC x) -> MkC $ monolit x
|
(MkC Dict, MkC x) -> MkC $ monolit x
|
||||||
|
|
||||||
|
|
||||||
instance (s ~ t, expr ~ 'At Expr, identity ~ 'At Identity, GHigherKindedTable t) => Serializable (s expr) (t identity) where
|
instance (s ~ t, expr ~ Expr, identity ~ Identity, GHigherKindedTable t) => Serializable (s expr) (t identity) where
|
||||||
lit = glit
|
lit = glit
|
||||||
rowParser f = growParser f
|
rowParser f = growParser f
|
||||||
|
|
||||||
@ -1303,7 +1309,7 @@ data MaybeTable t where
|
|||||||
MaybeTable
|
MaybeTable
|
||||||
:: { -- | Check if this @MaybeTable@ is null. In other words, check if an outer
|
:: { -- | Check if this @MaybeTable@ is null. In other words, check if an outer
|
||||||
-- join matched any rows.
|
-- join matched any rows.
|
||||||
nullTag :: Expr ( Maybe Bool )
|
nullTag :: Expr (Maybe Bool)
|
||||||
, table :: t
|
, table :: t
|
||||||
}
|
}
|
||||||
-> MaybeTable t
|
-> MaybeTable t
|
||||||
@ -1321,7 +1327,7 @@ instance Monad MaybeTable where
|
|||||||
|
|
||||||
|
|
||||||
data HMaybeTable g f = HMaybeTable
|
data HMaybeTable g f = HMaybeTable
|
||||||
{ hnullTag :: Column ('At f) (Maybe Bool)
|
{ hnullTag :: HIdentity (Maybe Bool) f
|
||||||
, htable :: g f
|
, htable :: g f
|
||||||
}
|
}
|
||||||
deriving stock Generic
|
deriving stock Generic
|
||||||
@ -1331,8 +1337,8 @@ data HMaybeTable g f = HMaybeTable
|
|||||||
instance Table Expr a => Table Expr (MaybeTable a) where
|
instance Table Expr a => Table Expr (MaybeTable a) where
|
||||||
type Columns (MaybeTable a) = HMaybeTable (Columns a)
|
type Columns (MaybeTable a) = HMaybeTable (Columns a)
|
||||||
|
|
||||||
toColumns (MaybeTable x y) = HMaybeTable x (toColumns y)
|
toColumns (MaybeTable x y) = HMaybeTable (HIdentity x) (toColumns y)
|
||||||
fromColumns (HMaybeTable x y) = MaybeTable x (fromColumns y)
|
fromColumns (HMaybeTable (HIdentity x) y) = MaybeTable x (fromColumns y)
|
||||||
|
|
||||||
|
|
||||||
-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
|
-- | Perform case analysis on a 'MaybeTable'. Like 'maybe'.
|
||||||
@ -2292,7 +2298,7 @@ traverseAggrExpr f = \case
|
|||||||
|
|
||||||
-- | A @ListTable@ value contains zero or more instances of @a@. You construct
|
-- | A @ListTable@ value contains zero or more instances of @a@. You construct
|
||||||
-- @ListTable@s with 'many' or 'listAgg'.
|
-- @ListTable@s with 'many' or 'listAgg'.
|
||||||
newtype ListTable a = ListTable (Columns a (ComposeInner Expr []))
|
newtype ListTable a = ListTable (Columns a (Context (ComposeInner (Context Expr) [])))
|
||||||
|
|
||||||
|
|
||||||
instance (f ~ Expr, Table f a) => Table f (ListTable a) where
|
instance (f ~ Expr, Table f a) => Table f (ListTable a) where
|
||||||
@ -2347,7 +2353,7 @@ many = fmap (maybeTable mempty id) . optional . aggregate . fmap listAgg
|
|||||||
|
|
||||||
-- | A @NonEmptyTable@ value contains one or more instances of @a@. You construct
|
-- | A @NonEmptyTable@ value contains one or more instances of @a@. You construct
|
||||||
-- @NonEmptyTable@s with 'some' or 'nonEmptyAgg'.
|
-- @NonEmptyTable@s with 'some' or 'nonEmptyAgg'.
|
||||||
newtype NonEmptyTable a = NonEmptyTable (Columns a (ComposeInner Expr NonEmpty))
|
newtype NonEmptyTable a = NonEmptyTable (Columns a (Context (ComposeInner (Context Expr) NonEmpty)))
|
||||||
|
|
||||||
|
|
||||||
instance (f ~ Expr, Table f a) => Table f (NonEmptyTable a) where
|
instance (f ~ Expr, Table f a) => Table f (NonEmptyTable a) where
|
||||||
@ -2487,27 +2493,26 @@ class c (f a) => ComposeConstraint c f a
|
|||||||
instance c (f a) => ComposeConstraint c f a
|
instance c (f a) => ComposeConstraint c f a
|
||||||
|
|
||||||
|
|
||||||
newtype ComposeInner f g a = ComposeInner
|
data ComposeInner context g a where
|
||||||
{ getComposeInner :: Column ('At f) (g a)
|
ComposeInner :: { getComposeInner :: Column f (g a) } -> ComposeInner (Context f) g a
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
traverseComposeInner :: forall f g t m a. Applicative m
|
traverseComposeInner :: forall f g t m a. Applicative m
|
||||||
=> (forall x. C f x -> m (C g x))
|
=> (forall x. C f x -> m (C g x))
|
||||||
-> C (ComposeInner f t) a -> m (C (ComposeInner g t) a)
|
-> C (ComposeInner (Context f) t) a -> m (C (ComposeInner (Context g) t) a)
|
||||||
traverseComposeInner f (MkC (ComposeInner a)) =
|
traverseComposeInner f (MkC (ComposeInner a)) =
|
||||||
mapC ComposeInner <$> f (MkC @_ @(t a) a)
|
mapC ComposeInner <$> f (MkC @_ @(t a) a)
|
||||||
|
|
||||||
|
|
||||||
zipComposeInnerWith :: forall f g h t a. ()
|
zipComposeInnerWith :: forall f g h t a. ()
|
||||||
=> (forall x. C f x -> C g x -> C h x)
|
=> (forall x. C f x -> C g x -> C h x)
|
||||||
-> C (ComposeInner f t) a -> C (ComposeInner g t) a -> C (ComposeInner h t) a
|
-> C (ComposeInner (Context f) t) a -> C (ComposeInner (Context g) t) a -> C (ComposeInner (Context h) t) a
|
||||||
zipComposeInnerWith f (MkC (ComposeInner a)) (MkC (ComposeInner b)) =
|
zipComposeInnerWith f (MkC (ComposeInner a)) (MkC (ComposeInner b)) =
|
||||||
mapC ComposeInner $ f (MkC @_ @(t a) a) (MkC @_ @(t a) b)
|
mapC ComposeInner $ f (MkC @_ @(t a) a) (MkC @_ @(t a) b)
|
||||||
|
|
||||||
|
|
||||||
newtype ComposeOuter f g a = ComposeOuter
|
newtype ComposeOuter f g a = ComposeOuter
|
||||||
{ getComposeOuter :: f (Column ('At g) a)
|
{ getComposeOuter :: f (Column g a)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
@ -2515,7 +2520,7 @@ data HComposeField f t a where
|
|||||||
HComposeField :: HField t a -> HComposeField f t (f a)
|
HComposeField :: HField t a -> HComposeField f t (f a)
|
||||||
|
|
||||||
|
|
||||||
newtype HComposeTable g t f = HComposeTable (t (ComposeInner f g))
|
newtype HComposeTable g t (f :: KContext) = HComposeTable (t (Context (ComposeInner f g)))
|
||||||
|
|
||||||
|
|
||||||
instance (HigherKindedTable t, forall a. DBType a => DBType (f a)) => HigherKindedTable (HComposeTable f t) where
|
instance (HigherKindedTable t, forall a. DBType a => DBType (f a)) => HigherKindedTable (HComposeTable f t) where
|
||||||
@ -2529,8 +2534,15 @@ instance (HigherKindedTable t, forall a. DBType a => DBType (f a)) => HigherKind
|
|||||||
|
|
||||||
htraverse f (HComposeTable t) = HComposeTable <$> htraverse (traverseComposeInner f) t
|
htraverse f (HComposeTable t) = HComposeTable <$> htraverse (traverseComposeInner f) t
|
||||||
|
|
||||||
hdicts :: forall c. HConstrainTable t (ComposeConstraint c f) => HComposeTable f t (Dict c)
|
hdicts :: forall c. HConstrainTable t (ComposeConstraint c f) => HComposeTable f t (Context (Dict c))
|
||||||
hdicts = HComposeTable $ hmap (mapC \Dict -> ComposeInner Dict) (hdicts @_ @(ComposeConstraint c f))
|
hdicts = HComposeTable $ hmap (mapC \Dict -> ComposeInner Dict) (hdicts @_ @(ComposeConstraint c f))
|
||||||
|
|
||||||
hdbtype :: HComposeTable f t (Dict DBType)
|
hdbtype :: HComposeTable f t (Context (Dict DBType))
|
||||||
hdbtype = HComposeTable $ hmap (mapC \Dict -> ComposeInner Dict) hdbtype
|
hdbtype = HComposeTable $ hmap (mapC \Dict -> ComposeInner Dict) hdbtype
|
||||||
|
|
||||||
|
|
||||||
|
data Tab f = Tab
|
||||||
|
{ foo :: Column f Bool
|
||||||
|
, bar :: Column f Int64
|
||||||
|
}
|
||||||
|
deriving (Generic, GHigherKindedTable)
|
||||||
|
@ -44,7 +44,6 @@ import qualified Database.Postgres.Temp as TmpPostgres
|
|||||||
import GHC.Generics ( Generic )
|
import GHC.Generics ( Generic )
|
||||||
import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
|
import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
|
||||||
import qualified Hedgehog.Gen as Gen
|
import qualified Hedgehog.Gen as Gen
|
||||||
import Rel8 ( At(..) )
|
|
||||||
import qualified Hedgehog.Range as Range
|
import qualified Hedgehog.Range as Range
|
||||||
import qualified Rel8
|
import qualified Rel8
|
||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
@ -131,12 +130,12 @@ data TestTable f = TestTable
|
|||||||
deriving anyclass Rel8.GHigherKindedTable
|
deriving anyclass Rel8.GHigherKindedTable
|
||||||
|
|
||||||
|
|
||||||
deriving stock instance Eq (TestTable ('At Identity))
|
deriving stock instance Eq (TestTable Identity)
|
||||||
deriving stock instance Ord (TestTable ('At Identity))
|
deriving stock instance Ord (TestTable Identity)
|
||||||
deriving stock instance Show (TestTable ('At Identity))
|
deriving stock instance Show (TestTable Identity)
|
||||||
|
|
||||||
|
|
||||||
testTableSchema :: Rel8.TableSchema ( TestTable ('At Rel8.ColumnSchema) )
|
testTableSchema :: Rel8.TableSchema (TestTable Rel8.ColumnSchema)
|
||||||
testTableSchema =
|
testTableSchema =
|
||||||
Rel8.TableSchema
|
Rel8.TableSchema
|
||||||
{ tableName = "test_table"
|
{ tableName = "test_table"
|
||||||
@ -530,9 +529,9 @@ data TwoTestTables f =
|
|||||||
deriving anyclass Rel8.GHigherKindedTable
|
deriving anyclass Rel8.GHigherKindedTable
|
||||||
|
|
||||||
|
|
||||||
deriving stock instance Eq (TwoTestTables ('At Identity))
|
deriving stock instance Eq (TwoTestTables Identity)
|
||||||
deriving stock instance Ord (TwoTestTables ('At Identity))
|
deriving stock instance Ord (TwoTestTables Identity)
|
||||||
deriving stock instance Show (TwoTestTables ('At Identity))
|
deriving stock instance Show (TwoTestTables Identity)
|
||||||
|
|
||||||
|
|
||||||
testNestedTables :: IO TmpPostgres.DB -> TestTree
|
testNestedTables :: IO TmpPostgres.DB -> TestTree
|
||||||
@ -565,7 +564,7 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
|
|||||||
(as, []) -> selected === (Nothing <$ as)
|
(as, []) -> selected === (Nothing <$ as)
|
||||||
(as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)
|
(as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)
|
||||||
where
|
where
|
||||||
genRows :: PropertyT IO [TestTable ('At Identity)]
|
genRows :: PropertyT IO [TestTable Identity]
|
||||||
genRows = forAll do
|
genRows = forAll do
|
||||||
Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
|
Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
|
||||||
|
|
||||||
@ -577,7 +576,7 @@ rollingBack connection m =
|
|||||||
m `finally` liftIO (rollback connection)
|
m `finally` liftIO (rollback connection)
|
||||||
|
|
||||||
|
|
||||||
genTestTable :: Gen (TestTable ('At Identity))
|
genTestTable :: Gen (TestTable Identity)
|
||||||
genTestTable = do
|
genTestTable = do
|
||||||
testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum
|
testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum
|
||||||
testTableColumn2 <- Gen.bool
|
testTableColumn2 <- Gen.bool
|
||||||
@ -659,9 +658,9 @@ newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
|
|||||||
deriving stock Generic
|
deriving stock Generic
|
||||||
deriving anyclass Rel8.GHigherKindedTable
|
deriving anyclass Rel8.GHigherKindedTable
|
||||||
|
|
||||||
deriving stock instance Eq (HKNestedPair ('At Identity))
|
deriving stock instance Eq (HKNestedPair Identity)
|
||||||
deriving stock instance Ord (HKNestedPair ('At Identity))
|
deriving stock instance Ord (HKNestedPair Identity)
|
||||||
deriving stock instance Show (HKNestedPair ('At Identity))
|
deriving stock instance Show (HKNestedPair Identity)
|
||||||
|
|
||||||
|
|
||||||
testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
|
testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
|
||||||
@ -694,9 +693,9 @@ data NestedMaybeTable f = NestedMaybeTable
|
|||||||
deriving anyclass Rel8.GHigherKindedTable
|
deriving anyclass Rel8.GHigherKindedTable
|
||||||
|
|
||||||
|
|
||||||
deriving stock instance Eq (NestedMaybeTable ('At Identity))
|
deriving stock instance Eq (NestedMaybeTable Identity)
|
||||||
deriving stock instance Ord (NestedMaybeTable ('At Identity))
|
deriving stock instance Ord (NestedMaybeTable Identity)
|
||||||
deriving stock instance Show (NestedMaybeTable ('At Identity))
|
deriving stock instance Show (NestedMaybeTable Identity)
|
||||||
|
|
||||||
|
|
||||||
testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
|
testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
|
||||||
|
Loading…
Reference in New Issue
Block a user