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.IntMap.Strict (IntMap)
12 import qualified Data.IntMap.Strict as M
14 instance Arbitrary v => Arbitrary (IntMap v) where
15 arbitrary = M.fromList `fmap` arbitrary
17 apply2 :: Fun (a, b) c -> a -> b -> c
18 apply2 f a b = apply f (a, b)
20 apply3 :: Fun (a, b, c) d -> a -> b -> c -> d
21 apply3 f a b c = apply f (a, b, c)
23 ------------------------------------------------------------------------
24 -- * Properties
26 ------------------------------------------------------------------------
27 -- ** Strict module
29 pSingletonKeyStrict :: Int -> Bool
30 pSingletonKeyStrict v = isBottom \$ M.singleton (bottom :: Int) v
32 pSingletonValueStrict :: Int -> Bool
33 pSingletonValueStrict k = isBottom \$ (M.singleton k (bottom :: Int))
35 pFindWithDefaultKeyStrict :: Int -> IntMap Int -> Bool
36 pFindWithDefaultKeyStrict def m = isBottom \$ M.findWithDefault def bottom m
38 pFindWithDefaultValueStrict :: Int -> IntMap Int -> Bool
39 pFindWithDefaultValueStrict k m =
40 M.member k m || (isBottom \$ M.findWithDefault bottom k m)
42 pAdjustKeyStrict :: Fun Int Int -> IntMap Int -> Bool
43 pAdjustKeyStrict f m = isBottom \$ M.adjust (apply f) bottom m
45 pAdjustValueStrict :: Int -> IntMap Int -> Bool
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
52 pInsertKeyStrict :: Int -> IntMap Int -> Bool
53 pInsertKeyStrict v m = isBottom \$ M.insert bottom v m
55 pInsertValueStrict :: Int -> IntMap Int -> Bool
56 pInsertValueStrict k m = isBottom \$ M.insert k bottom m
58 pInsertWithKeyStrict :: Fun (Int, Int) Int -> Int -> IntMap Int -> Bool
59 pInsertWithKeyStrict f v m = isBottom \$ M.insertWith (apply2 f) bottom v m
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
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
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
79 ------------------------------------------------------------------------
80 -- * Test list
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
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 -> IntMap Int -> a) -> IntMap 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