git.iko.soy/rel8
on b0e47ec help sign in
rel8/tests/Main.hs
795 lines 24 kB history raw
1{-# language BlockArguments #-}
2{-# language DeriveAnyClass #-}
3{-# language DeriveGeneric #-}
4{-# language DerivingStrategies #-}
5{-# language FlexibleContexts #-}
6{-# language FlexibleInstances #-}
7{-# language MonoLocalBinds #-}
8{-# language OverloadedStrings #-}
9{-# language RecordWildCards #-}
10{-# language ScopedTypeVariables #-}
11{-# language StandaloneDeriving #-}
12{-# language TypeApplications #-}
14module Main
15 ( main
16 )
17where
19-- base
20import Control.Applicative ( empty, liftA2, liftA3 )
21import Control.Exception ( bracket, throwIO )
22import Control.Monad ( (>=>), void )
23import Data.Bifunctor ( bimap )
24import Data.Foldable ( for_ )
25import Data.Int ( Int32, Int64 )
26import Data.List ( nub, sort )
27import Data.Maybe ( catMaybes )
28import Data.String ( fromString )
29import Data.Word (Word32)
30import GHC.Generics ( Generic )
32-- bytestring
33import qualified Data.ByteString.Lazy
35-- case-insensitive
36import Data.CaseInsensitive ( mk )
38-- containers
39import qualified Data.Map.Strict as Map
41-- hasql
42import Hasql.Connection ( Connection, acquire, release )
43import Hasql.Session ( sql, run )
45-- hasql-transaction
46import Hasql.Transaction ( Transaction, condemn, statement )
47import qualified Hasql.Transaction.Sessions as Hasql
49-- hedgehog
50import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
51import qualified Hedgehog.Gen as Gen
52import qualified Hedgehog.Range as Range
54-- mmorph
55import Control.Monad.Morph ( hoist )
57-- rel8
58import Rel8 ( Result )
59import qualified Rel8
61-- scientific
62import Data.Scientific ( Scientific )
64-- tasty
65import Test.Tasty
67-- tasty-hedgehog
68import Test.Tasty.Hedgehog ( testProperty )
70-- text
71import Data.Text ( Text, pack, unpack )
72import qualified Data.Text.Lazy
73import Data.Text.Encoding ( decodeUtf8 )
75-- time
76import Data.Time
78-- transformers
79import Control.Monad.Trans.Class ( lift )
81-- tmp-postgres
82import qualified Database.Postgres.Temp as TmpPostgres
84-- uuid
85import qualified Data.UUID
88main :: IO ()
89main = defaultMain tests
92tests :: TestTree
93tests =
94 withResource startTestDatabase stopTestDatabase \getTestDatabase ->
95 testGroup "rel8"
96 [ testSelectTestTable getTestDatabase
97 , testWhere_ getTestDatabase
98 , testFilter getTestDatabase
99 , testLimit getTestDatabase
100 , testUnion getTestDatabase
101 , testDistinct getTestDatabase
102 , testExists getTestDatabase
103 , testOptional getTestDatabase
104 , testAnd getTestDatabase
105 , testOr getTestDatabase
106 , testNot getTestDatabase
107 , testBool getTestDatabase
108 , testAp getTestDatabase
109 , testDBType getTestDatabase
110 , testDBEq getTestDatabase
111 , testTableEquality getTestDatabase
112 , testFromString getTestDatabase
113 , testCatMaybeTable getTestDatabase
114 , testCatMaybe getTestDatabase
115 , testMaybeTable getTestDatabase
116 , testNestedTables getTestDatabase
117 , testMaybeTableApplicative getTestDatabase
118 , testLogicalFixities getTestDatabase
119 , testUpdate getTestDatabase
120 , testDelete getTestDatabase
121 , testSelectNestedPairs getTestDatabase
122 , testSelectArray getTestDatabase
123 , testNestedMaybeTable getTestDatabase
124 , testEvaluate getTestDatabase
125 ]
127 where
129 startTestDatabase = do
130 db <- TmpPostgres.start >>= either throwIO return
132 bracket (either (error . show) return =<< acquire (TmpPostgres.toConnectionString db)) release \conn -> void do
133 flip run conn do
134 sql "CREATE EXTENSION citext"
135 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"
136 sql "CREATE SEQUENCE test_seq"
138 return db
140 stopTestDatabase = TmpPostgres.stop
143connect :: TmpPostgres.DB -> IO Connection
144connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure
147databasePropertyTest
148 :: TestName
149 -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())
150 -> IO TmpPostgres.DB -> TestTree
151databasePropertyTest testName f getTestDatabase =
152 withResource (connect =<< getTestDatabase) release $ \c ->
153 testProperty testName $ property do
154 connection <- lift c
155 f $ test . hoist \m -> do
156 e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection
157 either throwIO pure e
160data TestTable f = TestTable
161 { testTableColumn1 :: Rel8.Column f Text
162 , testTableColumn2 :: Rel8.Column f Bool
163 }
164 deriving stock Generic
165 deriving anyclass Rel8.Rel8able
168deriving stock instance Eq (TestTable Result)
169deriving stock instance Ord (TestTable Result)
170deriving stock instance Show (TestTable Result)
173testTableSchema :: Rel8.TableSchema (TestTable Rel8.Name)
174testTableSchema =
175 Rel8.TableSchema
176 { name = "test_table"
177 , schema = Nothing
178 , columns = TestTable
179 { testTableColumn1 = "column1"
180 , testTableColumn2 = "column2"
181 }
182 }
185testSelectTestTable :: IO TmpPostgres.DB -> TestTree
186testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
187 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
189 transaction do
190 selected <- lift do
191 statement () $ Rel8.insert Rel8.Insert
192 { into = testTableSchema
193 , rows = Rel8.values $ map Rel8.lit rows
194 , onConflict = Rel8.DoNothing
195 , returning = pure ()
196 }
198 statement () $ Rel8.select do
199 Rel8.each testTableSchema
201 sort selected === sort rows
203 cover 1 "Empty" $ null rows
204 cover 1 "Singleton" $ null $ drop 1 rows
205 cover 1 ">1 row" $ not $ null $ drop 1 rows
208testWhere_ :: IO TmpPostgres.DB -> TestTree
209testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do
210 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
212 magicBool <- forAll Gen.bool
214 let expected = filter (\t -> testTableColumn2 t == magicBool) rows
216 transaction do
217 selected <- lift do
218 statement () $ Rel8.select do
219 t <- Rel8.values $ Rel8.lit <$> rows
220 Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
221 return t
223 sort selected === sort expected
225 cover 1 "No results" $ null expected
226 cover 1 "Some results" $ not $ null expected
227 cover 1 "All results" $ expected == rows
230testFilter :: IO TmpPostgres.DB -> TestTree
231testFilter = databasePropertyTest "filter" \transaction -> do
232 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
234 transaction do
235 let expected = filter testTableColumn2 rows
237 selected <- lift do
238 statement () $ Rel8.select do
239 Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
241 sort selected === sort expected
243 cover 1 "No results" $ null expected
244 cover 1 "Some results" $ not $ null expected
245 cover 1 "All results" $ expected == rows
248testLimit :: IO TmpPostgres.DB -> TestTree
249testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do
250 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
252 n <- forAll $ Gen.integral (Range.linear 0 10)
254 transaction do
255 selected <- lift do
256 statement () $ Rel8.select do
257 Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
259 diff (length selected) (<=) (fromIntegral n)
261 for_ selected \row ->
262 diff row elem rows
264 cover 1 "n == 0" $ n == 0
265 cover 1 "n < length rows" $ fromIntegral n < length rows
266 cover 1 "n == length rows" $ fromIntegral n == length rows
267 cover 1 "n >= length rows" $ fromIntegral n >= length rows
270testUnion :: IO TmpPostgres.DB -> TestTree
271testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do
272 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
273 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
275 transaction do
276 selected <- lift do
277 statement () $ Rel8.select do
278 Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
280 sort selected === sort (nub (left ++ right))
283testDistinct :: IO TmpPostgres.DB -> TestTree
284testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
285 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
287 transaction do
288 selected <- lift do
289 statement () $ Rel8.select do
290 Rel8.distinct do
291 Rel8.values (Rel8.lit <$> rows)
293 sort selected === nub (sort rows)
295 cover 1 "Empty" $ null rows
296 cover 1 "Duplicates" $ not (null rows) && rows /= nub rows
297 cover 1 "No duplicates" $ not (null rows) && rows == nub rows
300testExists :: IO TmpPostgres.DB -> TestTree
301testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
302 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
304 transaction do
305 exists <- lift do
306 statement () $ Rel8.select do
307 Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
309 case rows of
310 [] -> exists === [False]
311 _ -> exists === [True]
314testOptional :: IO TmpPostgres.DB -> TestTree
315testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
316 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
318 transaction do
319 selected <- lift do
320 statement () $ Rel8.select do
321 Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
323 case rows of
324 [] -> selected === [Nothing]
325 _ -> sort selected === fmap Just (sort rows)
328testAnd :: IO TmpPostgres.DB -> TestTree
329testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
330 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
332 transaction do
333 [result] <- lift do
334 statement () $ Rel8.select do
335 pure $ Rel8.lit x Rel8.&&. Rel8.lit y
337 result === (x && y)
340testOr :: IO TmpPostgres.DB -> TestTree
341testOr = databasePropertyTest "OR (||.)" \transaction -> do
342 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
344 transaction do
345 [result] <- lift do
346 statement () $ Rel8.select $ pure $
347 Rel8.lit x Rel8.||. Rel8.lit y
349 result === (x || y)
352testLogicalFixities :: IO TmpPostgres.DB -> TestTree
353testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
354 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
356 transaction do
357 [result] <- lift do
358 statement () $ Rel8.select do
359 pure $ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
361 result === (u || v && w == x)
364testNot :: IO TmpPostgres.DB -> TestTree
365testNot = databasePropertyTest "NOT (not_)" \transaction -> do
366 x <- forAll Gen.bool
368 transaction do
369 [result] <- lift do
370 statement () $ Rel8.select do
371 pure $ Rel8.not_ $ Rel8.lit x
373 result === not x
376testBool :: IO TmpPostgres.DB -> TestTree
377testBool = databasePropertyTest "ifThenElse_" \transaction -> do
378 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
380 transaction do
381 [result] <- lift do
382 statement () $ Rel8.select do
383 pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
385 result === if x then y else z
388testAp :: IO TmpPostgres.DB -> TestTree
389testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do
390 (rows1, rows2) <- forAll $
391 liftA2 (,)
392 (Gen.list (Range.linear 1 10) genTestTable)
393 (Gen.list (Range.linear 1 10) genTestTable)
395 transaction do
396 result <- lift do
397 statement () $ Rel8.select do
398 liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
400 sort result === sort (liftA2 (,) rows1 rows2)
403testDBType :: IO TmpPostgres.DB -> TestTree
404testDBType getTestDatabase = testGroup "DBType instances"
405 [ dbTypeTest "Bool" Gen.bool
406 , dbTypeTest "ByteString" $ Gen.bytes (Range.linear 0 128)
407 , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode
408 , dbTypeTest "CI Text" $ mk <$> Gen.text (Range.linear 0 10) Gen.unicode
409 , dbTypeTest "Day" genDay
410 , dbTypeTest "Double" $ (/10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100)
411 , dbTypeTest "Float" $ (/10) . fromIntegral @Int @Float <$> Gen.integral (Range.linear (-100) 100)
412 , dbTypeTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded
413 , dbTypeTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded
414 , dbTypeTest "Lazy ByteString" $ Data.ByteString.Lazy.fromStrict <$> Gen.bytes (Range.linear 0 128)
415 , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode
416 , dbTypeTest "LocalTime" genLocalTime
417 , dbTypeTest "Scientific" $ (/10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100)
418 , dbTypeTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode
419 , dbTypeTest "TimeOfDay" genTimeOfDay
420 , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime
421 , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32
422 ]
424 where
425 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree
426 dbTypeTest name generator = testGroup name
427 [ databasePropertyTest name (t generator) getTestDatabase
428 , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
429 ]
431 t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)
432 => Gen a
433 -> (TestT Transaction () -> PropertyT IO b)
434 -> PropertyT IO b
435 t generator transaction = do
436 x <- forAll generator
438 transaction do
439 [res] <- lift do
440 statement () $ Rel8.select do
441 pure (Rel8.litExpr x)
442 diff res (==) x
444 genDay :: Gen Day
445 genDay = do
446 year <- Gen.integral (Range.linear 1970 3000)
447 month <- Gen.integral (Range.linear 1 12)
448 day <- Gen.integral (Range.linear 1 31)
449 Gen.just $ pure $ fromGregorianValid year month day
451 genDiffTime :: Gen DiffTime
452 genDiffTime = secondsToDiffTime <$> Gen.integral (Range.linear 0 86401)
454 genTimeOfDay :: Gen TimeOfDay
455 genTimeOfDay = do
456 hour <- Gen.integral (Range.linear 0 23)
457 minute <- Gen.integral (Range.linear 0 59)
458 sec <- fromIntegral @Int <$> Gen.integral (Range.linear 0 59)
459 Gen.just $ pure $ makeTimeOfDayValid hour minute sec
461 genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
463 genWord32 :: Gen Word32
464 genWord32 = Gen.integral Range.linearBounded
467testDBEq :: IO TmpPostgres.DB -> TestTree
468testDBEq getTestDatabase = testGroup "DBEq instances"
469 [ dbEqTest "Bool" Gen.bool
470 , dbEqTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded
471 , dbEqTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded
472 , dbEqTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode
473 ]
475 where
476 dbEqTest :: (Eq a, Show a, Rel8.DBEq a) => TestName -> Gen a -> TestTree
477 dbEqTest name generator = testGroup name
478 [ databasePropertyTest name (t generator) getTestDatabase
479 , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
480 ]
482 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)
483 => Gen a
484 -> (TestT Transaction () -> PropertyT IO ())
485 -> PropertyT IO ()
486 t generator transaction = do
487 (x, y) <- forAll (liftA2 (,) generator generator)
489 transaction do
490 [res] <- lift do
491 statement () $ Rel8.select do
492 pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
493 res === (x == y)
496testTableEquality :: IO TmpPostgres.DB -> TestTree
497testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
498 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
500 transaction do
501 [eq] <- lift do
502 statement () $ Rel8.select do
503 pure $ Rel8.lit x Rel8.==: Rel8.lit y
505 eq === (x == y)
508testFromString :: IO TmpPostgres.DB -> TestTree
509testFromString = databasePropertyTest "FromString" \transaction -> do
510 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
512 transaction do
513 [result] <- lift do
514 statement () $ Rel8.select do
515 pure $ fromString str
516 result === pack str
519testCatMaybeTable :: IO TmpPostgres.DB -> TestTree
520testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
521 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
523 transaction do
524 selected <- lift do
525 statement () $ Rel8.select do
526 testTable <- Rel8.values $ Rel8.lit <$> rows
527 Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
529 sort selected === sort (filter testTableColumn2 rows)
532testCatMaybe :: IO TmpPostgres.DB -> TestTree
533testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
534 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
536 transaction do
537 selected <- lift do
538 statement () $ Rel8.select do
539 Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
541 sort selected === sort (catMaybes rows)
544testMaybeTable :: IO TmpPostgres.DB -> TestTree
545testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
546 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
548 transaction do
549 selected <- lift do
550 statement () $ Rel8.select do
551 Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
553 case rows of
554 [] -> selected === [def]
555 _ -> sort selected === sort rows
558data TwoTestTables f =
559 TwoTestTables
560 { testTable1 :: TestTable f
561 , testTable2 :: TestTable f
562 }
563 deriving stock Generic
564 deriving anyclass Rel8.Rel8able
567deriving stock instance Eq (TwoTestTables Result)
568deriving stock instance Ord (TwoTestTables Result)
569deriving stock instance Show (TwoTestTables Result)
572testNestedTables :: IO TmpPostgres.DB -> TestTree
573testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> evalM do
574 rows <- forAll do
575 Gen.list (Range.linear 0 10) $
576 liftA2 TwoTestTables genTestTable genTestTable
578 transaction do
579 selected <- lift do
580 statement () $ Rel8.select do
581 Rel8.values (Rel8.lit <$> rows)
583 sort selected === sort rows
586testMaybeTableApplicative :: IO TmpPostgres.DB -> TestTree
587testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction -> evalM do
588 rows1 <- genRows
589 rows2 <- genRows
591 transaction do
592 selected <- lift do
593 statement () $ Rel8.select do
594 as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
595 bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
596 pure $ liftA2 (,) as bs
598 case (rows1, rows2) of
599 ([], []) -> selected === [Nothing]
600 ([], bs) -> selected === (Nothing <$ bs)
601 (as, []) -> selected === (Nothing <$ as)
602 (as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)
603 where
604 genRows :: PropertyT IO [TestTable Result]
605 genRows = forAll do
606 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
609genTestTable :: Gen (TestTable Result)
610genTestTable = do
611 testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum
612 testTableColumn2 <- Gen.bool
613 return TestTable{..}
616testUpdate :: IO TmpPostgres.DB -> TestTree
617testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
618 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
620 transaction do
621 selected <- lift do
622 statement () $ Rel8.insert Rel8.Insert
623 { into = testTableSchema
624 , rows = Rel8.values $ map Rel8.lit $ Map.keys rows
625 , onConflict = Rel8.DoNothing
626 , returning = pure ()
627 }
629 statement () $ Rel8.update Rel8.Update
630 { target = testTableSchema
631 , from = pure ()
632 , set = \_ r ->
633 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows
634 in
635 foldl
636 ( \e (x, y) ->
637 Rel8.bool
638 e
639 y
640 ( testTableColumn1 r Rel8.==. testTableColumn1 x Rel8.&&.
641 testTableColumn2 r Rel8.==. testTableColumn2 x
642 )
643 )
644 r
645 updates
646 , updateWhere = \_ _ -> Rel8.lit True
647 , returning = pure ()
648 }
650 statement () $ Rel8.select do
651 Rel8.each testTableSchema
653 sort selected === sort (Map.elems rows)
655 cover 1 "Empty" $ null rows
656 cover 1 "Singleton" $ null $ drop 1 $ Map.keys rows
657 cover 1 ">1 row" $ not $ null $ drop 1 $ Map.keys rows
660testDelete :: IO TmpPostgres.DB -> TestTree
661testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
662 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
664 transaction do
665 (deleted, selected) <- lift do
666 statement () $ Rel8.insert Rel8.Insert
667 { into = testTableSchema
668 , rows = Rel8.values $ map Rel8.lit rows
669 , onConflict = Rel8.DoNothing
670 , returning = pure ()
671 }
673 deleted <- statement () $ Rel8.delete Rel8.Delete
674 { from = testTableSchema
675 , using = pure ()
676 , deleteWhere = const testTableColumn2
677 , returning = Rel8.Projection id
678 }
680 selected <- statement () $ Rel8.select do
681 Rel8.each testTableSchema
683 pure (deleted, selected)
685 sort (deleted <> selected) === sort rows
688newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
689 deriving stock Generic
690 deriving anyclass Rel8.Rel8able
692deriving stock instance Eq (HKNestedPair Result)
693deriving stock instance Ord (HKNestedPair Result)
694deriving stock instance Show (HKNestedPair Result)
697testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
698testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
699 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
701 transaction do
702 selected <- lift do
703 statement () $ Rel8.select do
704 Rel8.values $ map Rel8.lit rows
706 sort selected === sort rows
709testSelectArray :: IO TmpPostgres.DB -> TestTree
710testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
711 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
713 transaction do
714 selected <- lift do
715 statement () $ Rel8.select do
716 Rel8.many $ Rel8.values (map Rel8.lit rows)
718 selected === [foldMap pure rows]
720 selected' <- lift do
721 statement () $ Rel8.select do
722 a <- Rel8.catListTable =<< do
723 Rel8.many $ Rel8.values (map Rel8.lit rows)
724 b <- Rel8.catListTable =<< do
725 Rel8.many $ Rel8.values (map Rel8.lit rows)
726 pure (a, b)
728 selected' === liftA2 (,) rows rows
731data NestedMaybeTable f = NestedMaybeTable
732 { nmt1 :: Rel8.Column f Bool
733 , nmt2 :: Rel8.HMaybe f (TestTable f)
734 }
735 deriving stock Generic
736 deriving anyclass Rel8.Rel8able
739deriving stock instance Eq (NestedMaybeTable Result)
740deriving stock instance Ord (NestedMaybeTable Result)
741deriving stock instance Show (NestedMaybeTable Result)
744testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
745testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
746 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
748 transaction do
749 selected <- lift do
750 statement () $ Rel8.select do
751 x <- Rel8.values [Rel8.lit example]
752 pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
754 selected === [True]
757testEvaluate :: IO TmpPostgres.DB -> TestTree
758testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do
760 transaction do
761 selected <- lift do
762 statement () $ Rel8.select do
763 x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
764 y <- Rel8.evaluate (Rel8.nextval "test_seq")
765 pure (x, (y, y))
767 normalize selected ===
768 [ ('a', (0, 0))
769 , ('b', (1, 1))
770 , ('c', (2, 2))
771 ]
773 selected' <- lift do
774 statement () $ Rel8.select do
775 x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
776 y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
777 z <- Rel8.evaluate (Rel8.nextval "test_seq")
778 pure ((x, y), (z, z))
780 normalize selected' ===
781 [ (('a', 'd'), (0, 0))
782 , (('a', 'e'), (1, 1))
783 , (('a', 'f'), (2, 2))
784 , (('b', 'd'), (3, 3))
785 , (('b', 'e'), (4, 4))
786 , (('b', 'f'), (5, 5))
787 , (('c', 'd'), (6, 6))
788 , (('c', 'e'), (7, 7))
789 , (('c', 'f'), (8, 8))
790 ]
792 where
793 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]
794 normalize [] = []
795 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs