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