Skip to content

Commit ce97656

Browse files
bgamaribgamari
committed
Move testsuite to tasty
1 parent 7e74129 commit ce97656

6 files changed

Lines changed: 59 additions & 63 deletions

File tree

‎postgresql-simple.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -115,6 +115,8 @@ test-suite test
115115
, bytestring
116116
, containers
117117
, cryptohash
118+
, tasty
119+
, tasty-hunit
118120
, HUnit
119121
, postgresql-simple
120122
, text

‎test/Common.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,14 @@
11
module Common (
22
module Database.PostgreSQL.Simple,
3-
module Test.HUnit,
3+
module Test.Tasty.HUnit,
44
TestEnv(..),
55
md5,
66
) where
77

88
import Data.ByteString (ByteString)
99
import Data.Text (Text)
1010
import Database.PostgreSQL.Simple
11-
import Test.HUnit
11+
import Test.Tasty.HUnit
1212

1313
import qualified Crypto.Hash.MD5 as MD5
1414
import qualified Data.ByteString.Base16 as Base16

‎test/Main.hs‎

Lines changed: 51 additions & 55 deletions
Original file line numberDiff line numberDiff line change
@@ -20,39 +20,39 @@ import Data.List (sort)
2020
import qualified Data.Map as Map
2121
import Data.Text(Text)
2222
import qualified Data.Text.Encoding as T
23-
import System.Exit (exitFailure)
24-
import System.IO
2523
import qualified Data.Vector as V
2624
import Data.Aeson
2725
import GHC.Generics (Generic)
2826

27+
import Test.Tasty
2928
import Notify
3029
import Serializable
3130
import 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

403403
main :: 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

‎test/Notify.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -14,9 +14,8 @@ import qualified Data.ByteString as B
1414
-- TODO: Test with payload, but only for PostgreSQL >= 9.0
1515
-- (when that feature was introduced).
1616

17-
testNotify :: TestEnv -> Test
17+
testNotify :: TestEnv -> Assertion
1818
testNotify TestEnv{..} =
19-
TestCase $
2019
withConn $ \conn2 -> do
2120
execute_ conn "LISTEN foo"
2221
execute_ conn "LISTEN bar"

‎test/Serializable.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -23,9 +23,8 @@ putCounter conn n = do
2323
1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n)
2424
return ()
2525

26-
testSerializable :: TestEnv -> Test
26+
testSerializable :: TestEnv -> Assertion
2727
testSerializable TestEnv{..} =
28-
TestCase $
2928
withConn $ \conn2 -> do
3029
initCounter conn
3130

‎test/Time.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -43,8 +43,8 @@ import Database.PostgreSQL.Simple.SqlQQ
4343
numTests :: Int
4444
numTests = 200
4545

46-
testTime :: TestEnv -> Test
47-
testTime env@TestEnv{..} = TestCase $ do
46+
testTime :: TestEnv -> Assertion
47+
testTime env@TestEnv{..} = do
4848
initializeTable env
4949
execute_ conn "SET timezone TO 'UTC'"
5050
checkRoundTrips env "1860-01-01 00:00:00+00"

0 commit comments

Comments
 (0)