1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module UnitTests.NoThunks where
import Test.Tasty (TestTree, testGroup)
#if __GLASGOW_HASKELL__ >=902 && __GLASGOW_HASKELL__ <907
import Data.Maybe (isNothing)
import NoThunks.Class (NoThunks (..), allNoThunks, noThunksInKeysAndValues)
import Test.QuickCheck (ioProperty)
import Test.Tasty.HUnit (assertFailure, testCase)
import Test.Tasty.QuickCheck (testProperty)
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Scientific as Sci
import Data.Aeson
noThunksTests :: TestTree
noThunksTests = testGroup "nothunks"
[ testNoThunks "example1" "null"
, testNoThunks "example2" "[ 1, 2, 3, true ]"
, testNoThunks "example3" "{ \"1\": 1, \"2\": 2 }"
, testProperty "property" $ \input -> ioProperty $ do
let lbs = encode (input :: Value)
!value <- either fail return $ eitherDecode lbs
isNothing <$> noThunks [] (value :: Value)
]
where
testNoThunks name bs = testCase name $ do
!value <- either fail return $ eitherDecode bs
x <- noThunks [] (value :: Value)
case x of
Nothing -> return ()
Just ti -> assertFailure $ show ti
instance NoThunks Value
instance NoThunks v => NoThunks (KM.KeyMap v) where
wNoThunks ctx m = noThunksInKeysAndValues ctx (KM.toList m)
showTypeOf _ = "KeyMap"
instance NoThunks K.Key where
wNoThunks _ _ = return Nothing
showTypeOf _ = "Key"
instance NoThunks Sci.Scientific where
wNoThunks ctx s = do
let !c = Sci.coefficient s
let !e = Sci.base10Exponent s
allNoThunks [ wNoThunks ctx c, wNoThunks ctx e ]
showTypeOf _ = "Scientific"
#else
-- for other GHCs the test group is empty
noThunksTests :: TestTree
noThunksTests = testGroup "nothunks" []
#endif
|
