Document the Semigroup for Map
[packages/containers.git] / tests / map-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.Map.Strict (Map)
12 import qualified Data.Map.Strict as M
13
14 instance (Arbitrary k, Arbitrary v, Ord k) =>
15 Arbitrary (Map k v) where
16 arbitrary = M.fromList `fmap` arbitrary
17
18 apply2 :: Fun (a, b) c -> a -> b -> c
19 apply2 f a b = apply f (a, b)
20
21 apply3 :: Fun (a, b, c) d -> a -> b -> c -> d
22 apply3 f a b c = apply f (a, b, c)
23
24 ------------------------------------------------------------------------
25 -- * Properties
26
27 ------------------------------------------------------------------------
28 -- ** Strict module
29
30 pSingletonKeyStrict :: Int -> Bool
31 pSingletonKeyStrict v = isBottom $ M.singleton (bottom :: Int) v
32
33 pSingletonValueStrict :: Int -> Bool
34 pSingletonValueStrict k = isBottom $ (M.singleton k (bottom :: Int))
35
36 pFindWithDefaultKeyStrict :: Int -> Map Int Int -> Bool
37 pFindWithDefaultKeyStrict def m = isBottom $ M.findWithDefault def bottom m
38
39 pFindWithDefaultValueStrict :: Int -> Map Int Int -> Bool
40 pFindWithDefaultValueStrict k m =
41 M.member k m || (isBottom $ M.findWithDefault bottom k m)
42
43 pAdjustKeyStrict :: Fun Int Int -> Map Int Int -> Bool
44 pAdjustKeyStrict f m = isBottom $ M.adjust (apply f) bottom m
45
46 pAdjustValueStrict :: Int -> Map Int Int -> Bool
47 pAdjustValueStrict k m
48 | k `M.member` m = isBottom $ M.adjust (const bottom) k m
49 | otherwise = case M.keys m of
50 [] -> True
51 (k':_) -> isBottom $ M.adjust (const bottom) k' m
52
53 pInsertKeyStrict :: Int -> Map Int Int -> Bool
54 pInsertKeyStrict v m = isBottom $ M.insert bottom v m
55
56 pInsertValueStrict :: Int -> Map Int Int -> Bool
57 pInsertValueStrict k m = isBottom $ M.insert k bottom m
58
59 pInsertWithKeyStrict :: Fun (Int, Int) Int -> Int -> Map Int Int -> Bool
60 pInsertWithKeyStrict f v m = isBottom $ M.insertWith (apply2 f) bottom v m
61
62 pInsertWithValueStrict :: Fun (Int, Int) Int -> Int -> Int -> Map Int Int
63 -> Bool
64 pInsertWithValueStrict f k v m
65 | M.member k m = (isBottom $ M.insertWith (const2 bottom) k v m) &&
66 not (isBottom $ M.insertWith (const2 1) k bottom m)
67 | otherwise = isBottom $ M.insertWith (apply2 f) k bottom m
68
69 pInsertLookupWithKeyKeyStrict :: Fun (Int, Int, Int) Int -> Int
70 -> Map Int Int -> Bool
71 pInsertLookupWithKeyKeyStrict f v m = isBottom $ M.insertLookupWithKey (apply3 f) bottom v m
72
73 pInsertLookupWithKeyValueStrict :: Fun (Int, Int, Int) Int -> Int -> Int
74 -> Map Int Int -> Bool
75 pInsertLookupWithKeyValueStrict f k v m
76 | M.member k m = (isBottom $ M.insertLookupWithKey (const3 bottom) k v m) &&
77 not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m)
78 | otherwise = isBottom $ M.insertLookupWithKey (apply3 f) k bottom m
79
80 ------------------------------------------------------------------------
81 -- * Test list
82
83 tests :: [Test]
84 tests =
85 [
86 -- Basic interface
87 testGroup "Map.Strict"
88 [ testProperty "singleton is key-strict" pSingletonKeyStrict
89 , testProperty "singleton is value-strict" pSingletonValueStrict
90 , testProperty "member is key-strict" $ keyStrict M.member
91 , testProperty "lookup is key-strict" $ keyStrict M.lookup
92 , testProperty "findWithDefault is key-strict" pFindWithDefaultKeyStrict
93 , testProperty "findWithDefault is value-strict" pFindWithDefaultValueStrict
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 -> Map Int Int -> a) -> Map Int 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