circuithub/rel8
1
1
Fork 0
mirror of https://github.com/circuithub/rel8.git synced 2024-10-27 02:08:37 +03:00
Code Issues Projects Releases Wiki Activity

Better testMaybeTableApplicative

Browse Source
This commit is contained in:
Shane 2021-03-02 20:35:50 +00:00
parent 0e1bccf1f7
commit 8f7e1da473
No known key found for this signature in database
GPG Key ID: C1D5BF1DE4F6D319
2 changed files with 26 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
src/Rel8.hs
View File

@ -62,6 +62,8 @@ module Rel8
, null_
, isNull
, liftNull
, mapNull
, liftOpNull
, catMaybe
-- ** Boolean operations
@ -435,6 +437,14 @@ liftNull :: Expr a -> Expr ( Maybe a )
liftNull = retype
mapNull :: (Expr a -> Expr b) -> Expr (Maybe a) -> Expr (Maybe b)
mapNull f = retype . f . retype
liftOpNull :: (Expr a -> Expr b -> Expr c) -> Expr (Maybe a) -> Expr (Maybe b) -> Expr (Maybe c)
liftOpNull f a b = retype (f (retype a) (retype b))
{-| Filter a 'Query' that might return @null@ to a 'Query' without any @null@s.
Corresponds to 'catMaybes'.
@ -1055,18 +1065,12 @@ data MaybeTable t where
instance Applicative MaybeTable where
pure = MaybeTable (lit (Just True))
MaybeTable t f <*> MaybeTable t' a = MaybeTable (liftNull (nullOr t t')) (f a)
where
nullOr x y =
null_ (lit False) (\x' -> null_ (lit False) (x' ||.) y) x
MaybeTable t f <*> MaybeTable t' a = MaybeTable (liftOpNull (&&.) t t') (f a)
instance Monad MaybeTable where
MaybeTable t a >>= f = case f a of
MaybeTable t' b -> MaybeTable (liftNull (nullOr t t')) b
where
nullOr x y =
null_ (lit False) (\x' -> null_ (lit False) (x' ||.) y) x
MaybeTable t' b -> MaybeTable (liftOpNull (&&.) t t') b
data HMaybeTable g f = HMaybeTable

29
tests/Main.hs
View File

@ -550,25 +550,24 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval
testMaybeTableApplicative :: IO TmpPostgres.DB -> TestTree
testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction -> evalM do
rows <- forAll do
-- TODO: We shouldn't need the @Identity type application, but without
-- it this fails to type check.
Gen.list (Range.linear 0 10) $ liftA2 (TestTable @Identity) (Gen.list (Range.linear 0 10) Gen.unicode) (pure True)
rows1 <- genRows
rows2 <- genRows
transaction \connection -> do
void $ liftIO $ executeMany connection
[sql| INSERT INTO test_table (column1, column2) VALUES (?, ?) |]
[ ( testTableColumn1, testTableColumn2 ) | TestTable{..} <- rows ]
selected <- Rel8.select connection do
fmap (pure id <*>) (Rel8.optional (Rel8.each testTableSchema))
let rowsExpected = case rows of
[] -> [Nothing]
xs -> map Just xs
sort selected === sort rowsExpected
as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
pure $ liftA2 (,) as bs
case (rows1, rows2) of
([], []) -> selected === [Nothing]
([], bs) -> selected === (Nothing <$ bs)
(as, []) -> selected === (Nothing <$ as)
(as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)
where
genRows :: PropertyT IO [TestTable Identity]
genRows = forAll do
Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.list (Range.linear 0 10) Gen.unicode) (pure True)
rollingBack
:: (MonadBaseControl IO m, MonadIO m)