@@ -1,11 +1,12 @@
1−{-# language BangPatterns #-}
21{-# language BlockArguments #-}
2+{-# language DataKinds #-}
33{-# language DeriveAnyClass #-}
44{-# language DeriveGeneric #-}
55{-# language DerivingStrategies #-}
6+{-# language DisambiguateRecordFields #-}
67{-# language FlexibleContexts #-}
78{-# language FlexibleInstances #-}
8−{-# language MonoLocalBinds #-}
9+{-# language GADTs #-}
910{-# language NamedFieldPuns #-}
1011{-# language OverloadedStrings #-}
1112{-# language RecordWildCards #-}
@@ -13,15 +14,17 @@
1314{-# language StandaloneDeriving #-}
1415{-# language TypeApplications #-}
1516
17+{-# options_ghc -fno-warn-redundant-constraints #-}
18+
1619module Main
1720 ( main
1821 )
1922where
2023
2124-- base
22−import Control.Applicative ( empty, liftA2, liftA3 )
23−import Control.Exception ( bracket, throwIO )
24−import Control.Monad ( (>=>), void )
25+import Control.Applicative ( liftA2, liftA3 )
26+import Control.Monad (void)
27+import Control.Monad.IO.Class ( MonadIO, liftIO )
2528import Data.Bifunctor ( bimap )
2629import Data.Foldable ( for_ )
2730import Data.Int ( Int32, Int64 )
@@ -35,27 +38,25 @@ import GHC.Generics ( Generic )
3538import qualified Data.ByteString.Lazy
3639
3740-- case-insensitive
38−import Data.CaseInsensitive ( mk )
41+import Data.CaseInsensitive (mk)
3942
4043-- containers
41−import Data.Containers.ListUtils ( nubOrdOn )
4244import qualified Data.Map.Strict as Map
4345
4446-- hasql
45−import Hasql.Connection ( Connection, acquire, release )
47+import Hasql.Connection ( Connection, acquire, release )
4648import Hasql.Session ( sql, run )
4749
48−-- hasql-transaction
49−import Hasql.Transaction ( Transaction, condemn, statement )
50−import qualified Hasql.Transaction.Sessions as Hasql
51−
5250-- hedgehog
5351import Hedgehog ( property, (===), forAll, cover, diff, evalM, PropertyT, TestT, test, Gen )
5452import qualified Hedgehog.Gen as Gen
5553import qualified Hedgehog.Range as Range
5654
57−-- mmorph
58−import Control.Monad.Morph ( hoist )
55+-- lifted-base
56+import Control.Exception.Lifted ( bracket, throwIO, bracket_ )
57+
58+-- monad-control
59+import Control.Monad.Trans.Control ( MonadBaseControl )
5960
6061-- rel8
6162import Rel8 ( Result )
@@ -71,16 +72,12 @@ import Test.Tasty
7172import Test.Tasty.Hedgehog ( testProperty )
7273
7374-- text
74−import Data.Text ( Text, pack, unpack )
75+import Data.Text (Text, pack)
7576import qualified Data.Text.Lazy
76−import Data.Text.Encoding ( decodeUtf8 )
7777
7878-- time
7979import Data.Time
8080
81−-- transformers
82−import Control.Monad.Trans.Class ( lift )
83−
8481-- tmp-postgres
8582import qualified Database.Postgres.Temp as TmpPostgres
8683
@@ -116,13 +113,11 @@ tests =
116113 , testCatMaybeTable getTestDatabase
117114 , testCatMaybe getTestDatabase
118115 , testMaybeTable getTestDatabase
119− , testAggregateMaybeTable getTestDatabase
120116 , testNestedTables getTestDatabase
121117 , testMaybeTableApplicative getTestDatabase
122118 , testLogicalFixities getTestDatabase
123119 , testUpdate getTestDatabase
124120 , testDelete getTestDatabase
125− , testUpsert getTestDatabase
126121 , testSelectNestedPairs getTestDatabase
127122 , testSelectArray getTestDatabase
128123 , testNestedMaybeTable getTestDatabase
@@ -138,7 +133,6 @@ tests =
138133 flip run conn do
139134 sql "CREATE EXTENSION citext"
140135 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 )"
142136 sql "CREATE SEQUENCE test_seq"
143137
144138 return db
@@ -146,21 +140,19 @@ tests =
146140 stopTestDatabase = TmpPostgres.stop
147141
148142
149−connect :: TmpPostgres.DB -> IO Connection
150−connect = acquire . TmpPostgres.toConnectionString >=> either (maybe empty (fail . unpack . decodeUtf8)) pure
151−
152−
153143databasePropertyTest
154144 :: TestName
155− -> ((TestT Transaction () -> PropertyT IO ()) -> PropertyT IO ())
145+ -> (((Connection -> TestT IO ()) -> PropertyT IO ()) -> PropertyT IO ())
156146 -> IO TmpPostgres.DB -> TestTree
157147databasePropertyTest testName f getTestDatabase =
158− withResource (connect =<< getTestDatabase) release $ \c ->
148+ withResource connect release $ \c ->
159149 testProperty testName $ property do
160− connection <- lift c
161− f $ test . hoist \m -> do
162− e <- run (Hasql.transaction Hasql.Serializable Hasql.Write (m <* condemn)) connection
163− either throwIO pure e
150+ connection <- liftIO c
151+ f \g -> test $ rollingBack connection $ g connection
152+
153+ where
154+
155+ connect = either (error . show) return =<< acquire . TmpPostgres.toConnectionString =<< getTestDatabase
164156
165157
166158data TestTable f = TestTable
@@ -192,17 +184,17 @@ testSelectTestTable :: IO TmpPostgres.DB -> TestTree
192184testSelectTestTable = databasePropertyTest "Can SELECT TestTable" \transaction -> do
193185 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
194186
195− transaction do
196− selected <- lift do
197− statement () $ Rel8.insert Rel8.Insert
187+ transaction \connection -> do
188+ liftIO $ Rel8.insert connection
189+ Rel8.Insert
198190 { into = testTableSchema
199191 , rows = Rel8.values $ map Rel8.lit rows
200192 , onConflict = Rel8.DoNothing
201193 , returning = pure ()
202194 }
203195
204− statement () $ Rel8.select do
205− Rel8.each testTableSchema
196+ selected <- liftIO $ Rel8.select connection do
197+ Rel8.each testTableSchema
206198
207199 sort selected === sort rows
208200
@@ -219,12 +211,11 @@ testWhere_ = databasePropertyTest "WHERE (Rel8.where_)" \transaction -> do
219211
220212 let expected = filter (\t -> testTableColumn2 t == magicBool) rows
221213
222− transaction do
223− selected <- lift do
224− statement () $ Rel8.select do
225− t <- Rel8.values $ Rel8.lit <$> rows
226− Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
227− return t
214+ transaction \connection -> do
215+ selected <- liftIO $ Rel8.select connection do
216+ t <- Rel8.values $ Rel8.lit <$> rows
217+ Rel8.where_ $ testTableColumn2 t Rel8.==. Rel8.lit magicBool
218+ return t
228219
229220 sort selected === sort expected
230221
@@ -237,12 +228,11 @@ testFilter :: IO TmpPostgres.DB -> TestTree
237228testFilter = databasePropertyTest "filter" \transaction -> do
238229 rows <- forAll $ Gen.list (Range.linear 1 10) genTestTable
239230
240− transaction do
231+ transaction \connection -> do
241232 let expected = filter testTableColumn2 rows
242233
243− selected <- lift do
244− statement () $ Rel8.select do
245− Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
234+ selected <- liftIO $ Rel8.select connection
235+ $ Rel8.filter testTableColumn2 =<< Rel8.values (Rel8.lit <$> rows)
246236
247237 sort selected === sort expected
248238
@@ -257,10 +247,9 @@ testLimit = databasePropertyTest "LIMIT (Rel8.limit)" \transaction -> do
257247
258248 n <- forAll $ Gen.integral (Range.linear 0 10)
259249
260− transaction do
261− selected <- lift do
262− statement () $ Rel8.select do
263− Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
250+ transaction \connection -> do
251+ selected <- liftIO $ Rel8.select connection do
252+ Rel8.limit n $ Rel8.values (Rel8.lit <$> rows)
264253
265254 diff (length selected) (<=) (fromIntegral n)
266255
@@ -278,10 +267,9 @@ testUnion = databasePropertyTest "UNION (Rel8.union)" \transaction -> evalM do
278267 left <- forAll $ Gen.list (Range.linear 0 10) genTestTable
279268 right <- forAll $ Gen.list (Range.linear 0 10) genTestTable
280269
281− transaction do
282− selected <- lift do
283− statement () $ Rel8.select do
284− Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
270+ transaction \connection -> do
271+ selected <- liftIO $ Rel8.select connection do
272+ Rel8.values (Rel8.lit <$> nub left) `Rel8.union` Rel8.values (Rel8.lit <$> nub right)
285273
286274 sort selected === sort (nub (left ++ right))
287275
@@ -290,11 +278,9 @@ testDistinct :: IO TmpPostgres.DB -> TestTree
290278testDistinct = databasePropertyTest "DISTINCT (Rel8.distinct)" \transaction -> do
291279 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
292280
293− transaction do
294− selected <- lift do
295− statement () $ Rel8.select do
296− Rel8.distinct do
297− Rel8.values (Rel8.lit <$> rows)
281+ transaction \connection -> do
282+ selected <- liftIO $ Rel8.select connection $ Rel8.distinct do
283+ Rel8.values (Rel8.lit <$> rows)
298284
299285 sort selected === nub (sort rows)
300286
@@ -307,10 +293,8 @@ testExists :: IO TmpPostgres.DB -> TestTree
307293testExists = databasePropertyTest "EXISTS (Rel8.exists)" \transaction -> do
308294 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
309295
310− transaction do
311− exists <- lift do
312− statement () $ Rel8.select do
313− Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
296+ transaction \connection -> do
297+ exists <- liftIO $ Rel8.select connection $ Rel8.exists $ Rel8.values $ Rel8.lit <$> rows
314298
315299 case rows of
316300 [] -> exists === [False]
@@ -321,10 +305,9 @@ testOptional :: IO TmpPostgres.DB -> TestTree
321305testOptional = databasePropertyTest "Rel8.optional" \transaction -> do
322306 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
323307
324− transaction do
325− selected <- lift do
326− statement () $ Rel8.select do
327− Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
308+ transaction \connection -> do
309+ selected <- liftIO $ Rel8.select connection do
310+ Rel8.optional $ Rel8.values (Rel8.lit <$> rows)
328311
329312 case rows of
330313 [] -> selected === [Nothing]
@@ -335,10 +318,9 @@ testAnd :: IO TmpPostgres.DB -> TestTree
335318testAnd = databasePropertyTest "AND (&&.)" \transaction -> do
336319 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
337320
338− transaction do
339− [result] <- lift do
340− statement () $ Rel8.select do
341− pure $ Rel8.lit x Rel8.&&. Rel8.lit y
321+ transaction \connection -> do
322+ [result] <- liftIO $ Rel8.select connection $ pure $
323+ Rel8.lit x Rel8.&&. Rel8.lit y
342324
343325 result === (x && y)
344326
@@ -347,10 +329,9 @@ testOr :: IO TmpPostgres.DB -> TestTree
347329testOr = databasePropertyTest "OR (||.)" \transaction -> do
348330 (x, y) <- forAll $ liftA2 (,) Gen.bool Gen.bool
349331
350− transaction do
351− [result] <- lift do
352− statement () $ Rel8.select $ pure $
353− Rel8.lit x Rel8.||. Rel8.lit y
332+ transaction \connection -> do
333+ [result] <- liftIO $ Rel8.select connection $ pure $
334+ Rel8.lit x Rel8.||. Rel8.lit y
354335
355336 result === (x || y)
356337
@@ -359,10 +340,9 @@ testLogicalFixities :: IO TmpPostgres.DB -> TestTree
359340testLogicalFixities = databasePropertyTest "Logical operator fixities" \transaction -> do
360341 (u, v, w, x) <- forAll $ (,,,) <$> Gen.bool <*> Gen.bool <*> Gen.bool <*> Gen.bool
361342
362− transaction do
363− [result] <- lift do
364− statement () $ Rel8.select do
365− pure $ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
343+ transaction \connection -> do
344+ [result] <- liftIO $ Rel8.select connection $ pure $
345+ Rel8.lit u Rel8.||. Rel8.lit v Rel8.&&. Rel8.lit w Rel8.==. Rel8.lit x
366346
367347 result === (u || v && w == x)
368348
@@ -371,10 +351,9 @@ testNot :: IO TmpPostgres.DB -> TestTree
371351testNot = databasePropertyTest "NOT (not_)" \transaction -> do
372352 x <- forAll Gen.bool
373353
374− transaction do
375− [result] <- lift do
376− statement () $ Rel8.select do
377− pure $ Rel8.not_ $ Rel8.lit x
354+ transaction \connection -> do
355+ [result] <- liftIO $ Rel8.select connection $ pure $
356+ Rel8.not_ $ Rel8.lit x
378357
379358 result === not x
380359
@@ -383,10 +362,9 @@ testBool :: IO TmpPostgres.DB -> TestTree
383362testBool = databasePropertyTest "ifThenElse_" \transaction -> do
384363 (x, y, z) <- forAll $ liftA3 (,,) Gen.bool Gen.bool Gen.bool
385364
386− transaction do
387− [result] <- lift do
388− statement () $ Rel8.select do
389− pure $ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
365+ transaction \connection -> do
366+ [result] <- liftIO $ Rel8.select connection $ pure $
367+ Rel8.bool (Rel8.lit z) (Rel8.lit y) (Rel8.lit x)
390368
391369 result === if x then y else z
392370
@@ -398,10 +376,9 @@ testAp = databasePropertyTest "Cartesian product (<*>)" \transaction -> do
398376 (Gen.list (Range.linear 1 10) genTestTable)
399377 (Gen.list (Range.linear 1 10) genTestTable)
400378
401− transaction do
402− result <- lift do
403− statement () $ Rel8.select do
404− liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
379+ transaction \connection -> do
380+ result <- liftIO $ Rel8.select connection $ do
381+ liftA2 (,) (Rel8.values (Rel8.lit <$> rows1)) (Rel8.values (Rel8.lit <$> rows2))
405382
406383 sort result === sort (liftA2 (,) rows1 rows2)
407384
@@ -430,22 +407,21 @@ testDBType getTestDatabase = testGroup "DBType instances"
430407 where
431408 dbTypeTest :: (Eq a, Show a, Rel8.DBType a) => TestName -> Gen a -> TestTree
432409 dbTypeTest name generator = testGroup name
433− [ databasePropertyTest name (t generator) getTestDatabase
434− , databasePropertyTest ("Maybe " <> name) (t (Gen.maybe generator)) getTestDatabase
410+ [ databasePropertyTest name (t (==) generator) getTestDatabase
411+ , databasePropertyTest ("Maybe " <> name) (t (==) (Gen.maybe generator)) getTestDatabase
435412 ]
436413
437− t :: forall a b. (Eq a, Show a, Rel8.Sql Rel8.DBType a)
438− => Gen a
439− -> (TestT Transaction () -> PropertyT IO b)
414+ t :: forall a b. (Show a, Rel8.Sql Rel8.DBType a)
415+ => (a -> a -> Bool)
416+ -> Gen a
417+ -> ((Connection -> TestT IO ()) -> PropertyT IO b)
440418 -> PropertyT IO b
441− t generator transaction = do
419+ t eq generator transaction = do
442420 x <- forAll generator
443421
444− transaction do
445− [res] <- lift do
446− statement () $ Rel8.select do
447− pure (Rel8.litExpr x)
448− diff res (==) x
422+ transaction \connection -> do
423+ [res] <- liftIO $ Rel8.select connection $ pure (Rel8.litExpr x)
424+ diff res eq x
449425
450426 genDay :: Gen Day
451427 genDay = do
@@ -487,15 +463,13 @@ testDBEq getTestDatabase = testGroup "DBEq instances"
487463
488464 t :: forall a. (Eq a, Show a, Rel8.Sql Rel8.DBEq a)
489465 => Gen a
490− -> (TestT Transaction () -> PropertyT IO ())
466+ -> ((Connection -> TestT IO ()) -> PropertyT IO ())
491467 -> PropertyT IO ()
492468 t generator transaction = do
493469 (x, y) <- forAll (liftA2 (,) generator generator)
494470
495− transaction do
496− [res] <- lift do
497− statement () $ Rel8.select do
498− pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
471+ transaction \connection -> do
472+ [res] <- liftIO $ Rel8.select connection $ pure $ Rel8.litExpr x Rel8.==. Rel8.litExpr y
499473 res === (x == y)
500474
501475
@@ -503,10 +477,9 @@ testTableEquality :: IO TmpPostgres.DB -> TestTree
503477testTableEquality = databasePropertyTest "TestTable equality" \transaction -> do
504478 (x, y) <- forAll $ liftA2 (,) genTestTable genTestTable
505479
506− transaction do
507− [eq] <- lift do
508− statement () $ Rel8.select do
509− pure $ Rel8.lit x Rel8.==: Rel8.lit y
480+ transaction \connection -> do
481+ [eq] <- liftIO $ Rel8.select connection do
482+ pure $ Rel8.lit x Rel8.==: Rel8.lit y
510483
511484 eq === (x == y)
512485
@@ -515,10 +488,8 @@ testFromString :: IO TmpPostgres.DB -> TestTree
515488testFromString = databasePropertyTest "FromString" \transaction -> do
516489 str <- forAll $ Gen.list (Range.linear 0 10) Gen.unicode
517490
518− transaction do
519− [result] <- lift do
520− statement () $ Rel8.select do
521− pure $ fromString str
491+ transaction \connection -> do
492+ [result] <- liftIO $ Rel8.select connection $ pure $ fromString str
522493 result === pack str
523494
524495
@@ -526,11 +497,10 @@ testCatMaybeTable :: IO TmpPostgres.DB -> TestTree
526497testCatMaybeTable = databasePropertyTest "catMaybeTable" \transaction -> do
527498 rows <- forAll $ Gen.list (Range.linear 0 10) genTestTable
528499
529− transaction do
530− selected <- lift do
531− statement () $ Rel8.select do
532− testTable <- Rel8.values $ Rel8.lit <$> rows
533− Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
500+ transaction \connection -> do
501+ selected <- liftIO $ Rel8.select connection do
502+ testTable <- Rel8.values $ Rel8.lit <$> rows
503+ Rel8.catMaybeTable $ Rel8.bool Rel8.nothingTable (pure testTable) (testTableColumn2 testTable)
534504
535505 sort selected === sort (filter testTableColumn2 rows)
536506
@@ -539,10 +509,9 @@ testCatMaybe :: IO TmpPostgres.DB -> TestTree
539509testCatMaybe = databasePropertyTest "catMaybe" \transaction -> evalM do
540510 rows <- forAll $ Gen.list (Range.linear 0 10) $ Gen.maybe Gen.bool
541511
542− transaction do
543− selected <- lift do
544− statement () $ Rel8.select do
545− Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
512+ transaction \connection -> do
513+ selected <- evalM $ liftIO $ Rel8.select connection do
514+ Rel8.catNull =<< Rel8.values (map Rel8.lit rows)
546515
547516 sort selected === sort (catMaybes rows)
548517
@@ -551,38 +520,15 @@ testMaybeTable :: IO TmpPostgres.DB -> TestTree
551520testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do
552521 (rows, def) <- forAll $ liftA2 (,) (Gen.list (Range.linear 0 10) genTestTable) genTestTable
553522
554− transaction do
555− selected <- lift do
556− statement () $ Rel8.select do
557− Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
523+ transaction \connection -> do
524+ selected <- liftIO $ Rel8.select connection $
525+ Rel8.maybeTable (Rel8.lit def) id <$> Rel8.optional (Rel8.values (Rel8.lit <$> rows))
558526
559527 case rows of
560528 [] -> selected === [def]
561529 _ -> sort selected === sort rows
562530
563531
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)))
567−
568− let
569− aggregate = go 0 False False
570− where
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]
577−
578− transaction do
579− selected <- lift do
580− statement () $ Rel8.select do
581− Rel8.aggregate $ Rel8.aggregateMaybeTable Rel8.sum <$> Rel8.values (Rel8.lit <$> rows)
582−
583− sort selected === aggregate rows
584−
585−
586532data TwoTestTables f =
587533 TwoTestTables
588534 { testTable1 :: TestTable f
@@ -603,10 +549,9 @@ testNestedTables = databasePropertyTest "Nested TestTables" \transaction -> eval
603549 Gen.list (Range.linear 0 10) $
604550 liftA2 TwoTestTables genTestTable genTestTable
605551
606− transaction do
607− selected <- lift do
608− statement () $ Rel8.select do
609− Rel8.values (Rel8.lit <$> rows)
552+ transaction \connection -> do
553+ selected <- liftIO $ Rel8.select connection do
554+ Rel8.values (Rel8.lit <$> rows)
610555
611556 sort selected === sort rows
612557
@@ -616,12 +561,11 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
616561 rows1 <- genRows
617562 rows2 <- genRows
618563
619− transaction do
620− selected <- lift do
621− statement () $ Rel8.select do
622− as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
623− bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
624− pure $ liftA2 (,) as bs
564+ transaction \connection -> do
565+ selected <- liftIO $ Rel8.select connection do
566+ as <- Rel8.optional (Rel8.values (Rel8.lit <$> rows1))
567+ bs <- Rel8.optional (Rel8.values (Rel8.lit <$> rows2))
568+ pure $ liftA2 (,) as bs
625569
626570 case (rows1, rows2) of
627571 ([], []) -> selected === [Nothing]
@@ -633,6 +577,14 @@ testMaybeTableApplicative = databasePropertyTest "MaybeTable (<*>)" \transaction
633577 genRows = forAll do
634578 Gen.list (Range.linear 0 10) $ liftA2 TestTable (Gen.text (Range.linear 0 10) Gen.unicode) (pure True)
635579
580+rollingBack
581+ :: (MonadBaseControl IO m, MonadIO m)
582+ => Connection -> m a -> m a
583+rollingBack connection =
584+ bracket_
585+ (liftIO (run (sql "BEGIN") connection))
586+ (liftIO (run (sql "ROLLBACK") connection))
587+
636588
637589genTestTable :: Gen (TestTable Result)
638590genTestTable = do
@@ -645,16 +597,17 @@ testUpdate :: IO TmpPostgres.DB -> TestTree
645597testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
646598 rows <- forAll $ Gen.map (Range.linear 0 5) $ liftA2 (,) genTestTable genTestTable
647599
648− transaction do
649− selected <- lift do
650− statement () $ Rel8.insert Rel8.Insert
600+ transaction \connection -> do
601+ liftIO $ Rel8.insert connection
602+ Rel8.Insert
651603 { into = testTableSchema
652604 , rows = Rel8.values $ map Rel8.lit $ Map.keys rows
653605 , onConflict = Rel8.DoNothing
654606 , returning = pure ()
655607 }
656608
657− statement () $ Rel8.update Rel8.Update
609+ liftIO $ Rel8.update connection
610+ Rel8.Update
658611 { target = testTableSchema
659612 , from = pure ()
660613 , set = \_ r ->
@@ -675,8 +628,8 @@ testUpdate = databasePropertyTest "Can UPDATE TestTable" \transaction -> do
675628 , returning = pure ()
676629 }
677630
678− statement () $ Rel8.select do
679− Rel8.each testTableSchema
631+ selected <- liftIO $ Rel8.select connection do
632+ Rel8.each testTableSchema
680633
681634 sort selected === sort (Map.elems rows)
682635
@@ -689,96 +642,30 @@ testDelete :: IO TmpPostgres.DB -> TestTree
689642testDelete = databasePropertyTest "Can DELETE TestTable" \transaction -> do
690643 rows <- forAll $ Gen.list (Range.linear 0 5) genTestTable
691644
692− transaction do
693− (deleted, selected) <- lift do
694− statement () $ Rel8.insert Rel8.Insert
645+ transaction \connection -> do
646+ liftIO $ Rel8.insert connection
647+ Rel8.Insert
695648 { into = testTableSchema
696649 , rows = Rel8.values $ map Rel8.lit rows
697650 , onConflict = Rel8.DoNothing
698651 , returning = pure ()
699652 }
700653
701− deleted <- statement () $ Rel8.delete Rel8.Delete
654+ deleted <-
655+ liftIO $ Rel8.delete connection
656+ Rel8.Delete
702657 { from = testTableSchema
703658 , using = pure ()
704659 , deleteWhere = const testTableColumn2
705660 , returning = Rel8.Projection id
706661 }
707662
708− selected <- statement () $ Rel8.select do
709− Rel8.each testTableSchema
710−
711− pure (deleted, selected)
663+ selected <- liftIO $ Rel8.select connection do
664+ Rel8.each testTableSchema
712665
713666 sort (deleted <> selected) === sort rows
714667
715668
716−data UniqueTable f = UniqueTable
717− { uniqueTableKey :: Rel8.Column f Text
718− , uniqueTableValue :: Rel8.Column f Text
719− }
720− deriving stock Generic
721− deriving anyclass Rel8.Rel8able
722−
723−
724−deriving stock instance Eq (UniqueTable Result)
725−deriving stock instance Ord (UniqueTable Result)
726−deriving stock instance Show (UniqueTable Result)
727−
728−
729−uniqueTableSchema :: Rel8.TableSchema (UniqueTable Rel8.Name)
730−uniqueTableSchema =
731− Rel8.TableSchema
732− { name = "unique_table"
733− , schema = Nothing
734− , columns = UniqueTable
735− { uniqueTableKey = "key"
736− , uniqueTableValue = "value"
737− }
738− }
739−
740−
741−genUniqueTable :: Gen (UniqueTable Result)
742−genUniqueTable = do
743− uniqueTableKey <- Gen.text (Range.linear 0 5) Gen.alphaNum
744− uniqueTableValue <- Gen.text (Range.linear 0 5) Gen.alphaNum
745− pure UniqueTable {..}
746−
747−
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
752−
753− transaction do
754− selected <- lift do
755− statement () $ Rel8.insert Rel8.Insert
756− { into = uniqueTableSchema
757− , rows = Rel8.values $ Rel8.lit <$> as
758− , onConflict = Rel8.DoNothing
759− , returning = pure ()
760− }
761−
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
769− }
770− , returning = pure ()
771− }
772−
773− statement () $ Rel8.select do
774− Rel8.each uniqueTableSchema
775−
776− fromUniqueTables selected === fromUniqueTables bs <> fromUniqueTables as
777− where
778− unique = fmap (nubOrdOn uniqueTableKey)
779− fromUniqueTables = Map.fromList . map \(UniqueTable key value) -> (key, value)
780−
781−
782669newtype HKNestedPair f = HKNestedPair { pairOne :: (TestTable f, TestTable f) }
783670 deriving stock Generic
784671 deriving anyclass Rel8.Rel8able
@@ -792,10 +679,9 @@ testSelectNestedPairs :: IO TmpPostgres.DB -> TestTree
792679testSelectNestedPairs = databasePropertyTest "Can SELECT nested pairs" \transaction -> do
793680 rows <- forAll $ Gen.list (Range.linear 0 10) $ HKNestedPair <$> liftA2 (,) genTestTable genTestTable
794681
795− transaction do
796− selected <- lift do
797− statement () $ Rel8.select do
798− Rel8.values $ map Rel8.lit rows
682+ transaction \connection -> do
683+ selected <- liftIO $ Rel8.select connection do
684+ Rel8.values $ map Rel8.lit rows
799685
800686 sort selected === sort rows
801687
@@ -804,20 +690,18 @@ testSelectArray :: IO TmpPostgres.DB -> TestTree
804690testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \transaction -> do
805691 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
806692
807− transaction do
808− selected <- lift do
809− statement () $ Rel8.select do
810− Rel8.many $ Rel8.values (map Rel8.lit rows)
693+ transaction \connection -> do
694+ selected <- liftIO $ Rel8.select connection do
695+ Rel8.many $ Rel8.values (map Rel8.lit rows)
811696
812697 selected === [foldMap pure rows]
813698
814− selected' <- lift do
815− statement () $ Rel8.select do
816− a <- Rel8.catListTable =<< do
817− Rel8.many $ Rel8.values (map Rel8.lit rows)
818− b <- Rel8.catListTable =<< do
819− Rel8.many $ Rel8.values (map Rel8.lit rows)
820− pure (a, b)
699+ selected' <- liftIO $ Rel8.select connection $ do
700+ a <- Rel8.catListTable =<< do
701+ Rel8.many $ Rel8.values (map Rel8.lit rows)
702+ b <- Rel8.catListTable =<< do
703+ Rel8.many $ Rel8.values (map Rel8.lit rows)
704+ pure (a, b)
821705
822706 selected' === liftA2 (,) rows rows
823707
@@ -839,11 +723,10 @@ testNestedMaybeTable :: IO TmpPostgres.DB -> TestTree
839723testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other tables" \transaction -> do
840724 let example = NestedMaybeTable { nmt1 = True, nmt2 = Just (TestTable "Hi" True) }
841725
842− transaction do
843− selected <- lift do
844− statement () $ Rel8.select do
845− x <- Rel8.values [Rel8.lit example]
846− pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
726+ transaction \connection -> do
727+ selected <- liftIO $ Rel8.select connection do
728+ x <- Rel8.values [Rel8.lit example]
729+ pure $ Rel8.maybeTable (Rel8.lit False) (\_ -> Rel8.lit True) (nmt2 x)
847730
848731 selected === [True]
849732
@@ -851,12 +734,11 @@ testNestedMaybeTable = databasePropertyTest "Can nest MaybeTable within other ta
851734testEvaluate :: IO TmpPostgres.DB -> TestTree
852735testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect" \transaction -> do
853736
854− transaction do
855− selected <- lift do
856− statement () $ Rel8.select do
857− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
858− y <- Rel8.evaluate (Rel8.nextval "test_seq")
859− pure (x, (y, y))
737+ transaction \connection -> do
738+ selected <- liftIO $ Rel8.select connection do
739+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
740+ y <- Rel8.evaluate (Rel8.nextval "test_seq")
741+ pure (x, (y, y))
860742
861743 normalize selected ===
862744 [ ('a', (0, 0))
@@ -864,12 +746,11 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
864746 , ('c', (2, 2))
865747 ]
866748
867− selected' <- lift do
868− statement () $ Rel8.select do
869− x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
870− y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
871− z <- Rel8.evaluate (Rel8.nextval "test_seq")
872− pure ((x, y), (z, z))
749+ selected' <- liftIO $ Rel8.select connection do
750+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
751+ y <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
752+ z <- Rel8.evaluate (Rel8.nextval "test_seq")
753+ pure ((x, y), (z, z))
873754
874755 normalize selected' ===
875756 [ (('a', 'd'), (0, 0))
@@ -887,3 +768,13 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
887768 normalize :: [(x, (Int64, Int64))] -> [(x, (Int64, Int64))]
888769 normalize [] = []
889770 normalize xs@((_, (i, _)) : _) = map (fmap (\(a, b) -> (a - i, b - i))) xs
771+
772+{-
773+ selected <- liftIO $ Rel8.select connection do
774+ x <- Rel8.values (Rel8.lit <$> ['a', 'b', 'c'])
775+ x <- Rel8.values (Rel8.lit <$> ['d', 'e', 'f'])
776+ y <- Rel8.evaluate (Rel8.nextval "test_seq")
777+ pure (x, y, y)
778+
779+ selected === [('a', 1, 1), ('b', 2, 2), ('c', 3, 3)]
780+-}