mirror of
https://github.com/circuithub/rel8.git
synced 2024-09-12 00:07:34 +03:00
More tests
This commit is contained in:
parent
057bff8b9b
commit
1e650a2031
@ -37,7 +37,7 @@ module Rel8
|
|||||||
, Table
|
, Table
|
||||||
, AltTable((<|>:))
|
, AltTable((<|>:))
|
||||||
, EqTable, (==:), (/=:)
|
, EqTable, (==:), (/=:)
|
||||||
, OrdTable, ascTable, descTable
|
, OrdTable, (<:), (<=:), (>:), (>=:), ascTable, descTable
|
||||||
, lit
|
, lit
|
||||||
, bool
|
, bool
|
||||||
, case_
|
, case_
|
||||||
|
@ -289,7 +289,7 @@ genTypedQuery env = Gen.recursive Gen.choice nonrecursive recursive
|
|||||||
Gen.integral (Range.linear 0 ((maxBound `div` 2) - 1))
|
Gen.integral (Range.linear 0 ((maxBound `div` 2) - 1))
|
||||||
|
|
||||||
|
|
||||||
genQueryOfType :: Rel8.Table Rel8.Expr i
|
genQueryOfType :: (Rel8.Table Rel8.Expr i, Show o)
|
||||||
=> Environment env -> Ty i o -> Gen (TypedQuery env i o)
|
=> Environment env -> Ty i o -> Gen (TypedQuery env i o)
|
||||||
genQueryOfType env tableType = do
|
genQueryOfType env tableType = do
|
||||||
ATypedQuery x <- genTypedQuery env
|
ATypedQuery x <- genTypedQuery env
|
||||||
@ -421,6 +421,16 @@ data Expr :: Context -> Type -> Type -> Type where
|
|||||||
-> Expr env i o
|
-> Expr env i o
|
||||||
-> Expr env i o
|
-> Expr env i o
|
||||||
|
|
||||||
|
(:<>) :: (Rel8.DBSemigroup i)
|
||||||
|
=> Expr env (Rel8.Expr i) o
|
||||||
|
-> Expr env (Rel8.Expr i) o
|
||||||
|
-> Expr env (Rel8.Expr i) o
|
||||||
|
|
||||||
|
(:<:) :: (Rel8.OrdTable i, Show o)
|
||||||
|
=> Expr env i o
|
||||||
|
-> Expr env i o
|
||||||
|
-> Expr env (Rel8.Expr Bool) Bool
|
||||||
|
|
||||||
|
|
||||||
deriving stock instance Show o => Show (Expr env i o)
|
deriving stock instance Show o => Show (Expr env i o)
|
||||||
|
|
||||||
@ -448,7 +458,7 @@ genTableIx t env =
|
|||||||
xs -> Just $ Gen.element xs
|
xs -> Just $ Gen.element xs
|
||||||
|
|
||||||
|
|
||||||
genExpr :: Rel8.Table Rel8.Expr i
|
genExpr :: (Rel8.Table Rel8.Expr i, Show o)
|
||||||
=> Ty i o -> Environment env -> Gen (Expr env i o)
|
=> Ty i o -> Environment env -> Gen (Expr env i o)
|
||||||
genExpr t env = Gen.recursive Gen.choice nonrecursive recursive
|
genExpr t env = Gen.recursive Gen.choice nonrecursive recursive
|
||||||
where
|
where
|
||||||
@ -556,7 +566,7 @@ genExpr t env = Gen.recursive Gen.choice nonrecursive recursive
|
|||||||
|
|
||||||
recursive = catMaybes
|
recursive = catMaybes
|
||||||
[ case_, altTableListTable, isJustTable, isNothingTable, isLeftTable
|
[ case_, altTableListTable, isJustTable, isNothingTable, isLeftTable
|
||||||
, isRightTable, eqTableListTable
|
, isRightTable, eqTableListTable, semigroupOp, ltTable
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
case_ = Just $
|
case_ = Just $
|
||||||
@ -607,6 +617,18 @@ genExpr t env = Gen.recursive Gen.choice nonrecursive recursive
|
|||||||
ATEqTable t <- genTEqTable
|
ATEqTable t <- genTEqTable
|
||||||
EqTable <$> genExpr (TListTable t) env <*> genExpr (TListTable t) env
|
EqTable <$> genExpr (TListTable t) env <*> genExpr (TListTable t) env
|
||||||
|
|
||||||
|
semigroupOp = do
|
||||||
|
TNotNull _ <- pure t
|
||||||
|
Dict <- hasDBSemigroupInstance t
|
||||||
|
pure do
|
||||||
|
(:<>) <$> genExpr t env <*> genExpr t env
|
||||||
|
|
||||||
|
ltTable = do
|
||||||
|
TNotNull TBool <- pure t
|
||||||
|
pure do
|
||||||
|
ATOrdTable t' <- genTOrdTable
|
||||||
|
(:<:) <$> genExpr t' env <*> genExpr t' env
|
||||||
|
|
||||||
|
|
||||||
find :: TableIx env i o -> Results env -> i
|
find :: TableIx env i o -> Results env -> i
|
||||||
find Here (Store x _) = x
|
find Here (Store x _) = x
|
||||||
@ -615,30 +637,32 @@ find (There ix) (Store _ env) = find ix env
|
|||||||
|
|
||||||
compileExpr :: Results env -> Expr env i o -> i
|
compileExpr :: Results env -> Expr env i o -> i
|
||||||
compileExpr env = \case
|
compileExpr env = \case
|
||||||
PairTable x y -> (compileExpr env x, compileExpr env y)
|
PairTable x y -> (compileExpr env x, compileExpr env y)
|
||||||
TrioTable x1 x2 x3 -> (compileExpr env x1, compileExpr env x2, compileExpr env x3)
|
TrioTable x1 x2 x3 -> (compileExpr env x1, compileExpr env x2, compileExpr env x3)
|
||||||
QuartetTable x1 x2 x3 x4 -> (compileExpr env x1, compileExpr env x2, compileExpr env x3, compileExpr env x4)
|
QuartetTable x1 x2 x3 x4 -> (compileExpr env x1, compileExpr env x2, compileExpr env x3, compileExpr env x4)
|
||||||
QuintetTable x1 x2 x3 x4 x5 -> (compileExpr env x1, compileExpr env x2, compileExpr env x3, compileExpr env x4, compileExpr env x5)
|
QuintetTable x1 x2 x3 x4 x5 -> (compileExpr env x1, compileExpr env x2, compileExpr env x3, compileExpr env x4, compileExpr env x5)
|
||||||
Lookup ix -> find ix env
|
Lookup ix -> find ix env
|
||||||
JustTable t -> Rel8.justTable (compileExpr env t)
|
JustTable t -> Rel8.justTable (compileExpr env t)
|
||||||
NothingTable -> Rel8.nothingTable
|
NothingTable -> Rel8.nothingTable
|
||||||
LeftTable t -> Rel8.leftTable (compileExpr env t)
|
LeftTable t -> Rel8.leftTable (compileExpr env t)
|
||||||
RightTable t -> Rel8.rightTable (compileExpr env t)
|
RightTable t -> Rel8.rightTable (compileExpr env t)
|
||||||
ThisTable t -> Rel8.thisTable (compileExpr env t)
|
ThisTable t -> Rel8.thisTable (compileExpr env t)
|
||||||
ThatTable t -> Rel8.thatTable (compileExpr env t)
|
ThatTable t -> Rel8.thatTable (compileExpr env t)
|
||||||
ThoseTable x y -> Rel8.thoseTable (compileExpr env x) (compileExpr env y)
|
ThoseTable x y -> Rel8.thoseTable (compileExpr env x) (compileExpr env y)
|
||||||
ListTable xs -> Rel8.listTable $ compileExpr env <$> xs
|
ListTable xs -> Rel8.listTable $ compileExpr env <$> xs
|
||||||
NonEmptyTable xs -> Rel8.nonEmptyTable $ compileExpr env <$> xs
|
NonEmptyTable xs -> Rel8.nonEmptyTable $ compileExpr env <$> xs
|
||||||
EmptyTable -> Rel8.emptyTable
|
EmptyTable -> Rel8.emptyTable
|
||||||
AltTable x y -> compileExpr env x Rel8.<|>: compileExpr env y
|
AltTable x y -> compileExpr env x Rel8.<|>: compileExpr env y
|
||||||
Case alts def -> Rel8.case_ (map (bimap (compileExpr env) (compileExpr env)) alts) (compileExpr env def)
|
Case alts def -> Rel8.case_ (map (bimap (compileExpr env) (compileExpr env)) alts) (compileExpr env def)
|
||||||
LitNN x -> Rel8.lit x
|
LitNN x -> Rel8.lit x
|
||||||
LitN x -> Rel8.lit x
|
LitN x -> Rel8.lit x
|
||||||
IsJustTable t -> Rel8.isJustTable (compileExpr env t)
|
IsJustTable t -> Rel8.isJustTable (compileExpr env t)
|
||||||
IsNothingTable t -> Rel8.isNothingTable (compileExpr env t)
|
IsNothingTable t -> Rel8.isNothingTable (compileExpr env t)
|
||||||
IsLeftTable t -> Rel8.isLeftTable (compileExpr env t)
|
IsLeftTable t -> Rel8.isLeftTable (compileExpr env t)
|
||||||
IsRightTable t -> Rel8.isRightTable (compileExpr env t)
|
IsRightTable t -> Rel8.isRightTable (compileExpr env t)
|
||||||
EqTable x y -> compileExpr env x Rel8.==: compileExpr env y
|
EqTable x y -> compileExpr env x Rel8.==: compileExpr env y
|
||||||
|
(:<>) x y -> compileExpr env x Rel8.<>. compileExpr env y
|
||||||
|
(:<:) x y -> compileExpr env x Rel8.<: compileExpr env y
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -723,6 +747,40 @@ hasAltTableInstance = \case
|
|||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
|
|
||||||
|
hasOrdTableInstance :: Ty i o -> Maybe (Dict (Rel8.OrdTable i))
|
||||||
|
hasOrdTableInstance = \case
|
||||||
|
TNotNull t -> do
|
||||||
|
Dict <- hasDBOrdInstance t
|
||||||
|
Just Dict
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
|
||||||
|
hasDBSemigroupInstance :: Ty (Rel8.Expr i) o -> Maybe (Dict (Rel8.DBSemigroup i))
|
||||||
|
hasDBSemigroupInstance = \case
|
||||||
|
TNotNull TText -> Just Dict
|
||||||
|
TNotNull TLazyText -> Just Dict
|
||||||
|
TNotNull TByteString -> Just Dict
|
||||||
|
TNotNull TLazyByteString -> Just Dict
|
||||||
|
TNotNull TCalendarDiffTime -> Just Dict
|
||||||
|
TNotNull TCIText -> Just Dict
|
||||||
|
TNotNull TCILazyText -> Just Dict
|
||||||
|
TNotNull (TList _) -> Just Dict
|
||||||
|
TNotNull (TNonEmpty _) -> Just Dict
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
|
||||||
|
hasDBOrdInstance :: TDBType i -> Maybe (Dict (Rel8.DBOrd i))
|
||||||
|
hasDBOrdInstance = \case
|
||||||
|
TText -> Just Dict
|
||||||
|
TLazyText -> Just Dict
|
||||||
|
TByteString -> Just Dict
|
||||||
|
TLazyByteString -> Just Dict
|
||||||
|
TCalendarDiffTime -> Just Dict
|
||||||
|
TCIText -> Just Dict
|
||||||
|
TCILazyText -> Just Dict
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
|
||||||
eqTy :: Ty i o -> Ty i' o' -> Maybe ((i, o) :~: (i', o'))
|
eqTy :: Ty i o -> Ty i' o' -> Maybe ((i, o) :~: (i', o'))
|
||||||
eqTy x y =
|
eqTy x y =
|
||||||
case (x, y) of
|
case (x, y) of
|
||||||
@ -895,6 +953,65 @@ genTEqTable = Gen.recursive Gen.choice nonrecursive recursive
|
|||||||
ATEqTable $ TNonEmptyTable x
|
ATEqTable $ TNonEmptyTable x
|
||||||
|
|
||||||
|
|
||||||
|
data ATOrdTable :: Type where
|
||||||
|
ATOrdTable :: (Rel8.OrdTable i, Show o, Rel8.Serializable i o, Eq o)
|
||||||
|
=> Ty i o -> ATOrdTable
|
||||||
|
|
||||||
|
|
||||||
|
genTOrdTable :: Gen ATOrdTable
|
||||||
|
genTOrdTable = Gen.recursive Gen.choice nonrecursive recursive
|
||||||
|
where
|
||||||
|
nonrecursive = [ exprAsTable ]
|
||||||
|
where
|
||||||
|
exprAsTable :: Gen ATOrdTable
|
||||||
|
exprAsTable = do
|
||||||
|
ATOrdExpr exprType <- genTOrdExpr
|
||||||
|
return $ ATOrdTable exprType
|
||||||
|
|
||||||
|
recursive =
|
||||||
|
[ pair, trio, quartet, quintet, eitherTable, maybeTable, theseTable
|
||||||
|
, listTable, nonEmptyTable
|
||||||
|
]
|
||||||
|
where
|
||||||
|
pair =
|
||||||
|
Gen.subterm2 genTOrdTable genTOrdTable \(ATOrdTable x) (ATOrdTable y) ->
|
||||||
|
ATOrdTable $ TTablePair x y
|
||||||
|
|
||||||
|
trio =
|
||||||
|
Gen.subterm3 genTOrdTable genTOrdTable genTOrdTable \(ATOrdTable x) (ATOrdTable y) (ATOrdTable z) ->
|
||||||
|
ATOrdTable $ TTableTrio x y z
|
||||||
|
|
||||||
|
quartet =
|
||||||
|
Gen.subtermM2 genTOrdTable genTOrdTable \(ATOrdTable x1) (ATOrdTable x2) ->
|
||||||
|
Gen.subterm2 genTOrdTable genTOrdTable \(ATOrdTable x3) (ATOrdTable x4) ->
|
||||||
|
ATOrdTable $ TTableQuartet x1 x2 x3 x4
|
||||||
|
|
||||||
|
quintet =
|
||||||
|
Gen.subtermM2 genTOrdTable genTOrdTable \(ATOrdTable x1) (ATOrdTable x2) ->
|
||||||
|
Gen.subterm3 genTOrdTable genTOrdTable genTOrdTable \(ATOrdTable x3) (ATOrdTable x4) (ATOrdTable x5) ->
|
||||||
|
ATOrdTable $ TTableQuintet x1 x2 x3 x4 x5
|
||||||
|
|
||||||
|
eitherTable =
|
||||||
|
Gen.subterm2 genTOrdTable genTOrdTable \(ATOrdTable x) (ATOrdTable y) ->
|
||||||
|
ATOrdTable $ TEitherTable x y
|
||||||
|
|
||||||
|
maybeTable =
|
||||||
|
Gen.subterm genTOrdTable \(ATOrdTable x) ->
|
||||||
|
ATOrdTable $ TMaybeTable x
|
||||||
|
|
||||||
|
theseTable =
|
||||||
|
Gen.subterm2 genTOrdTable genTOrdTable \(ATOrdTable x) (ATOrdTable y) ->
|
||||||
|
ATOrdTable $ TTheseTable x y
|
||||||
|
|
||||||
|
listTable =
|
||||||
|
Gen.subterm genTOrdTable \(ATOrdTable x) ->
|
||||||
|
ATOrdTable $ TListTable x
|
||||||
|
|
||||||
|
nonEmptyTable =
|
||||||
|
Gen.subterm genTOrdTable \(ATOrdTable x) ->
|
||||||
|
ATOrdTable $ TNonEmptyTable x
|
||||||
|
|
||||||
|
|
||||||
data ATExpr :: Type where
|
data ATExpr :: Type where
|
||||||
ATExpr :: (Show a, Rel8.Sql Rel8.DBType a, Eq a)
|
ATExpr :: (Show a, Rel8.Sql Rel8.DBType a, Eq a)
|
||||||
=> Ty (Rel8.Expr a) a -> ATExpr
|
=> Ty (Rel8.Expr a) a -> ATExpr
|
||||||
@ -905,6 +1022,11 @@ data ATEqExpr :: Type where
|
|||||||
=> Ty (Rel8.Expr a) a -> ATEqExpr
|
=> Ty (Rel8.Expr a) a -> ATEqExpr
|
||||||
|
|
||||||
|
|
||||||
|
data ATOrdExpr :: Type where
|
||||||
|
ATOrdExpr :: (Show a, Rel8.Sql Rel8.DBOrd a, Eq a)
|
||||||
|
=> Ty (Rel8.Expr a) a -> ATOrdExpr
|
||||||
|
|
||||||
|
|
||||||
genTExpr :: Gen ATExpr
|
genTExpr :: Gen ATExpr
|
||||||
genTExpr = choice
|
genTExpr = choice
|
||||||
[ genTDBType <&> \(ATDBType t) -> ATExpr $ TNotNull t
|
[ genTDBType <&> \(ATDBType t) -> ATExpr $ TNotNull t
|
||||||
@ -919,6 +1041,13 @@ genTEqExpr = choice
|
|||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
|
genTOrdExpr :: Gen ATOrdExpr
|
||||||
|
genTOrdExpr = choice
|
||||||
|
[ genTDBOrd <&> \(ATDBOrd t) -> ATOrdExpr $ TNotNull t
|
||||||
|
, genTDBOrd <&> \(ATDBOrd t) -> ATOrdExpr $ TNull t
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
data ATDBType :: Type where
|
data ATDBType :: Type where
|
||||||
ATDBType :: (Rel8.DBType a, Show a, Eq a) => TDBType a -> ATDBType
|
ATDBType :: (Rel8.DBType a, Show a, Eq a) => TDBType a -> ATDBType
|
||||||
|
|
||||||
@ -927,6 +1056,14 @@ data ATDBEq :: Type where
|
|||||||
ATDBEq :: (Rel8.DBEq a, Show a, Eq a) => TDBType a -> ATDBEq
|
ATDBEq :: (Rel8.DBEq a, Show a, Eq a) => TDBType a -> ATDBEq
|
||||||
|
|
||||||
|
|
||||||
|
data ATDBOrd :: Type where
|
||||||
|
ATDBOrd :: (Rel8.DBOrd a, Show a, Eq a) => TDBType a -> ATDBOrd
|
||||||
|
|
||||||
|
|
||||||
|
data ATDBSemigroup :: Type where
|
||||||
|
ATDBSemigroup :: (Rel8.DBSemigroup a, Show a, Eq a) => TDBType a -> ATDBSemigroup
|
||||||
|
|
||||||
|
|
||||||
data TDBType :: Type -> Type where
|
data TDBType :: Type -> Type where
|
||||||
TBool :: TDBType Bool
|
TBool :: TDBType Bool
|
||||||
TChar :: TDBType Char
|
TChar :: TDBType Char
|
||||||
@ -948,6 +1085,8 @@ data TDBType :: Type -> Type where
|
|||||||
TByteString :: TDBType StrictByteString.ByteString
|
TByteString :: TDBType StrictByteString.ByteString
|
||||||
TLazyByteString :: TDBType LazyByteString.ByteString
|
TLazyByteString :: TDBType LazyByteString.ByteString
|
||||||
TUUID :: TDBType UUID
|
TUUID :: TDBType UUID
|
||||||
|
TList :: Rel8.Sql Rel8.DBType a => TDBType a -> TDBType [a]
|
||||||
|
TNonEmpty :: Rel8.Sql Rel8.DBType a => TDBType a -> TDBType (NonEmpty a)
|
||||||
|
|
||||||
|
|
||||||
deriving stock instance Show (TDBType a)
|
deriving stock instance Show (TDBType a)
|
||||||
@ -976,6 +1115,12 @@ eqDBType x y =
|
|||||||
(TByteString, TByteString) -> Just Refl
|
(TByteString, TByteString) -> Just Refl
|
||||||
(TLazyByteString, TLazyByteString) -> Just Refl
|
(TLazyByteString, TLazyByteString) -> Just Refl
|
||||||
(TUUID, TUUID) -> Just Refl
|
(TUUID, TUUID) -> Just Refl
|
||||||
|
(TList x, TList y) -> do
|
||||||
|
Refl <- eqDBType x y
|
||||||
|
Just Refl
|
||||||
|
(TNonEmpty x, TNonEmpty y) -> do
|
||||||
|
Refl <- eqDBType x y
|
||||||
|
Just Refl
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
|
|
||||||
@ -1000,6 +1145,24 @@ genTDBEq = Gen.element
|
|||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
|
genTDBOrd :: Gen ATDBOrd
|
||||||
|
genTDBOrd = Gen.element
|
||||||
|
[ ATDBOrd TBool, ATDBOrd TChar, ATDBOrd TInt16, ATDBOrd TInt32
|
||||||
|
, ATDBOrd TInt64, ATDBOrd TFloat, ATDBOrd TDouble, ATDBOrd TScientific
|
||||||
|
, ATDBOrd TUTCTime, ATDBOrd TDay, ATDBOrd TLocalTime, ATDBOrd TCalendarDiffTime
|
||||||
|
, ATDBOrd TText, ATDBOrd TLazyText, ATDBOrd TCIText, ATDBOrd TCILazyText
|
||||||
|
, ATDBOrd TByteString, ATDBOrd TLazyByteString, ATDBOrd TUUID
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
genTDBSemigroup :: Gen ATDBSemigroup
|
||||||
|
genTDBSemigroup = Gen.element
|
||||||
|
[ ATDBSemigroup TCalendarDiffTime, ATDBSemigroup TText
|
||||||
|
, ATDBSemigroup TLazyText, ATDBSemigroup TCIText, ATDBSemigroup TCILazyText
|
||||||
|
, ATDBSemigroup TByteString, ATDBSemigroup TLazyByteString
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
genLiteral :: TDBType a -> Gen a
|
genLiteral :: TDBType a -> Gen a
|
||||||
genLiteral = \case
|
genLiteral = \case
|
||||||
TBool -> Gen.element [True, False]
|
TBool -> Gen.element [True, False]
|
||||||
|
Loading…
Reference in New Issue
Block a user