Convert to cabal.project
[packages/containers.git] / containers-tests / tests / intmap-strictness.hs
1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2
3 module Main (main) where
4
5 import Test.ChasingBottoms.IsBottom
6 import Test.Framework (Test, defaultMain, testGroup)
7 import Test.Framework.Providers.QuickCheck2 (testProperty)
8 import Test.QuickCheck (Arbitrary(arbitrary))
9 import Test.QuickCheck.Function (Fun(..), apply)
10
11 import Data.IntMap.Strict (IntMap)
12 import qualified Data.IntMap.Strict as M
13
14 instance Arbitrary v => Arbitrary (IntMap v) where
15 arbitrary = M.fromList `fmap` arbitrary
16
17 apply2 :: Fun (a, b) c -> a -> b -> c
18 apply2 f a b = apply f (a, b)
19
20 apply3 :: Fun (a, b, c) d -> a -> b -> c -> d
21 apply3 f a b c = apply f (a, b, c)
22
23 ------------------------------------------------------------------------
24 -- * Properties
25
26 ------------------------------------------------------------------------
27 -- ** Strict module
28
29 pSingletonKeyStrict :: Int -> Bool
30 pSingletonKeyStrict v = isBottom $ M.singleton (bottom :: Int) v
31
32 pSingletonValueStrict :: Int -> Bool
33 pSingletonValueStrict k = isBottom $ (M.singleton k (bottom :: Int))
34
35 pFindWithDefaultKeyStrict :: Int -> IntMap Int -> Bool
36 pFindWithDefaultKeyStrict def m = isBottom $ M.findWithDefault def bottom m
37
38 pFindWithDefaultValueStrict :: Int -> IntMap Int -> Bool
39 pFindWithDefaultValueStrict k m =
40 M.member k m || (isBottom $ M.findWithDefault bottom k m)
41
42 pAdjustKeyStrict :: Fun Int Int -> IntMap Int -> Bool
43 pAdjustKeyStrict f m = isBottom $ M.adjust (apply f) bottom m
44
45 pAdjustValueStrict :: Int -> IntMap Int -> Bool
46 pAdjustValueStrict k m
47 | k `M.member` m = isBottom $ M.adjust (const bottom) k m
48 | otherwise = case M.keys m of
49 [] -> True
50 (k':_) -> isBottom $ M.adjust (const bottom) k' m
51
52 pInsertKeyStrict :: Int -> IntMap Int -> Bool
53 pInsertKeyStrict v m = isBottom $ M.insert bottom v m
54
55 pInsertValueStrict :: Int -> IntMap Int -> Bool
56 pInsertValueStrict k m = isBottom $ M.insert k bottom m
57
58 pInsertWithKeyStrict :: Fun (Int, Int) Int -> Int -> IntMap Int -> Bool
59 pInsertWithKeyStrict f v m = isBottom $ M.insertWith (apply2 f) bottom v m
60
61 pInsertWithValueStrict :: Fun (Int, Int) Int -> Int -> Int -> IntMap Int
62 -> Bool
63 pInsertWithValueStrict f k v m
64 | M.member k m = (isBottom $ M.insertWith (const2 bottom) k v m) &&
65 not (isBottom $ M.insertWith (const2 1) k bottom m)
66 | otherwise = isBottom $ M.insertWith (apply2 f) k bottom m
67
68 pInsertLookupWithKeyKeyStrict :: Fun (Int, Int, Int) Int -> Int -> IntMap Int
69 -> Bool
70 pInsertLookupWithKeyKeyStrict f v m = isBottom $ M.insertLookupWithKey (apply3 f) bottom v m
71
72 pInsertLookupWithKeyValueStrict :: Fun (Int, Int, Int) Int -> Int -> Int
73 -> IntMap Int -> Bool
74 pInsertLookupWithKeyValueStrict f k v m
75 | M.member k m = (isBottom $ M.insertLookupWithKey (const3 bottom) k v m) &&
76 not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m)
77 | otherwise = isBottom $ M.insertLookupWithKey (apply3 f) k bottom m
78
79 ------------------------------------------------------------------------
80 -- * Test list
81
82 tests :: [Test]
83 tests =
84 [
85 -- Basic interface
86 testGroup "IntMap.Strict"
87 [ testProperty "singleton is key-strict" pSingletonKeyStrict
88 , testProperty "singleton is value-strict" pSingletonValueStrict
89 , testProperty "member is key-strict" $ keyStrict M.member
90 , testProperty "lookup is key-strict" $ keyStrict M.lookup
91 , testProperty "findWithDefault is key-strict" pFindWithDefaultKeyStrict
92 , testProperty "findWithDefault is value-strict" pFindWithDefaultValueStrict
93 , testProperty "! is key-strict" $ keyStrict (flip (M.!))
94 , testProperty "!? is key-strict" $ keyStrict (flip (M.!?))
95 , testProperty "delete is key-strict" $ keyStrict M.delete
96 , testProperty "adjust is key-strict" pAdjustKeyStrict
97 , testProperty "adjust is value-strict" pAdjustValueStrict
98 , testProperty "insert is key-strict" pInsertKeyStrict
99 , testProperty "insert is value-strict" pInsertValueStrict
100 , testProperty "insertWith is key-strict" pInsertWithKeyStrict
101 , testProperty "insertWith is value-strict" pInsertWithValueStrict
102 , testProperty "insertLookupWithKey is key-strict"
103 pInsertLookupWithKeyKeyStrict
104 , testProperty "insertLookupWithKey is value-strict"
105 pInsertLookupWithKeyValueStrict
106 ]
107 ]
108
109 ------------------------------------------------------------------------
110 -- * Test harness
111
112 main :: IO ()
113 main = defaultMain tests
114
115 ------------------------------------------------------------------------
116 -- * Utilities
117
118 keyStrict :: (Int -> IntMap Int -> a) -> IntMap Int -> Bool
119 keyStrict f m = isBottom $ f bottom m
120
121 const2 :: a -> b -> c -> a
122 const2 x _ _ = x
123
124 const3 :: a -> b -> c -> d -> a
125 const3 x _ _ _ = x