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