mirror of
https://github.com/circuithub/rel8.git
synced 2024-10-27 02:08:37 +03:00
Better testMaybeTableApplicative
This commit is contained in:
parent
0e1bccf1f7
commit
8f7e1da473
20
src/Rel8.hs
20
src/Rel8.hs
@ -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
|
||||
|
@ -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)
|
||||
|
Loading…
Reference in New Issue
Block a user