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