@@ -1,11 +1,12 @@
1−{-# language BangPatterns #-}
2{-# language BlockArguments #-}
1{-# language BlockArguments #-}
2+{-# language DataKinds #-}
3{-# language DeriveAnyClass #-}
3{-# language DeriveAnyClass #-}
4{-# language DeriveGeneric #-}
4{-# language DeriveGeneric #-}
5{-# language DerivingStrategies #-}
5{-# language DerivingStrategies #-}
6+{-# language DisambiguateRecordFields #-}
6{-# language FlexibleContexts #-}
7{-# language FlexibleContexts #-}
7{-# language FlexibleInstances #-}
8{-# language FlexibleInstances #-}
8−{-# language MonoLocalBinds #-}
9+{-# language GADTs #-}
9{-# language NamedFieldPuns #-}
10{-# language NamedFieldPuns #-}
10{-# language OverloadedStrings #-}
11{-# language OverloadedStrings #-}
11{-# language RecordWildCards #-}
12{-# language RecordWildCards #-}
@@ -13,15 +14,17 @@
13{-# language StandaloneDeriving #-}
14{-# language StandaloneDeriving #-}
14{-# language TypeApplications #-}
15{-# language TypeApplications #-}
17+{-# options_ghc -fno-warn-redundant-constraints #-}
16module Main
19module Main
22−import Control.Applicative ( empty, liftA2, liftA3 )
25+import Control.Applicative ( liftA2, liftA3 )
23−import Control.Exception ( bracket, throwIO )
26+import Control.Monad (void)
24−import Control.Monad ( (>=>), void )
27+import Control.Monad.IO.Class ( MonadIO, liftIO )
25import Data.Bifunctor ( bimap )
28import Data.Bifunctor ( bimap )
26import Data.Foldable ( for_ )
29import Data.Foldable ( for_ )
27import Data.Int ( Int32, Int64 )
30import Data.Int ( Int32, Int64 )
@@ -35,27 +38,25 @@ import GHC.Generics ( Generic )
35import qualified Data.ByteString.Lazy
38import qualified Data.ByteString.Lazy
37-- case-insensitive
40-- case-insensitive
38−import Data.CaseInsensitive ( mk )
41+import Data.CaseInsensitive (mk)
40-- containers
43-- containers
41−import Data.Containers.ListUtils ( nubOrdOn )
42import qualified Data.Map.Strict as Map
44import qualified Data.Map.Strict as Map
45−import Hasql.Connection ( Connection, acquire, release )
47+import Hasql.Connection ( Connection, acquire, release )
46import Hasql.Session ( sql, run )
48import Hasql.Session ( sql, run )
49−import Hasql.Transaction ( Transaction, condemn, statement )
50−import qualified Hasql.Transaction.Sessions as Hasql
52-- hedgehog
50-- hedgehog
53import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
51import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
54import qualified Hedgehog.Gen as Gen
52import qualified Hedgehog.Gen as Gen
55import qualified Hedgehog.Range as Range
53import qualified Hedgehog.Range as Range
57−-- mmorph
55+-- lifted-base
58−import Control.Monad.Morph ( hoist )
56+import Control.Exception.Lifted ( bracket, throwIO, bracket_ )
59+import Control.Monad.Trans.Control ( MonadBaseControl )
61import Rel8 ( Result )
62import Rel8 ( Result )
@@ -71,16 +72,12 @@ import Test.Tasty
71import Test.Tasty.Hedgehog ( testProperty )
72import Test.Tasty.Hedgehog ( testProperty )
74−import Data.Text ( Text, pack, unpack )
75+import Data.Text (Text, pack)
75import qualified Data.Text.Lazy
76import qualified Data.Text.Lazy
76−import Data.Text.Encoding ( decodeUtf8 )
79import Data.Time
79import Data.Time
82−import Control.Monad.Trans.Class ( lift )
84-- tmp-postgres
81-- tmp-postgres
85import qualified Database.Postgres.Temp as TmpPostgres
82import qualified Database.Postgres.Temp as TmpPostgres
@@ -116,13 +113,11 @@ tests =
116 , testCatMaybeTable getTestDatabase
113 , testCatMaybeTable getTestDatabase
117 , testCatMaybe getTestDatabase
114 , testCatMaybe getTestDatabase
118 , testMaybeTable getTestDatabase
115 , testMaybeTable getTestDatabase
119− , testAggregateMaybeTable getTestDatabase
120 , testNestedTables getTestDatabase
116 , testNestedTables getTestDatabase
121 , testMaybeTableApplicative getTestDatabase
117 , testMaybeTableApplicative getTestDatabase
122 , testLogicalFixities getTestDatabase
118 , testLogicalFixities getTestDatabase
123 , testUpdate getTestDatabase
119 , testUpdate getTestDatabase
124 , testDelete getTestDatabase
120 , testDelete getTestDatabase
125− , testUpsert getTestDatabase
126 , testSelectNestedPairs getTestDatabase
121 , testSelectNestedPairs getTestDatabase
127 , testSelectArray getTestDatabase
122 , testSelectArray getTestDatabase
128 , testNestedMaybeTable getTestDatabase
123 , testNestedMaybeTable getTestDatabase
@@ -138,7 +133,6 @@ tests =
138 flip run conn do
133 flip run conn do
139 sql "CREATE EXTENSION citext"
134 sql "CREATE EXTENSION citext"
140 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"
135 sql "CREATE TABLE test_table ( column1 text not null, column2 bool not null )"
141− sql "CREATE TABLE unique_table ( \"key\" text not null unique, \"value\" text not null )"
142 sql "CREATE SEQUENCE test_seq"
136 sql "CREATE SEQUENCE test_seq"
144 return db
138 return db
@@ -146,21 +140,19 @@ tests =
146 stopTestDatabase = TmpPostgres.stop
140 stopTestDatabase = TmpPostgres.stop
149−connect :: TmpPostgres.DB -> IO Connection
150−connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure
153databasePropertyTest
143databasePropertyTest
154 :: TestName
144 :: TestName
155− -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())
145+ -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())
156 -> IO TmpPostgres.DB -> TestTree
146 -> IO TmpPostgres.DB -> TestTree
157databasePropertyTest testName f getTestDatabase =
147databasePropertyTest testName f getTestDatabase =
158− withResource (connect =<< getTestDatabase) release $ \c ->
148+ withResource connect release $ \c ->
159 testProperty testName $ property do
149 testProperty testName $ property do
160− connection <- lift c
150+ connection <- liftIO c
161− f $ test . hoist \m -> do
151+ f \g -> test $ rollingBack connection $ g connection
162− e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection
152+
163− either throwIO pure e
153+ where
155+ connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase
166data TestTable f = TestTable
158data TestTable f = TestTable
@@ -192,17 +184,18 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree
192testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
184testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
193 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
185 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
195− transaction do
187+ transaction \connection -> do
196− selected <- lift do
188+ void do
197− statement () $ Rel8.insert Rel8.Insert
189+ liftIO $ Rel8.insert connection
198− { into = testTableSchema
190+ Rel8.Insert
199− , rows = Rel8.values $ map Rel8.lit rows
191+ { into = testTableSchema
200− , onConflict = Rel8.DoNothing
192+ , rows = map Rel8.lit rows
201− , returning = pure ()
193+ , onConflict = Rel8.DoNothing
202− }
194+ , returning = Rel8.NumberOfRowsAffected
204− statement () $ Rel8.select do
197+ selected <- liftIO $ Rel8.select connection do
205− Rel8.each testTableSchema
198+ Rel8.each testTableSchema
207 sort selected === sort rows
200 sort selected === sort rows
@@ -219,12 +212,11 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do
220 let expected = filter (\t -> testTableColumn2 t == magicBool) rows
213 let expected = filter (\t -> testTableColumn2 t == magicBool) rows
222− transaction do
215+ transaction \connection -> do
223− selected <- lift do
216+ selected <- liftIO $ Rel8.select connection do
224− statement () $ Rel8.select do
217+ t <- Rel8.values $ Rel8.lit <$> rows
225− t <- Rel8.values $ Rel8.lit <$> rows
218+ Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
226− Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
219+ return t
229 sort selected === sort expected
221 sort selected === sort expected
@@ -237,12 +229,11 @@ testFilter :: IO TmpPostgres.DB -> TestTree
237testFilter = databasePropertyTest "filter" \transaction -> do
229testFilter = databasePropertyTest "filter" \transaction -> do
238 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
230 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
240− transaction do
232+ transaction \connection -> do
241 let expected = filter testTableColumn2 rows
233 let expected = filter testTableColumn2 rows
243− selected <- lift do
235+ selected <- liftIO $ Rel8.select connection
244− statement () $ Rel8.select do
236+ $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
245− Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
247 sort selected === sort expected
238 sort selected === sort expected
@@ -257,10 +248,9 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do
258 n <- forAll $ Gen.integral (Range.linear 0 10)
249 n <- forAll $ Gen.integral (Range.linear 0 10)
260− transaction do
251+ transaction \connection -> do
261− selected <- lift do
252+ selected <- liftIO $ Rel8.select connection do
262− statement () $ Rel8.select do
253+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
263− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
265 diff (length selected) (<=) (fromIntegral n)
255 diff (length selected) (<=) (fromIntegral n)
@@ -278,10 +268,9 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do
278 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
268 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
279 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
269 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
281− transaction do
271+ transaction \connection -> do
282− selected <- lift do
272+ selected <- liftIO $ Rel8.select connection do
283− statement () $ Rel8.select do
273+ Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
284− Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
286 sort selected === sort (nub (left ++ right))
275 sort selected === sort (nub (left ++ right))
@@ -290,11 +279,9 @@ testDistinct :: IO TmpPostgres.DB -> TestTree
290testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
279testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
291 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
280 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
293− transaction do
282+ transaction \connection -> do
294− selected <- lift do
283+ selected <- liftIO $ Rel8.select connection $ Rel8.distinct do
295− statement () $ Rel8.select do
284+ Rel8.values (Rel8.lit <$> rows)
297− Rel8.values (Rel8.lit <$> rows)
299 sort selected === nub (sort rows)
286 sort selected === nub (sort rows)
@@ -307,10 +294,8 @@ testExists :: IO TmpPostgres.DB -> TestTree
307testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
294testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
308 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
295 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
310− transaction do
297+ transaction \connection -> do
311− exists <- lift do
298+ exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
312− statement () $ Rel8.select do
313− Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
315 case rows of
300 case rows of
316 [] -> exists === [False]
301 [] -> exists === [False]
@@ -321,10 +306,9 @@ testOptional :: IO TmpPostgres.DB -> TestTree
321testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
306testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
322 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
307 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
324− transaction do
309+ transaction \connection -> do
325− selected <- lift do
310+ selected <- liftIO $ Rel8.select connection do
326− statement () $ Rel8.select do
311+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
327− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
329 case rows of
313 case rows of
330 [] -> selected === [Nothing]
314 [] -> selected === [Nothing]
@@ -335,10 +319,9 @@ testAnd :: IO TmpPostgres.DB -> TestTree
335testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
319testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
336 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
320 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
338− transaction do
322+ transaction \connection -> do
339− [result] <- lift do
323+ [result] <- liftIO $ Rel8.select connection $ pure $
340− statement () $ Rel8.select do
324+ Rel8.lit x Rel8.&&. Rel8.lit y
341− pure $ Rel8.lit x Rel8.&&. Rel8.lit y
343 result === (x && y)
326 result === (x && y)
@@ -347,10 +330,9 @@ testOr :: IO TmpPostgres.DB -> TestTree
347testOr = databasePropertyTest "OR (||.)" \transaction -> do
330testOr = databasePropertyTest "OR (||.)" \transaction -> do
348 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
331 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
350− transaction do
333+ transaction \connection -> do
351− [result] <- lift do
334+ [result] <- liftIO $ Rel8.select connection $ pure $
352− statement () $ Rel8.select $ pure $
335+ Rel8.lit x Rel8.||. Rel8.lit y
353− Rel8.lit x Rel8.||. Rel8.lit y
355 result === (x || y)
337 result === (x || y)
@@ -359,10 +341,9 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree
359testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
341testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
360 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
342 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
362− transaction do
344+ transaction \connection -> do
363− [result] <- lift do
345+ [result] <- liftIO $ Rel8.select connection $ pure $
364− statement () $ Rel8.select do
346+ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
365− pure $ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
367 result === (u || v && w == x)
348 result === (u || v && w == x)
@@ -371,10 +352,9 @@ testNot :: IO TmpPostgres.DB -> TestTree
371testNot = databasePropertyTest "NOT (not_)" \transaction -> do
352testNot = databasePropertyTest "NOT (not_)" \transaction -> do
372 x <- forAll Gen.bool
353 x <- forAll Gen.bool
374− transaction do
355+ transaction \connection -> do
375− [result] <- lift do
356+ [result] <- liftIO $ Rel8.select connection $ pure $
376− statement () $ Rel8.select do
357+ Rel8.not_ $ Rel8.lit x
377− pure $ Rel8.not_ $ Rel8.lit x
379 result === not x
359 result === not x
@@ -383,10 +363,9 @@ testBool :: IO TmpPostgres.DB -> TestTree
383testBool = databasePropertyTest "ifThenElse_" \transaction -> do
363testBool = databasePropertyTest "ifThenElse_" \transaction -> do
384 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
364 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
386− transaction do
366+ transaction \connection -> do
387− [result] <- lift do
367+ [result] <- liftIO $ Rel8.select connection $ pure $
388− statement () $ Rel8.select do
368+ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
389− pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
391 result === if x then y else z
370 result === if x then y else z
@@ -398,10 +377,9 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do
398 (Gen.list (Range.linear 1 10) genTestTable)
377 (Gen.list (Range.linear 1 10) genTestTable)
399 (Gen.list (Range.linear 1 10) genTestTable)
378 (Gen.list (Range.linear 1 10) genTestTable)
401− transaction do
380+ transaction \connection -> do
402− result <- lift do
381+ result <- liftIO $ Rel8.select connection $ do
403− statement () $ Rel8.select do
382+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
404− liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
406 sort result === sort (liftA2 (,) rows1 rows2)
384 sort result === sort (liftA2 (,) rows1 rows2)
@@ -430,22 +408,21 @@ testDBType getTestDatabase = testGroup "DBType instances"
431 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree
409 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree
432 dbTypeTest name generator = testGroup name
410 dbTypeTest name generator = testGroup name
433− [ databasePropertyTest name (t generator) getTestDatabase
411+ [ databasePropertyTest name (t (==) generator) getTestDatabase
434− , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
412+ , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase
437− t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)
415+ t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)
438− => Gen a
416+ => (a -> a -> Bool)
439− -> (TestT Transaction () -> PropertyT IO b)
417+ -> Gen a
418+ -> ((Connection -> TestT IO ()) -> PropertyT IO b)
440 -> PropertyT IO b
419 -> PropertyT IO b
441− t generator transaction = do
420+ t eq generator transaction = do
442 x <- forAll generator
421 x <- forAll generator
444− transaction do
423+ transaction \connection -> do
445− [res] <- lift do
424+ [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)
446− statement () $ Rel8.select do
425+ diff res eq x
447− pure (Rel8.litExpr x)
450 genDay :: Gen Day
427 genDay :: Gen Day
451 genDay = do
428 genDay = do
@@ -487,15 +464,13 @@ testDBEq getTestDatabase = testGroup "DBEq instances"
488 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)
465 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)
490− -> (TestT Transaction () -> PropertyT IO ())
467+ -> ((Connection -> TestT IO ()) -> PropertyT IO ())
491 -> PropertyT IO ()
468 -> PropertyT IO ()
492 t generator transaction = do
469 t generator transaction = do
493 (x, y) <- forAll (liftA2 (,) generator generator)
470 (x, y) <- forAll (liftA2 (,) generator generator)
495− transaction do
472+ transaction \connection -> do
496− [res] <- lift do
473+ [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
497− statement () $ Rel8.select do
498− pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
499 res === (x == y)
474 res === (x == y)
@@ -503,10 +478,9 @@ testTableEquality :: IO TmpPostgres.DB -> TestTree
503testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
478testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
504 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
479 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
506− transaction do
481+ transaction \connection -> do
507− [eq] <- lift do
482+ [eq] <- liftIO $ Rel8.select connection do
508− statement () $ Rel8.select do
483+ pure $ Rel8.lit x Rel8.==: Rel8.lit y
509− pure $ Rel8.lit x Rel8.==: Rel8.lit y
511 eq === (x == y)
485 eq === (x == y)
@@ -515,10 +489,8 @@ testFromString :: IO TmpPostgres.DB -> TestTree
515testFromString = databasePropertyTest "FromString" \transaction -> do
489testFromString = databasePropertyTest "FromString" \transaction -> do
516 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
490 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
518− transaction do
492+ transaction \connection -> do
519− [result] <- lift do
493+ [result] <- liftIO $ Rel8.select connection $ pure $ fromString str
520− statement () $ Rel8.select do
521− pure $ fromString str
522 result === pack str
494 result === pack str
@@ -526,11 +498,10 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree
526testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
498testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
527 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
499 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
529− transaction do
501+ transaction \connection -> do
530− selected <- lift do
502+ selected <- liftIO $ Rel8.select connection do
531− statement () $ Rel8.select do
503+ testTable <- Rel8.values $ Rel8.lit <$> rows
532− testTable <- Rel8.values $ Rel8.lit <$> rows
504+ Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
533− Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
535 sort selected === sort (filter testTableColumn2 rows)
506 sort selected === sort (filter testTableColumn2 rows)
@@ -539,10 +510,9 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree
539testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
510testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
540 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
511 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
542− transaction do
513+ transaction \connection -> do
543− selected <- lift do
514+ selected <- evalM $ liftIO $ Rel8.select connection do
544− statement () $ Rel8.select do
515+ Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
545− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
547 sort selected === sort (catMaybes rows)
517 sort selected === sort (catMaybes rows)
@@ -551,38 +521,15 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree
551testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
521testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
552 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
522 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
554− transaction do
524+ transaction \connection -> do
555− selected <- lift do
525+ selected <- liftIO $ Rel8.select connection $
556− statement () $ Rel8.select do
526+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
557− Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
559 case rows of
528 case rows of
560 [] -> selected === [def]
529 [] -> selected === [def]
561 _ -> sort selected === sort rows
530 _ -> sort selected === sort rows
564−testAggregateMaybeTable :: IO TmpPostgres.DB -> TestTree
565−testAggregateMaybeTable = databasePropertyTest "aggregateMaybeTable" \transaction -> evalM do
566− rows <- forAll $ Gen.list (Range.linear 0 10) (Gen.maybe (Gen.int64 (Range.linear 0 10)))
569− aggregate = go 0 False False
571− go !n nothing _ (Just a : as) = go (n + a) nothing True as
572− go n _ just (Nothing : as) = go n True just as
573− go _ False False [] = []
574− go _ True False [] = [Nothing]
575− go n False True [] = [Just n]
576− go n True True [] = [Nothing, Just n]
580− statement () $ Rel8.select do
581− Rel8.aggregate $ Rel8.aggregateMaybeTable Rel8.sum <$> Rel8.values (Rel8.lit <$> rows)
583− sort selected === aggregate rows
586data TwoTestTables f =
533data TwoTestTables f =
587 TwoTestTables
534 TwoTestTables
588 { testTable1 :: TestTable f
535 { testTable1 :: TestTable f
@@ -603,10 +550,9 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval
603 Gen.list (Range.linear 0 10) $
550 Gen.list (Range.linear 0 10) $
604 liftA2 TwoTestTables genTestTable genTestTable
551 liftA2 TwoTestTables genTestTable genTestTable
606− transaction do
553+ transaction \connection -> do
607− selected <- lift do
554+ selected <- liftIO $ Rel8.select connection do
608− statement () $ Rel8.select do
555+ Rel8.values (Rel8.lit <$> rows)
609− Rel8.values (Rel8.lit <$> rows)
611 sort selected === sort rows
557 sort selected === sort rows
@@ -616,12 +562,11 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
616 rows1 <- genRows
562 rows1 <- genRows
617 rows2 <- genRows
563 rows2 <- genRows
619− transaction do
565+ transaction \connection -> do
620− selected <- lift do
566+ selected <- liftIO $ Rel8.select connection do
621− statement () $ Rel8.select do
567+ as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
622− as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
568+ bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
623− bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
569+ pure $ liftA2 (,) as bs
624− pure $ liftA2 (,) as bs
626 case (rows1, rows2) of
571 case (rows1, rows2) of
627 ([], []) -> selected === [Nothing]
572 ([], []) -> selected === [Nothing]
@@ -633,6 +578,14 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
633 genRows = forAll do
578 genRows = forAll do
634 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
579 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
582+ :: (MonadBaseControl IO m, MonadIO m)
583+ => Connection -> m a -> m a
584+rollingBack connection =
586+ (liftIO (run (sql "BEGIN") connection))
587+ (liftIO (run (sql "ROLLBACK") connection))
637genTestTable :: Gen (TestTable Result)
590genTestTable :: Gen (TestTable Result)
638genTestTable = do
591genTestTable = do
@@ -645,19 +598,19 @@ testUpdate :: IO TmpPostgres.DB -> TestTree
645testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
598testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
646 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
599 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
648− transaction do
601+ transaction \connection -> do
649− selected <- lift do
602+ void $ liftIO $ Rel8.insert connection
650− statement () $ Rel8.insert Rel8.Insert
603+ Rel8.Insert
651 { into = testTableSchema
604 { into = testTableSchema
652− , rows = Rel8.values $ map Rel8.lit $ Map.keys rows
605+ , rows = map Rel8.lit $ Map.keys rows
653 , onConflict = Rel8.DoNothing
606 , onConflict = Rel8.DoNothing
654− , returning = pure ()
607+ , returning = Rel8.NumberOfRowsAffected
657− statement () $ Rel8.update Rel8.Update
610+ void $ liftIO $ Rel8.update connection
658 { target = testTableSchema
612 { target = testTableSchema
659− , from = pure ()
613+ , set = \r ->
661 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows
614 let updates = map (bimap Rel8.lit Rel8.lit) $ Map.toList rows
@@ -671,12 +624,12 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
674− , updateWhere = \_ _ -> Rel8.lit True
627+ , updateWhere = \_ -> Rel8.lit True
675− , returning = pure ()
628+ , returning = Rel8.NumberOfRowsAffected
678− statement () $ Rel8.select do
631+ selected <- liftIO $ Rel8.select connection do
679− Rel8.each testTableSchema
632+ Rel8.each testTableSchema
681 sort selected === sort (Map.elems rows)
634 sort selected === sort (Map.elems rows)
@@ -689,96 +642,29 @@ testDelete :: IO TmpPostgres.DB -> TestTree
689testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
642testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
690 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
643 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
692− transaction do
645+ transaction \connection -> do
693− (deleted, selected) <- lift do
646+ void $ liftIO $ Rel8.insert connection
694− statement () $ Rel8.insert Rel8.Insert
647+ Rel8.Insert
695 { into = testTableSchema
648 { into = testTableSchema
696− , rows = Rel8.values $ map Rel8.lit rows
649+ , rows = map Rel8.lit rows
697 , onConflict = Rel8.DoNothing
650 , onConflict = Rel8.DoNothing
698− , returning = pure ()
651+ , returning = Rel8.NumberOfRowsAffected
701− deleted <- statement () $ Rel8.delete Rel8.Delete
654+ deleted <-
655+ liftIO $ Rel8.delete connection
702 { from = testTableSchema
657 { from = testTableSchema
703− , using = pure ()
658+ , deleteWhere = testTableColumn2
704− , deleteWhere = const testTableColumn2
705 , returning = Rel8.Projection id
659 , returning = Rel8.Projection id
708− selected <- statement () $ Rel8.select do
662+ selected <- liftIO $ Rel8.select connection do
709− Rel8.each testTableSchema
663+ Rel8.each testTableSchema
711− pure (deleted, selected)
713 sort (deleted <> selected) === sort rows
665 sort (deleted <> selected) === sort rows
716−data UniqueTable f = UniqueTable
717− { uniqueTableKey :: Rel8.Column f Text
718− , uniqueTableValue :: Rel8.Column f Text
720− deriving stock Generic
721− deriving anyclass Rel8.Rel8able
724−deriving stock instance Eq (UniqueTable Result)
725−deriving stock instance Ord (UniqueTable Result)
726−deriving stock instance Show (UniqueTable Result)
729−uniqueTableSchema :: Rel8.TableSchema (UniqueTable Rel8.Name)
732− { name = "unique_table"
734− , columns = UniqueTable
735− { uniqueTableKey = "key"
736− , uniqueTableValue = "value"
741−genUniqueTable :: Gen (UniqueTable Result)
743− uniqueTableKey <- Gen.text (Range.linear 0 5) Gen.alphaNum
744− uniqueTableValue <- Gen.text (Range.linear 0 5) Gen.alphaNum
745− pure UniqueTable {..}
748−testUpsert :: IO TmpPostgres.DB -> TestTree
749−testUpsert = databasePropertyTest "Can UPSERT UniqueTable" \transaction -> do
750− as <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable
751− bs <- unique $ forAll $ Gen.list (Range.linear 0 20) genUniqueTable
755− statement () $ Rel8.insert Rel8.Insert
756− { into = uniqueTableSchema
757− , rows = Rel8.values $ Rel8.lit <$> as
758− , onConflict = Rel8.DoNothing
759− , returning = pure ()
762− statement () $ Rel8.insert Rel8.Insert
763− { into = uniqueTableSchema
764− , rows = Rel8.values $ Rel8.lit <$> bs
765− , onConflict = Rel8.DoUpdate Rel8.Upsert
766− { index = uniqueTableKey
767− , set = \UniqueTable {uniqueTableValue} old -> old {uniqueTableValue}
768− , updateWhere = \_ _ -> Rel8.true
770− , returning = pure ()
773− statement () $ Rel8.select do
774− Rel8.each uniqueTableSchema
776− fromUniqueTables selected === fromUniqueTables bs <> fromUniqueTables as
778− unique = fmap (nubOrdOn uniqueTableKey)
779− fromUniqueTables = Map.fromList . map \(UniqueTable key value) -> (key, value)
782newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
668newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
783 deriving stock Generic
669 deriving stock Generic
784 deriving anyclass Rel8.Rel8able
670 deriving anyclass Rel8.Rel8able
@@ -792,10 +678,9 @@ testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
792testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
678testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
793 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
679 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
795− transaction do
681+ transaction \connection -> do
796− selected <- lift do
682+ selected <- liftIO $ Rel8.select connection do
797− statement () $ Rel8.select do
683+ Rel8.values $ map Rel8.lit rows
798− Rel8.values $ map Rel8.lit rows
800 sort selected === sort rows
685 sort selected === sort rows
@@ -804,20 +689,18 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree
804testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
689testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
805 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
690 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
807− transaction do
692+ transaction \connection -> do
808− selected <- lift do
693+ selected <- liftIO $ Rel8.select connection do
809− statement () $ Rel8.select do
694+ Rel8.many $ Rel8.values (map Rel8.lit rows)
810− Rel8.many $ Rel8.values (map Rel8.lit rows)
812 selected === [foldMap pure rows]
696 selected === [foldMap pure rows]
814− selected' <- lift do
698+ selected' <- liftIO $ Rel8.select connection $ do
815− statement () $ Rel8.select do
699+ a <- Rel8.catListTable =<< do
816− a <- Rel8.catListTable =<< do
700+ Rel8.many $ Rel8.values (map Rel8.lit rows)
817− Rel8.many $ Rel8.values (map Rel8.lit rows)
701+ b <- Rel8.catListTable =<< do
818− b <- Rel8.catListTable =<< do
702+ Rel8.many $ Rel8.values (map Rel8.lit rows)
819− Rel8.many $ Rel8.values (map Rel8.lit rows)
703+ pure (a, b)
822 selected' === liftA2 (,) rows rows
705 selected' === liftA2 (,) rows rows
@@ -839,11 +722,10 @@ testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
839testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
722testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
840 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
723 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
842− transaction do
725+ transaction \connection -> do
843− selected <- lift do
726+ selected <- liftIO $ Rel8.select connection do
844− statement () $ Rel8.select do
727+ x <- Rel8.values [Rel8.lit example]
845− x <- Rel8.values [Rel8.lit example]
728+ pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
846− pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
848 selected === [True]
730 selected === [True]
@@ -851,12 +733,11 @@ testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other ta
851testEvaluate :: IO TmpPostgres.DB -> TestTree
733testEvaluate :: IO TmpPostgres.DB -> TestTree
852testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do
734testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do
854− transaction do
736+ transaction \connection -> do
855− selected <- lift do
737+ selected <- liftIO $ Rel8.select connection do
856− statement () $ Rel8.select do
738+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
857− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
739+ y <- Rel8.evaluate (Rel8.nextval "test_seq")
858− y <- Rel8.evaluate (Rel8.nextval "test_seq")
740+ pure (x, (y, y))
861 normalize selected ===
742 normalize selected ===
862 [ ('a', (0, 0))
743 [ ('a', (0, 0))
@@ -864,12 +745,11 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
864 , ('c', (2, 2))
745 , ('c', (2, 2))
867− selected' <- lift do
748+ selected' <- liftIO $ Rel8.select connection do
868− statement () $ Rel8.select do
749+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
869− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
750+ y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
870− y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
751+ z <- Rel8.evaluate (Rel8.nextval "test_seq")
871− z <- Rel8.evaluate (Rel8.nextval "test_seq")
752+ pure ((x, y), (z, z))
872− pure ((x, y), (z, z))
874 normalize selected' ===
754 normalize selected' ===
875 [ (('a', 'd'), (0, 0))
755 [ (('a', 'd'), (0, 0))
@@ -887,3 +767,13 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
887 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]
767 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]
888 normalize [] = []
768 normalize [] = []
889 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs
769 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs
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")
778+ selected === [('a', 1, 1), ('b', 2, 2), ('c', 3, 3)]