@@ -20,39 +20,39 @@ import Data.List (sort)
2020import qualified Data.Map as Map
2121import Data.Text(Text)
2222import qualified Data.Text.Encoding as T
23−import System.Exit (exitFailure)
24−import System.IO
2523import qualified Data.Vector as V
2624import Data.Aeson
2725import GHC.Generics (Generic)
2826
27+import Test.Tasty
2928import Notify
3029import Serializable
3130import Time
3231
33−tests :: [TestEnv -> Test]
34−tests =
35− [ TestLabel "Bytea" . testBytea
36− , TestLabel "ExecuteMany" . testExecuteMany
37− , TestLabel "Fold" . testFold
38− , TestLabel "Notify" . testNotify
39− , TestLabel "Serializable" . testSerializable
40− , TestLabel "Time" . testTime
41− , TestLabel "Array" . testArray
42− , TestLabel "HStore" . testHStore
43− , TestLabel "JSON" . testJSON
44− , TestLabel "Savepoint" . testSavepoint
45− , TestLabel "Unicode" . testUnicode
46− , TestLabel "Values" . testValues
47− , TestLabel "Copy" . testCopy
48− , TestLabel "Double" . testDouble
49− , TestLabel "1-ary generic" . testGeneric1
50− , TestLabel "2-ary generic" . testGeneric2
51− , TestLabel "3-ary generic" . testGeneric3
32+tests :: TestEnv -> TestTree
33+tests env = testGroup "tests"
34+ $ map ($ env)
35+ [ testBytea
36+ , testCase "ExecuteMany" . testExecuteMany
37+ , testCase "Fold" . testFold
38+ , testCase "Notify" . testNotify
39+ , testCase "Serializable" . testSerializable
40+ , testCase "Time" . testTime
41+ , testCase "Array" . testArray
42+ , testCase "HStore" . testHStore
43+ , testCase "JSON" . testJSON
44+ , testCase "Savepoint" . testSavepoint
45+ , testCase "Unicode" . testUnicode
46+ , testCase "Values" . testValues
47+ , testCase "Copy" . testCopy
48+ , testCase "Double" . testDouble
49+ , testCase "1-ary generic" . testGeneric1
50+ , testCase "2-ary generic" . testGeneric2
51+ , testCase "3-ary generic" . testGeneric3
5252 ]
5353
54−testBytea :: TestEnv -> Test
55−testBytea TestEnv{..} = TestList
54+testBytea :: TestEnv -> TestTree
55+testBytea TestEnv{..} = testGroup "Bytea"
5656 [ testStr "empty" []
5757 , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String)
5858 , testStr "ascending" [0..255]
@@ -61,7 +61,7 @@ testBytea TestEnv{..} = TestList
6161 , testStr "descending, doubled up" $ doubleUp [255,254..0]
6262 ]
6363 where
64− testStr label bytes = TestLabel label $ TestCase $ do
64+ testStr label bytes = testCase label $ do
6565 let bs = B.pack bytes
6666
6767 [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]
@@ -72,8 +72,8 @@ testBytea TestEnv{..} = TestList
7272
7373 doubleUp = concatMap (\x -> [x, x])
7474
75−testExecuteMany :: TestEnv -> Test
76−testExecuteMany TestEnv{..} = TestCase $ do
75+testExecuteMany :: TestEnv -> Assertion
76+testExecuteMany TestEnv{..} = do
7777 execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"
7878
7979 let rows :: [(Int, String, Binary ByteString)]
@@ -90,8 +90,8 @@ testExecuteMany TestEnv{..} = TestCase $ do
9090
9191 return ()
9292
93−testFold :: TestEnv -> Test
94−testFold TestEnv{..} = TestCase $ do
93+testFold :: TestEnv -> Assertion
94+testFold TestEnv{..} = do
9595 xs <- fold_ conn "SELECT generate_series(1,10000)"
9696 [] $ \xs (Only x) -> return (x:xs)
9797 reverse xs @?= ([1..10000] :: [Int])
@@ -160,8 +160,8 @@ queryFailure conn q resultType = do
160160 ++ show (typeOf resultType)
161161 ++ " -> " ++ show val)
162162
163−testArray :: TestEnv -> Test
164−testArray TestEnv{..} = TestCase $ do
163+testArray :: TestEnv -> Assertion
164+testArray TestEnv{..} = do
165165 xs <- query_ conn "SELECT '{1,2,3,4}'::_int4"
166166 xs @?= [Only (V.fromList [1,2,3,4 :: Int])]
167167 xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4"
@@ -170,8 +170,8 @@ testArray TestEnv{..} = TestCase $ do
170170 queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool)
171171 queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int)
172172
173−testHStore :: TestEnv -> Test
174−testHStore TestEnv{..} = TestCase $ do
173+testHStore :: TestEnv -> Assertion
174+testHStore TestEnv{..} = do
175175 execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore"
176176 roundTrip []
177177 roundTrip [("foo","bar"),("bar","baz"),("baz","hello")]
@@ -183,8 +183,8 @@ testHStore TestEnv{..} = TestCase $ do
183183 m' <- query conn "SELECT ?::hstore" m
184184 [m] @?= m'
185185
186−testJSON :: TestEnv -> Test
187−testJSON TestEnv{..} = TestCase $ do
186+testJSON :: TestEnv -> Assertion
187+testJSON TestEnv{..} = do
188188 roundTrip (Map.fromList [] :: Map Text Text)
189189 roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
190190 roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
@@ -198,8 +198,8 @@ testJSON TestEnv{..} = TestCase $ do
198198 js' <- query conn "SELECT ?::json" js
199199 [js] @?= js'
200200
201−testSavepoint :: TestEnv -> Test
202−testSavepoint TestEnv{..} = TestCase $ do
201+testSavepoint :: TestEnv -> Assertion
202+testSavepoint TestEnv{..} = do
203203 True <- expectError ST.isNoActiveTransactionError $
204204 withSavepoint conn $ return ()
205205
@@ -259,8 +259,8 @@ testSavepoint TestEnv{..} = TestCase $ do
259259
260260 return ()
261261
262−testUnicode :: TestEnv -> Test
263−testUnicode TestEnv{..} = TestCase $ do
262+testUnicode :: TestEnv -> Assertion
263+testUnicode TestEnv{..} = do
264264 let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure
265265 -- the table gets created correctly.
266266 let messages = map Only ["привет","мир"] :: [Only Text]
@@ -269,8 +269,8 @@ testUnicode TestEnv{..} = TestCase $ do
269269 messages' <- query_ conn "SELECT сообщение FROM ру́сский"
270270 sort messages @?= sort messages'
271271
272−testValues :: TestEnv -> Test
273−testValues TestEnv{..} = TestCase $ do
272+testValues :: TestEnv -> Assertion
273+testValues TestEnv{..} = do
274274 execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)"
275275 test (Values ["int4","text"] [])
276276 test (Values ["int4","text"] [(1,"hello")])
@@ -287,8 +287,8 @@ testValues TestEnv{..} = TestCase $ do
287287 sort vals @?= sort vals'
288288
289289
290−testCopy :: TestEnv -> Test
291−testCopy TestEnv{..} = TestCase $ do
290+testCopy :: TestEnv -> Assertion
291+testCopy TestEnv{..} = do
292292 execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)"
293293 copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)"
294294 mapM_ (putCopyData conn) copyRows
@@ -315,8 +315,8 @@ testCopy TestEnv{..} = TestCase $ do
315315 CopyOutDone _ -> return rows
316316 CopyOutRow row -> loop (row:rows)
317317
318−testDouble :: TestEnv -> Test
319−testDouble TestEnv{..} = TestCase $ do
318+testDouble :: TestEnv -> Assertion
319+testDouble TestEnv{..} = do
320320 [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8"
321321 assertBool "expected NaN" (isNaN x)
322322 [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8"
@@ -325,24 +325,24 @@ testDouble TestEnv{..} = TestCase $ do
325325 x @?= (-1 / 0)
326326
327327
328−testGeneric1 :: TestEnv -> Test
329−testGeneric1 TestEnv{..} = TestCase $ do
328+testGeneric1 :: TestEnv -> Assertion
329+testGeneric1 TestEnv{..} = do
330330 roundTrip conn (Gen1 123)
331331 where
332332 roundTrip conn x0 = do
333333 r <- query conn "SELECT ?::int" (x0 :: Gen1)
334334 r @?= [x0]
335335
336−testGeneric2 :: TestEnv -> Test
337−testGeneric2 TestEnv{..} = TestCase $ do
336+testGeneric2 :: TestEnv -> Assertion
337+testGeneric2 TestEnv{..} = do
338338 roundTrip conn (Gen2 123 "asdf")
339339 where
340340 roundTrip conn x0 = do
341341 r <- query conn "SELECT ?::int, ?::text" x0
342342 r @?= [x0]
343343
344−testGeneric3 :: TestEnv -> Test
345−testGeneric3 TestEnv{..} = TestCase $ do
344+testGeneric3 :: TestEnv -> Assertion
345+testGeneric3 TestEnv{..} = do
346346 roundTrip conn (Gen3 123 "asdf" True)
347347 where
348348 roundTrip conn x0 = do
@@ -401,8 +401,4 @@ withTestEnv cb =
401401 withConn = bracket testConnect close
402402
403403main :: IO ()
404−main = do
405− mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]
406− Counts{cases, tried, errors, failures} <-
407− withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests
408− when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure
404+main = withTestEnv $ defaultMain . tests