git.iko.soy/rel8
on 97d89cf help sign in
rel8/tests/Main.hs
779 lines 25 kB history raw
1{-# language BlockArguments #-}
2{-# language DataKinds #-}
3{-# language DeriveAnyClass #-}
4{-# language DeriveGeneric #-}
5{-# language DerivingStrategies #-}
6{-# language DisambiguateRecordFields #-}
7{-# language FlexibleContexts #-}
8{-# language FlexibleInstances #-}
9{-# language GADTs #-}
10{-# language NamedFieldPuns #-}
11{-# language OverloadedStrings #-}
12{-# language RecordWildCards #-}
13{-# language ScopedTypeVariables #-}
14{-# language StandaloneDeriving #-}
15{-# language TypeApplications #-}
17{-# options_ghc -fno-warn-redundant-constraints #-}
19module Main
20 ( main
21 )
22where
24-- base
25import Control.Applicative ( liftA2, liftA3 )
26import Control.Monad (void)
27import Control.Monad.IO.Class ( MonadIO, liftIO )
28import Data.Bifunctor ( bimap )
29import Data.Foldable ( for_ )
30import Data.Int ( Int32, Int64 )
31import Data.List ( nub, sort )
32import Data.Maybe ( catMaybes )
33import Data.String ( fromString )
34import Data.Word (Word32)
35import GHC.Generics ( Generic )
37-- bytestring
38import qualified Data.ByteString.Lazy
40-- case-insensitive
41import Data.CaseInsensitive (mk)
43-- containers
44import qualified Data.Map.Strict as Map
46-- hasql
47import Hasql.Connection ( Connection, acquire, release )
48import Hasql.Session ( sql, run )
50-- hedgehog
51import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
52import qualified Hedgehog.Gen as Gen
53import qualified Hedgehog.Range as Range
55-- lifted-base
56import Control.Exception.Lifted ( bracket, throwIO, bracket_ )
58-- monad-control
59import Control.Monad.Trans.Control ( MonadBaseControl )
61-- rel8
62import Rel8 ( Result )
63import qualified Rel8
65-- scientific
66import Data.Scientific ( Scientific )
68-- tasty
69import Test.Tasty
71-- tasty-hedgehog
72import Test.Tasty.Hedgehog ( testProperty )
74-- text
75import Data.Text (Text, pack)
76import qualified Data.Text.Lazy
78-- time
79import Data.Time
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
143databasePropertyTest
144 :: TestName
145 -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())
146 -> IO TmpPostgres.DB -> TestTree
147databasePropertyTest testName f getTestDatabase =
148 withResource connect release $ \c ->
149 testProperty testName $ property do
150 connection <- liftIO c
151 f \g -> test $ rollingBack connection $ g connection
153 where
155 connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase
158data TestTable f = TestTable
159 { testTableColumn1 :: Rel8.Column f Text
160 , testTableColumn2 :: Rel8.Column f Bool
161 }
162 deriving stock Generic
163 deriving anyclass Rel8.Rel8able
166deriving stock instance Eq (TestTable Result)
167deriving stock instance Ord (TestTable Result)
168deriving stock instance Show (TestTable Result)
171testTableSchema :: Rel8.TableSchema (TestTable Rel8.Name)
172testTableSchema =
173 Rel8.TableSchema
174 { name = "test_table"
175 , schema = Nothing
176 , columns = TestTable
177 { testTableColumn1 = "column1"
178 , testTableColumn2 = "column2"
179 }
180 }
183testSelectTestTable :: IO TmpPostgres.DB -> TestTree
184testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
185 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
187 transaction \connection -> do
188 void do
189 liftIO $ Rel8.insert connection
190 Rel8.Insert
191 { into = testTableSchema
192 , rows = map Rel8.lit rows
193 , onConflict = Rel8.DoNothing
194 , returning = Rel8.NumberOfRowsAffected
195 }
197 selected <- liftIO $ Rel8.select connection do
198 Rel8.each testTableSchema
200 sort selected === sort rows
202 cover 1 "Empty" $ null rows
203 cover 1 "Singleton" $ null $ drop 1 rows
204 cover 1 ">1 row" $ not $ null $ drop 1 rows
207testWhere_ :: IO TmpPostgres.DB -> TestTree
208testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do
209 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
211 magicBool <- forAll Gen.bool
213 let expected = filter (\t -> testTableColumn2 t == magicBool) rows
215 transaction \connection -> do
216 selected <- liftIO $ Rel8.select connection do
217 t <- Rel8.values $ Rel8.lit <$> rows
218 Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
219 return t
221 sort selected === sort expected
223 cover 1 "No results" $ null expected
224 cover 1 "Some results" $ not $ null expected
225 cover 1 "All results" $ expected == rows
228testFilter :: IO TmpPostgres.DB -> TestTree
229testFilter = databasePropertyTest "filter" \transaction -> do
230 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
232 transaction \connection -> do
233 let expected = filter testTableColumn2 rows
235 selected <- liftIO $ Rel8.select connection
236 $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
238 sort selected === sort expected
240 cover 1 "No results" $ null expected
241 cover 1 "Some results" $ not $ null expected
242 cover 1 "All results" $ expected == rows
245testLimit :: IO TmpPostgres.DB -> TestTree
246testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do
247 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
249 n <- forAll $ Gen.integral (Range.linear 0 10)
251 transaction \connection -> do
252 selected <- liftIO $ Rel8.select connection do
253 Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
255 diff (length selected) (<=) (fromIntegral n)
257 for_ selected \row ->
258 diff row elem rows
260 cover 1 "n == 0" $ n == 0
261 cover 1 "n < length rows" $ fromIntegral n < length rows
262 cover 1 "n == length rows" $ fromIntegral n == length rows
263 cover 1 "n >= length rows" $ fromIntegral n >= length rows
266testUnion :: IO TmpPostgres.DB -> TestTree
267testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do
268 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
269 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
271 transaction \connection -> do
272 selected <- liftIO $ Rel8.select connection do
273 Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
275 sort selected === sort (nub (left ++ right))
278testDistinct :: IO TmpPostgres.DB -> TestTree
279testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
280 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
282 transaction \connection -> do
283 selected <- liftIO $ Rel8.select connection $ Rel8.distinct do
284 Rel8.values (Rel8.lit <$> rows)
286 sort selected === nub (sort rows)
288 cover 1 "Empty" $ null rows
289 cover 1 "Duplicates" $ not (null rows) && rows /= nub rows
290 cover 1 "No duplicates" $ not (null rows) && rows == nub rows
293testExists :: IO TmpPostgres.DB -> TestTree
294testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
295 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
297 transaction \connection -> do
298 exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
300 case rows of
301 [] -> exists === [False]
302 _ -> exists === [True]
305testOptional :: IO TmpPostgres.DB -> TestTree
306testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
307 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
309 transaction \connection -> do
310 selected <- liftIO $ Rel8.select connection do
311 Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
313 case rows of
314 [] -> selected === [Nothing]
315 _ -> sort selected === fmap Just (sort rows)
318testAnd :: IO TmpPostgres.DB -> TestTree
319testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
320 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
322 transaction \connection -> do
323 [result] <- liftIO $ Rel8.select connection $ pure $
324 Rel8.lit x Rel8.&&. Rel8.lit y
326 result === (x && y)
329testOr :: IO TmpPostgres.DB -> TestTree
330testOr = databasePropertyTest "OR (||.)" \transaction -> do
331 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
333 transaction \connection -> do
334 [result] <- liftIO $ Rel8.select connection $ pure $
335 Rel8.lit x Rel8.||. Rel8.lit y
337 result === (x || y)
340testLogicalFixities :: IO TmpPostgres.DB -> TestTree
341testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
342 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
344 transaction \connection -> do
345 [result] <- liftIO $ Rel8.select connection $ pure $
346 Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
348 result === (u || v && w == x)
351testNot :: IO TmpPostgres.DB -> TestTree
352testNot = databasePropertyTest "NOT (not_)" \transaction -> do
353 x <- forAll Gen.bool
355 transaction \connection -> do
356 [result] <- liftIO $ Rel8.select connection $ pure $
357 Rel8.not_ $ Rel8.lit x
359 result === not x
362testBool :: IO TmpPostgres.DB -> TestTree
363testBool = databasePropertyTest "ifThenElse_" \transaction -> do
364 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
366 transaction \connection -> do
367 [result] <- liftIO $ Rel8.select connection $ pure $
368 Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
370 result === if x then y else z
373testAp :: IO TmpPostgres.DB -> TestTree
374testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do
375 (rows1, rows2) <- forAll $
376 liftA2 (,)
377 (Gen.list (Range.linear 1 10) genTestTable)
378 (Gen.list (Range.linear 1 10) genTestTable)
380 transaction \connection -> do
381 result <- liftIO $ Rel8.select connection $ do
382 liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
384 sort result === sort (liftA2 (,) rows1 rows2)
387testDBType :: IO TmpPostgres.DB -> TestTree
388testDBType getTestDatabase = testGroup "DBType instances"
389 [ dbTypeTest "Bool" Gen.bool
390 , dbTypeTest "ByteString" $ Gen.bytes (Range.linear 0 128)
391 , dbTypeTest "CI Lazy Text" $ mk . Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode
392 , dbTypeTest "CI Text" $ mk <$> Gen.text (Range.linear 0 10) Gen.unicode
393 , dbTypeTest "Day" genDay
394 , dbTypeTest "Double" $ (/10) . fromIntegral @Int @Double <$> Gen.integral (Range.linear (-100) 100)
395 , dbTypeTest "Float" $ (/10) . fromIntegral @Int @Float <$> Gen.integral (Range.linear (-100) 100)
396 , dbTypeTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded
397 , dbTypeTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded
398 , dbTypeTest "Lazy ByteString" $ Data.ByteString.Lazy.fromStrict <$> Gen.bytes (Range.linear 0 128)
399 , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict <$> Gen.text (Range.linear 0 10) Gen.unicode
400 , dbTypeTest "LocalTime" genLocalTime
401 , dbTypeTest "Scientific" $ (/10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100)
402 , dbTypeTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode
403 , dbTypeTest "TimeOfDay" genTimeOfDay
404 , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime
405 , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32
406 ]
408 where
409 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree
410 dbTypeTest name generator = testGroup name
411 [ databasePropertyTest name (t (==) generator) getTestDatabase
412 , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase
413 ]
415 t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)
416 => (a -> a -> Bool)
417 -> Gen a
418 -> ((Connection -> TestT IO ()) -> PropertyT IO b)
419 -> PropertyT IO b
420 t eq generator transaction = do
421 x <- forAll generator
423 transaction \connection -> do
424 [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)
425 diff res eq x
427 genDay :: Gen Day
428 genDay = do
429 year <- Gen.integral (Range.linear 1970 3000)
430 month <- Gen.integral (Range.linear 1 12)
431 day <- Gen.integral (Range.linear 1 31)
432 Gen.just $ pure $ fromGregorianValid year month day
434 genDiffTime :: Gen DiffTime
435 genDiffTime = secondsToDiffTime <$> Gen.integral (Range.linear 0 86401)
437 genTimeOfDay :: Gen TimeOfDay
438 genTimeOfDay = do
439 hour <- Gen.integral (Range.linear 0 23)
440 minute <- Gen.integral (Range.linear 0 59)
441 sec <- fromIntegral @Int <$> Gen.integral (Range.linear 0 59)
442 Gen.just $ pure $ makeTimeOfDayValid hour minute sec
444 genLocalTime = LocalTime <$> genDay <*> genTimeOfDay
446 genWord32 :: Gen Word32
447 genWord32 = Gen.integral Range.linearBounded
450testDBEq :: IO TmpPostgres.DB -> TestTree
451testDBEq getTestDatabase = testGroup "DBEq instances"
452 [ dbEqTest "Bool" Gen.bool
453 , dbEqTest "Int32" $ Gen.integral @_ @Int32 Range.linearBounded
454 , dbEqTest "Int64" $ Gen.integral @_ @Int64 Range.linearBounded
455 , dbEqTest "Text" $ Gen.text (Range.linear 0 10) Gen.unicode
456 ]
458 where
459 dbEqTest :: (Eq a, Show a, Rel8.DBEq a) => TestName -> Gen a -> TestTree
460 dbEqTest name generator = testGroup name
461 [ databasePropertyTest name (t generator) getTestDatabase
462 , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
463 ]
465 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)
466 => Gen a
467 -> ((Connection -> TestT IO ()) -> PropertyT IO ())
468 -> PropertyT IO ()
469 t generator transaction = do
470 (x, y) <- forAll (liftA2 (,) generator generator)
472 transaction \connection -> do
473 [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
474 res === (x == y)
477testTableEquality :: IO TmpPostgres.DB -> TestTree
478testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
479 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
481 transaction \connection -> do
482 [eq] <- liftIO $ Rel8.select connection do
483 pure $ Rel8.lit x Rel8.==: Rel8.lit y
485 eq === (x == y)
488testFromString :: IO TmpPostgres.DB -> TestTree
489testFromString = databasePropertyTest "FromString" \transaction -> do
490 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
492 transaction \connection -> do
493 [result] <- liftIO $ Rel8.select connection $ pure $ fromString str
494 result === pack str
497testCatMaybeTable :: IO TmpPostgres.DB -> TestTree
498testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
499 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
501 transaction \connection -> do
502 selected <- liftIO $ Rel8.select connection do
503 testTable <- Rel8.values $ Rel8.lit <$> rows
504 Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
506 sort selected === sort (filter testTableColumn2 rows)
509testCatMaybe :: IO TmpPostgres.DB -> TestTree
510testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
511 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
513 transaction \connection -> do
514 selected <- evalM $ liftIO $ Rel8.select connection do
515 Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
517 sort selected === sort (catMaybes rows)
520testMaybeTable :: IO TmpPostgres.DB -> TestTree
521testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
522 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
524 transaction \connection -> do
525 selected <- liftIO $ Rel8.select connection $
526 Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
528 case rows of
529 [] -> selected === [def]
530 _ -> sort selected === sort rows
533data TwoTestTables f =
534 TwoTestTables
535 { testTable1 :: TestTable f
536 , testTable2 :: TestTable f
537 }
538 deriving stock Generic
539 deriving anyclass Rel8.Rel8able
542deriving stock instance Eq (TwoTestTables Result)
543deriving stock instance Ord (TwoTestTables Result)
544deriving stock instance Show (TwoTestTables Result)
547testNestedTables :: IO TmpPostgres.DB -> TestTree
548testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> evalM do
549 rows <- forAll do
550 Gen.list (Range.linear 0 10) $
551 liftA2 TwoTestTables genTestTable genTestTable
553 transaction \connection -> do
554 selected <- liftIO $ Rel8.select connection do
555 Rel8.values (Rel8.lit <$> rows)
557 sort selected === sort rows
560testMaybeTableApplicative :: IO TmpPostgres.DB -> TestTree
561testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction -> evalM do
562 rows1 <- genRows
563 rows2 <- genRows
565 transaction \connection -> do
566 selected <- liftIO $ Rel8.select connection do
567 as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
568 bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
569 pure $ liftA2 (,) as bs
571 case (rows1, rows2) of
572 ([], []) -> selected === [Nothing]
573 ([], bs) -> selected === (Nothing <$ bs)
574 (as, []) -> selected === (Nothing <$ as)
575 (as, bs) -> sort selected === sort (Just <$> liftA2 (,) as bs)
576 where
577 genRows :: PropertyT IO [TestTable Result]
578 genRows = forAll do
579 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
581rollingBack
582 :: (MonadBaseControl IO m, MonadIO m)
583 => Connection -> m a -> m a
584rollingBack connection =
585 bracket_
586 (liftIO (run (sql "BEGIN") connection))
587 (liftIO (run (sql "ROLLBACK") connection))
590genTestTable :: Gen (TestTable Result)
591genTestTable = do
592 testTableColumn1 <- Gen.text (Range.linear 0 5) Gen.alphaNum
593 testTableColumn2 <- Gen.bool
594 return TestTable{..}
597testUpdate :: IO TmpPostgres.DB -> TestTree
598testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
599 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
601 transaction \connection -> do
602 void $ liftIO $ Rel8.insert connection
603 Rel8.Insert
604 { into = testTableSchema
605 , rows = map Rel8.lit $ Map.keys rows
606 , onConflict = Rel8.DoNothing
607 , returning = Rel8.NumberOfRowsAffected
608 }
610 void $ liftIO $ Rel8.update connection
611 Rel8.Update
612 { target = testTableSchema
613 , set = \r ->
614 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows
615 in
616 foldl
617 ( \e (x, y) ->
618 Rel8.bool
619 e
620 y
621 ( testTableColumn1 r Rel8.==. testTableColumn1 x Rel8.&&.
622 testTableColumn2 r Rel8.==. testTableColumn2 x
623 )
624 )
625 r
626 updates
627 , updateWhere = \_ -> Rel8.lit True
628 , returning = Rel8.NumberOfRowsAffected
629 }
631 selected <- liftIO $ Rel8.select connection do
632 Rel8.each testTableSchema
634 sort selected === sort (Map.elems rows)
636 cover 1 "Empty" $ null rows
637 cover 1 "Singleton" $ null $ drop 1 $ Map.keys rows
638 cover 1 ">1 row" $ not $ null $ drop 1 $ Map.keys rows
641testDelete :: IO TmpPostgres.DB -> TestTree
642testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
643 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
645 transaction \connection -> do
646 void $ liftIO $ Rel8.insert connection
647 Rel8.Insert
648 { into = testTableSchema
649 , rows = map Rel8.lit rows
650 , onConflict = Rel8.DoNothing
651 , returning = Rel8.NumberOfRowsAffected
652 }
654 deleted <-
655 liftIO $ Rel8.delete connection
656 Rel8.Delete
657 { from = testTableSchema
658 , deleteWhere = testTableColumn2
659 , returning = Rel8.Projection id
660 }
662 selected <- liftIO $ Rel8.select connection do
663 Rel8.each testTableSchema
665 sort (deleted <> selected) === sort rows
668newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
669 deriving stock Generic
670 deriving anyclass Rel8.Rel8able
672deriving stock instance Eq (HKNestedPair Result)
673deriving stock instance Ord (HKNestedPair Result)
674deriving stock instance Show (HKNestedPair Result)
677testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
678testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
679 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
681 transaction \connection -> do
682 selected <- liftIO $ Rel8.select connection do
683 Rel8.values $ map Rel8.lit rows
685 sort selected === sort rows
688testSelectArray :: IO TmpPostgres.DB -> TestTree
689testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
690 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
692 transaction \connection -> do
693 selected <- liftIO $ Rel8.select connection do
694 Rel8.many $ Rel8.values (map Rel8.lit rows)
696 selected === [foldMap pure rows]
698 selected' <- liftIO $ Rel8.select connection $ do
699 a <- Rel8.catListTable =<< do
700 Rel8.many $ Rel8.values (map Rel8.lit rows)
701 b <- Rel8.catListTable =<< do
702 Rel8.many $ Rel8.values (map Rel8.lit rows)
703 pure (a, b)
705 selected' === liftA2 (,) rows rows
708data NestedMaybeTable f = NestedMaybeTable
709 { nmt1 :: Rel8.Column f Bool
710 , nmt2 :: Rel8.HMaybe f (TestTable f)
711 }
712 deriving stock Generic
713 deriving anyclass Rel8.Rel8able
716deriving stock instance Eq (NestedMaybeTable Result)
717deriving stock instance Ord (NestedMaybeTable Result)
718deriving stock instance Show (NestedMaybeTable Result)
721testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
722testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
723 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
725 transaction \connection -> do
726 selected <- liftIO $ Rel8.select connection do
727 x <- Rel8.values [Rel8.lit example]
728 pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
730 selected === [True]
733testEvaluate :: IO TmpPostgres.DB -> TestTree
734testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do
736 transaction \connection -> do
737 selected <- liftIO $ Rel8.select connection do
738 x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
739 y <- Rel8.evaluate (Rel8.nextval "test_seq")
740 pure (x, (y, y))
742 normalize selected ===
743 [ ('a', (0, 0))
744 , ('b', (1, 1))
745 , ('c', (2, 2))
746 ]
748 selected' <- liftIO $ Rel8.select connection do
749 x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
750 y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
751 z <- Rel8.evaluate (Rel8.nextval "test_seq")
752 pure ((x, y), (z, z))
754 normalize selected' ===
755 [ (('a', 'd'), (0, 0))
756 , (('a', 'e'), (1, 1))
757 , (('a', 'f'), (2, 2))
758 , (('b', 'd'), (3, 3))
759 , (('b', 'e'), (4, 4))
760 , (('b', 'f'), (5, 5))
761 , (('c', 'd'), (6, 6))
762 , (('c', 'e'), (7, 7))
763 , (('c', 'f'), (8, 8))
764 ]
766 where
767 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]
768 normalize [] = []
769 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs
771{-
772 selected <- liftIO $ Rel8.select connection do
773 x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
774 x <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
775 y <- Rel8.evaluate (Rel8.nextval "test_seq")
776 pure (x, y, y)
778 selected === [('a', 1, 1), ('b', 2, 2), ('c', 3, 3)]
779-}