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