1{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
2
3-- | Tests for the 'Data.HashMap.Lazy' module.  We test functions by
4-- comparing them to a simpler model, an association list.
5
6module Main (main) where
7
8import Control.Monad ( guard )
9import qualified Data.Foldable as Foldable
10import Data.Function (on)
11import Data.Hashable (Hashable(hashWithSalt))
12import qualified Data.List as L
13import Data.Ord (comparing)
14#if defined(STRICT)
15import qualified Data.HashMap.Strict as HM
16import qualified Data.Map.Strict as M
17#else
18import qualified Data.HashMap.Lazy as HM
19import qualified Data.Map.Lazy as M
20#endif
21import Test.QuickCheck (Arbitrary, Property, (==>), (===))
22import Test.Framework (Test, defaultMain, testGroup)
23import Test.Framework.Providers.QuickCheck2 (testProperty)
24#if MIN_VERSION_base(4,8,0)
25import Data.Functor.Identity (Identity (..))
26#endif
27import Control.Applicative (Const (..))
28import Test.QuickCheck.Function (Fun, apply)
29import Test.QuickCheck.Poly (A, B)
30
31-- Key type that generates more hash collisions.
32newtype Key = K { unK :: Int }
33            deriving (Arbitrary, Eq, Ord, Read, Show)
34
35instance Hashable Key where
36    hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20
37
38------------------------------------------------------------------------
39-- * Properties
40
41------------------------------------------------------------------------
42-- ** Instances
43
44pEq :: [(Key, Int)] -> [(Key, Int)] -> Bool
45pEq xs = (M.fromList xs ==) `eq` (HM.fromList xs ==)
46
47pNeq :: [(Key, Int)] -> [(Key, Int)] -> Bool
48pNeq xs = (M.fromList xs /=) `eq` (HM.fromList xs /=)
49
50-- We cannot compare to `Data.Map` as ordering is different.
51pOrd1 :: [(Key, Int)] -> Bool
52pOrd1 xs = compare x x == EQ
53  where
54    x = HM.fromList xs
55
56pOrd2 :: [(Key, Int)] -> [(Key, Int)] -> [(Key, Int)] -> Bool
57pOrd2 xs ys zs = case (compare x y, compare y z) of
58    (EQ, o)  -> compare x z == o
59    (o,  EQ) -> compare x z == o
60    (LT, LT) -> compare x z == LT
61    (GT, GT) -> compare x z == GT
62    (LT, GT) -> True -- ys greater than xs and zs.
63    (GT, LT) -> True
64  where
65    x = HM.fromList xs
66    y = HM.fromList ys
67    z = HM.fromList zs
68
69pOrd3 :: [(Key, Int)] -> [(Key, Int)] -> Bool
70pOrd3 xs ys = case (compare x y, compare y x) of
71    (EQ, EQ) -> True
72    (LT, GT) -> True
73    (GT, LT) -> True
74    _        -> False
75  where
76    x = HM.fromList xs
77    y = HM.fromList ys
78
79pOrdEq :: [(Key, Int)] -> [(Key, Int)] -> Bool
80pOrdEq xs ys = case (compare x y, x == y) of
81    (EQ, True)  -> True
82    (LT, False) -> True
83    (GT, False) -> True
84    _           -> False
85  where
86    x = HM.fromList xs
87    y = HM.fromList ys
88
89pReadShow :: [(Key, Int)] -> Bool
90pReadShow xs = M.fromList xs == read (show (M.fromList xs))
91
92pFunctor :: [(Key, Int)] -> Bool
93pFunctor = fmap (+ 1) `eq_` fmap (+ 1)
94
95pFoldable :: [(Int, Int)] -> Bool
96pFoldable = (L.sort . Foldable.foldr (:) []) `eq`
97            (L.sort . Foldable.foldr (:) [])
98
99pHashable :: [(Key, Int)] -> [Int] -> Int -> Property
100pHashable xs is salt =
101    x == y ==> hashWithSalt salt x === hashWithSalt salt y
102  where
103    xs' = L.nubBy (\(k,_) (k',_) -> k == k') xs
104    ys = shuffle is xs'
105    x = HM.fromList xs'
106    y = HM.fromList ys
107    -- Shuffle the list using indexes in the second
108    shuffle :: [Int] -> [a] -> [a]
109    shuffle idxs = L.map snd
110                 . L.sortBy (comparing fst)
111                 . L.zip (idxs ++ [L.maximum (0:is) + 1 ..])
112
113------------------------------------------------------------------------
114-- ** Basic interface
115
116pSize :: [(Key, Int)] -> Bool
117pSize = M.size `eq` HM.size
118
119pMember :: Key -> [(Key, Int)] -> Bool
120pMember k = M.member k `eq` HM.member k
121
122pLookup :: Key -> [(Key, Int)] -> Bool
123pLookup k = M.lookup k `eq` HM.lookup k
124
125pInsert :: Key -> Int -> [(Key, Int)] -> Bool
126pInsert k v = M.insert k v `eq_` HM.insert k v
127
128pDelete :: Key -> [(Key, Int)] -> Bool
129pDelete k = M.delete k `eq_` HM.delete k
130
131newtype AlwaysCollide = AC Int
132    deriving (Arbitrary, Eq, Ord, Show)
133
134instance Hashable AlwaysCollide where
135    hashWithSalt _ _ = 1
136
137-- White-box test that tests the case of deleting one of two keys from
138-- a map, where the keys' hash values collide.
139pDeleteCollision :: AlwaysCollide -> AlwaysCollide -> AlwaysCollide -> Int
140                 -> Property
141pDeleteCollision k1 k2 k3 idx = (k1 /= k2) && (k2 /= k3) && (k1 /= k3) ==>
142                                HM.member toKeep $ HM.delete toDelete $
143                                HM.fromList [(k1, 1 :: Int), (k2, 2), (k3, 3)]
144  where
145    which = idx `mod` 3
146    toDelete
147        | which == 0 = k1
148        | which == 1 = k2
149        | which == 2 = k3
150        | otherwise = error "Impossible"
151    toKeep
152        | which == 0 = k2
153        | which == 1 = k3
154        | which == 2 = k1
155        | otherwise = error "Impossible"
156
157pInsertWith :: Key -> [(Key, Int)] -> Bool
158pInsertWith k = M.insertWith (+) k 1 `eq_` HM.insertWith (+) k 1
159
160pAdjust :: Key -> [(Key, Int)] -> Bool
161pAdjust k = M.adjust succ k `eq_` HM.adjust succ k
162
163pUpdateAdjust :: Key -> [(Key, Int)] -> Bool
164pUpdateAdjust k = M.update (Just . succ) k `eq_` HM.update (Just . succ) k
165
166pUpdateDelete :: Key -> [(Key, Int)] -> Bool
167pUpdateDelete k = M.update (const Nothing) k `eq_` HM.update (const Nothing) k
168
169pAlterAdjust :: Key -> [(Key, Int)] -> Bool
170pAlterAdjust k = M.alter (fmap succ) k `eq_` HM.alter (fmap succ) k
171
172pAlterInsert :: Key -> [(Key, Int)] -> Bool
173pAlterInsert k = M.alter (const $ Just 3) k `eq_` HM.alter (const $ Just 3) k
174
175pAlterDelete :: Key -> [(Key, Int)] -> Bool
176pAlterDelete k = M.alter (const Nothing) k `eq_` HM.alter (const Nothing) k
177
178
179-- We choose the list functor here because we don't fuss with
180-- it in alterF rules and because it has a sufficiently interesting
181-- structure to have a good chance of breaking if something is wrong.
182pAlterF :: Key -> Fun (Maybe A) [Maybe A] -> [(Key, A)] -> Property
183pAlterF k f xs =
184  fmap M.toAscList (M.alterF (apply f) k (M.fromList xs))
185  ===
186  fmap toAscList (HM.alterF (apply f) k (HM.fromList xs))
187
188#if !MIN_VERSION_base(4,8,0)
189newtype Identity a = Identity {runIdentity :: a}
190instance Functor Identity where
191  fmap f (Identity x) = Identity (f x)
192#endif
193
194pAlterFAdjust :: Key -> [(Key, Int)] -> Bool
195pAlterFAdjust k =
196  runIdentity . M.alterF (Identity . fmap succ) k `eq_`
197  runIdentity . HM.alterF (Identity . fmap succ) k
198
199pAlterFInsert :: Key -> [(Key, Int)] -> Bool
200pAlterFInsert k =
201  runIdentity . M.alterF (const . Identity . Just $ 3) k `eq_`
202  runIdentity . HM.alterF (const . Identity . Just $ 3) k
203
204pAlterFInsertWith :: Key -> Fun Int Int -> [(Key, Int)] -> Bool
205pAlterFInsertWith k f =
206  runIdentity . M.alterF (Identity . Just . maybe 3 (apply f)) k `eq_`
207  runIdentity . HM.alterF (Identity . Just . maybe 3 (apply f)) k
208
209pAlterFDelete :: Key -> [(Key, Int)] -> Bool
210pAlterFDelete k =
211  runIdentity . M.alterF (const (Identity Nothing)) k `eq_`
212  runIdentity . HM.alterF (const (Identity Nothing)) k
213
214pAlterFLookup :: Key
215              -> Fun (Maybe A) B
216              -> [(Key, A)] -> Bool
217pAlterFLookup k f =
218  getConst . M.alterF (Const . apply f :: Maybe A -> Const B (Maybe A)) k
219  `eq`
220  getConst . HM.alterF (Const . apply f) k
221
222------------------------------------------------------------------------
223-- ** Combine
224
225pUnion :: [(Key, Int)] -> [(Key, Int)] -> Bool
226pUnion xs ys = M.union (M.fromList xs) `eq_` HM.union (HM.fromList xs) $ ys
227
228pUnionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool
229pUnionWith xs ys = M.unionWith (-) (M.fromList xs) `eq_`
230                   HM.unionWith (-) (HM.fromList xs) $ ys
231
232pUnionWithKey :: [(Key, Int)] -> [(Key, Int)] -> Bool
233pUnionWithKey xs ys = M.unionWithKey go (M.fromList xs) `eq_`
234                             HM.unionWithKey go (HM.fromList xs) $ ys
235  where
236    go :: Key -> Int -> Int -> Int
237    go (K k) i1 i2 = k - i1 + i2
238
239pUnions :: [[(Key, Int)]] -> Bool
240pUnions xss = M.toAscList (M.unions (map M.fromList xss)) ==
241              toAscList (HM.unions (map HM.fromList xss))
242
243------------------------------------------------------------------------
244-- ** Transformations
245
246pMap :: [(Key, Int)] -> Bool
247pMap = M.map (+ 1) `eq_` HM.map (+ 1)
248
249pTraverse :: [(Key, Int)] -> Bool
250pTraverse xs =
251  L.sort (fmap (L.sort . M.toList) (M.traverseWithKey (\_ v -> [v + 1, v + 2]) (M.fromList (take 10 xs))))
252     == L.sort (fmap (L.sort . HM.toList) (HM.traverseWithKey (\_ v -> [v + 1, v + 2]) (HM.fromList (take 10 xs))))
253
254------------------------------------------------------------------------
255-- ** Difference and intersection
256
257pDifference :: [(Key, Int)] -> [(Key, Int)] -> Bool
258pDifference xs ys = M.difference (M.fromList xs) `eq_`
259                    HM.difference (HM.fromList xs) $ ys
260
261pDifferenceWith :: [(Key, Int)] -> [(Key, Int)] -> Bool
262pDifferenceWith xs ys = M.differenceWith f (M.fromList xs) `eq_`
263                        HM.differenceWith f (HM.fromList xs) $ ys
264  where
265    f x y = if x == 0 then Nothing else Just (x - y)
266
267pIntersection :: [(Key, Int)] -> [(Key, Int)] -> Bool
268pIntersection xs ys = M.intersection (M.fromList xs) `eq_`
269                      HM.intersection (HM.fromList xs) $ ys
270
271pIntersectionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool
272pIntersectionWith xs ys = M.intersectionWith (-) (M.fromList xs) `eq_`
273                          HM.intersectionWith (-) (HM.fromList xs) $ ys
274
275pIntersectionWithKey :: [(Key, Int)] -> [(Key, Int)] -> Bool
276pIntersectionWithKey xs ys = M.intersectionWithKey go (M.fromList xs) `eq_`
277                             HM.intersectionWithKey go (HM.fromList xs) $ ys
278  where
279    go :: Key -> Int -> Int -> Int
280    go (K k) i1 i2 = k - i1 - i2
281
282------------------------------------------------------------------------
283-- ** Folds
284
285pFoldr :: [(Int, Int)] -> Bool
286pFoldr = (L.sort . M.foldr (:) []) `eq` (L.sort . HM.foldr (:) [])
287
288pFoldrWithKey :: [(Int, Int)] -> Bool
289pFoldrWithKey = (sortByKey . M.foldrWithKey f []) `eq`
290                (sortByKey . HM.foldrWithKey f [])
291  where f k v z = (k, v) : z
292
293pFoldl' :: Int -> [(Int, Int)] -> Bool
294pFoldl' z0 = foldlWithKey'Map (\ z _ v -> v + z) z0 `eq` HM.foldl' (+) z0
295
296foldlWithKey'Map :: (b -> k -> a -> b) -> b -> M.Map k a -> b
297#if MIN_VERSION_containers(4,2,0)
298foldlWithKey'Map = M.foldlWithKey'
299#else
300-- Equivalent except for bottoms, which we don't test.
301foldlWithKey'Map = M.foldlWithKey
302#endif
303
304------------------------------------------------------------------------
305-- ** Filter
306
307pMapMaybeWithKey :: [(Key, Int)] -> Bool
308pMapMaybeWithKey = M.mapMaybeWithKey f `eq_` HM.mapMaybeWithKey f
309  where f k v = guard (odd (unK k + v)) >> Just (v + 1)
310
311pMapMaybe :: [(Key, Int)] -> Bool
312pMapMaybe = M.mapMaybe f `eq_` HM.mapMaybe f
313  where f v = guard (odd v) >> Just (v + 1)
314
315pFilter :: [(Key, Int)] -> Bool
316pFilter = M.filter odd `eq_` HM.filter odd
317
318pFilterWithKey :: [(Key, Int)] -> Bool
319pFilterWithKey = M.filterWithKey p `eq_` HM.filterWithKey p
320  where p k v = odd (unK k + v)
321
322------------------------------------------------------------------------
323-- ** Conversions
324
325-- 'eq_' already calls fromList.
326pFromList :: [(Key, Int)] -> Bool
327pFromList = id `eq_` id
328
329pFromListWith :: [(Key, Int)] -> Bool
330pFromListWith kvs = (M.toAscList $ M.fromListWith (+) kvs) ==
331                    (toAscList $ HM.fromListWith (+) kvs)
332
333pToList :: [(Key, Int)] -> Bool
334pToList = M.toAscList `eq` toAscList
335
336pElems :: [(Key, Int)] -> Bool
337pElems = (L.sort . M.elems) `eq` (L.sort . HM.elems)
338
339pKeys :: [(Key, Int)] -> Bool
340pKeys = (L.sort . M.keys) `eq` (L.sort . HM.keys)
341
342------------------------------------------------------------------------
343-- * Test list
344
345tests :: [Test]
346tests =
347    [
348    -- Instances
349      testGroup "instances"
350      [ testProperty "==" pEq
351      , testProperty "/=" pNeq
352      , testProperty "compare reflexive" pOrd1
353      , testProperty "compare transitive" pOrd2
354      , testProperty "compare antisymmetric" pOrd3
355      , testProperty "Ord => Eq" pOrdEq
356      , testProperty "Read/Show" pReadShow
357      , testProperty "Functor" pFunctor
358      , testProperty "Foldable" pFoldable
359      , testProperty "Hashable" pHashable
360      ]
361    -- Basic interface
362    , testGroup "basic interface"
363      [ testProperty "size" pSize
364      , testProperty "member" pMember
365      , testProperty "lookup" pLookup
366      , testProperty "insert" pInsert
367      , testProperty "delete" pDelete
368      , testProperty "deleteCollision" pDeleteCollision
369      , testProperty "insertWith" pInsertWith
370      , testProperty "adjust" pAdjust
371      , testProperty "updateAdjust" pUpdateAdjust
372      , testProperty "updateDelete" pUpdateDelete
373      , testProperty "alterAdjust" pAlterAdjust
374      , testProperty "alterInsert" pAlterInsert
375      , testProperty "alterDelete" pAlterDelete
376      , testProperty "alterF" pAlterF
377      , testProperty "alterFAdjust" pAlterFAdjust
378      , testProperty "alterFInsert" pAlterFInsert
379      , testProperty "alterFInsertWith" pAlterFInsertWith
380      , testProperty "alterFDelete" pAlterFDelete
381      , testProperty "alterFLookup" pAlterFLookup
382      ]
383    -- Combine
384    , testProperty "union" pUnion
385    , testProperty "unionWith" pUnionWith
386    , testProperty "unionWithKey" pUnionWithKey
387    , testProperty "unions" pUnions
388    -- Transformations
389    , testProperty "map" pMap
390    , testProperty "traverse" pTraverse
391    -- Folds
392    , testGroup "folds"
393      [ testProperty "foldr" pFoldr
394      , testProperty "foldrWithKey" pFoldrWithKey
395      , testProperty "foldl'" pFoldl'
396      ]
397    , testGroup "difference and intersection"
398      [ testProperty "difference" pDifference
399      , testProperty "differenceWith" pDifferenceWith
400      , testProperty "intersection" pIntersection
401      , testProperty "intersectionWith" pIntersectionWith
402      , testProperty "intersectionWithKey" pIntersectionWithKey
403      ]
404    -- Filter
405    , testGroup "filter"
406      [ testProperty "filter" pFilter
407      , testProperty "filterWithKey" pFilterWithKey
408      , testProperty "mapMaybe" pMapMaybe
409      , testProperty "mapMaybeWithKey" pMapMaybeWithKey
410      ]
411    -- Conversions
412    , testGroup "conversions"
413      [ testProperty "elems" pElems
414      , testProperty "keys" pKeys
415      , testProperty "fromList" pFromList
416      , testProperty "fromListWith" pFromListWith
417      , testProperty "toList" pToList
418      ]
419    ]
420
421------------------------------------------------------------------------
422-- * Model
423
424type Model k v = M.Map k v
425
426-- | Check that a function operating on a 'HashMap' is equivalent to
427-- one operating on a 'Model'.
428eq :: (Eq a, Eq k, Hashable k, Ord k)
429   => (Model k v -> a)       -- ^ Function that modifies a 'Model'
430   -> (HM.HashMap k v -> a)  -- ^ Function that modified a 'HashMap' in the same
431                             -- way
432   -> [(k, v)]               -- ^ Initial content of the 'HashMap' and 'Model'
433   -> Bool                   -- ^ True if the functions are equivalent
434eq f g xs = g (HM.fromList xs) == f (M.fromList xs)
435
436infix 4 `eq`
437
438eq_ :: (Eq k, Eq v, Hashable k, Ord k)
439    => (Model k v -> Model k v)            -- ^ Function that modifies a 'Model'
440    -> (HM.HashMap k v -> HM.HashMap k v)  -- ^ Function that modified a
441                                           -- 'HashMap' in the same way
442    -> [(k, v)]                            -- ^ Initial content of the 'HashMap'
443                                           -- and 'Model'
444    -> Bool                                -- ^ True if the functions are
445                                           -- equivalent
446eq_ f g = (M.toAscList . f) `eq` (toAscList . g)
447
448infix 4 `eq_`
449
450------------------------------------------------------------------------
451-- * Test harness
452
453main :: IO ()
454main = defaultMain tests
455
456------------------------------------------------------------------------
457-- * Helpers
458
459sortByKey :: Ord k => [(k, v)] -> [(k, v)]
460sortByKey = L.sortBy (compare `on` fst)
461
462toAscList :: Ord k => HM.HashMap k v -> [(k, v)]
463toAscList = L.sortBy (compare `on` fst) . HM.toList
464