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