1 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 module Main (main) where
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)
11 import Data.Map.Strict (Map)
12 import qualified Data.Map.Strict as M
14 instance (Arbitrary k, Arbitrary v, Ord k) =>
15 Arbitrary (Map k v) where
16 arbitrary = M.fromList `fmap` arbitrary
18 apply2 :: Fun (a, b) c -> a -> b -> c
19 apply2 f a b = apply f (a, b)
21 apply3 :: Fun (a, b, c) d -> a -> b -> c -> d
22 apply3 f a b c = apply f (a, b, c)
24 ------------------------------------------------------------------------
25 -- * Properties
27 ------------------------------------------------------------------------
28 -- ** Strict module
30 pSingletonKeyStrict :: Int -> Bool
31 pSingletonKeyStrict v = isBottom \$ M.singleton (bottom :: Int) v
33 pSingletonValueStrict :: Int -> Bool
34 pSingletonValueStrict k = isBottom \$ (M.singleton k (bottom :: Int))
36 pFindWithDefaultKeyStrict :: Int -> Map Int Int -> Bool
37 pFindWithDefaultKeyStrict def m = isBottom \$ M.findWithDefault def bottom m
39 pFindWithDefaultValueStrict :: Int -> Map Int Int -> Bool
40 pFindWithDefaultValueStrict k m =
41 M.member k m || (isBottom \$ M.findWithDefault bottom k m)
43 pAdjustKeyStrict :: Fun Int Int -> Map Int Int -> Bool
44 pAdjustKeyStrict f m = isBottom \$ M.adjust (apply f) bottom m
46 pAdjustValueStrict :: Int -> Map Int Int -> Bool
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
53 pInsertKeyStrict :: Int -> Map Int Int -> Bool
54 pInsertKeyStrict v m = isBottom \$ M.insert bottom v m
56 pInsertValueStrict :: Int -> Map Int Int -> Bool
57 pInsertValueStrict k m = isBottom \$ M.insert k bottom m
59 pInsertWithKeyStrict :: Fun (Int, Int) Int -> Int -> Map Int Int -> Bool
60 pInsertWithKeyStrict f v m = isBottom \$ M.insertWith (apply2 f) bottom v m
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
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
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
80 ------------------------------------------------------------------------
81 -- * Test list
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
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 ]
109 ------------------------------------------------------------------------
110 -- * Test harness
112 main :: IO ()
113 main = defaultMain tests
115 ------------------------------------------------------------------------
116 -- * Utilities
118 keyStrict :: (Int -> Map Int Int -> a) -> Map Int Int -> Bool
119 keyStrict f m = isBottom \$ f bottom m
121 const2 :: a -> b -> c -> a
122 const2 x _ _ = x
124 const3 :: a -> b -> c -> d -> a
125 const3 x _ _ _ = x