unordered-containers 0.2.2.1 → 0.2.3.0
raw patch · 9 files changed
+414/−122 lines, 9 filesdep +ChasingBottomsdep ~basedep ~containersdep ~test-framework-quickcheck2PVP ok
version bump matches the API change (PVP)
Dependencies added: ChasingBottoms
Dependency ranges changed: base, containers, test-framework-quickcheck2
API changes (from Hackage documentation)
+ Data.HashSet: instance (Data a, Eq a, Hashable a) => Data (HashSet a)
+ Data.HashSet: instance Typeable1 HashSet
Files
- Data/HashMap/Base.hs +68/−17
- Data/HashMap/Strict.hs +18/−6
- Data/HashSet.hs +21/−2
- benchmarks/Benchmarks.hs +85/−81
- tests/HashMapProperties.hs +13/−5
- tests/HashSetProperties.hs +19/−5
- tests/Regressions.hs +53/−2
- tests/Strictness.hs +113/−0
- unordered-containers.cabal +24/−4
Data/HashMap/Base.hs view
@@ -95,6 +95,7 @@ import Data.Typeable (Typeable) #if defined(__GLASGOW_HASKELL__)+import Data.Data hiding (Typeable) import GHC.Exts ((==#), build, reallyUnsafePtrEquality#) #endif @@ -142,6 +143,23 @@ mappend = union {-# INLINE mappend #-} +#if __GLASGOW_HASKELL__+instance (Data k, Data v, Eq k, Hashable k) => Data (HashMap k v) where+ gfoldl f z m = z fromList `f` toList m+ toConstr _ = fromListConstr+ gunfold k z c = case constrIndex c of+ 1 -> k (z fromList)+ _ -> error "gunfold"+ dataTypeOf _ = hashMapDataType+ dataCast2 f = gcast2 f++fromListConstr :: Constr+fromListConstr = mkConstr hashMapDataType "fromList" [] Prefix++hashMapDataType :: DataType+hashMapDataType = mkDataType "Data.HashMap.Base.HashMap" [fromListConstr]+#endif+ type Hash = Word type Bitmap = Word type Shift = Int@@ -156,18 +174,34 @@ (==) = equal equal :: (Eq k, Eq v) => HashMap k v -> HashMap k v -> Bool-equal (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) =- b1 == b2 && A.toList ary1 == A.toList ary2-equal (Leaf k1 v1) (Leaf k2 v2) =- k1 == k2 && v1 == v2-equal (Full ary1) (Full ary2) =- A.toList ary1 == A.toList ary2-equal (Collision k1 ary1) (Collision k2 ary2) =- k1 == k2 && A.length ary1 == A.length ary2- && L.null (A.toList ary1 L.\\ A.toList ary2)-equal Empty Empty = True-equal _ _ = False+equal t1 t2 = go (toList' t1 []) (toList' t2 [])+ where+ -- If the two trees are the same, then their lists of 'Leaf's and+ -- 'Collision's read from left to right should be the same (modulo the+ -- order of elements in 'Collision'). + go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2)+ | k1 == k2 && l1 == l2+ = go tl1 tl2+ go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2)+ | k1 == k2 && A.length ary1 == A.length ary2 &&+ L.null (A.toList ary1 L.\\ A.toList ary2)+ = go tl1 tl2+ go [] [] = True+ go _ _ = False++ toList' (BitmapIndexed _ ary) a = A.foldr toList' a ary+ toList' (Full ary) a = A.foldr toList' a ary+ toList' l@(Leaf _ _) a = l : a+ toList' c@(Collision _ _) a = c : a+ toList' Empty a = a++-- Helper function to detect 'Leaf's and 'Collision's.+isLeafOrCollision :: HashMap k v -> Bool+isLeafOrCollision (Leaf _ _) = True+isLeafOrCollision (Collision _ _) = True+isLeafOrCollision _ = False+ ------------------------------------------------------------------------ -- * Construction @@ -237,7 +271,7 @@ lookupDefault def k t = case lookup k t of Just v -> v _ -> def-{-# INLINE lookupDefault #-}+{-# INLINABLE lookupDefault #-} -- | /O(log n)/ Return the value to which the specified key is mapped. -- Calls 'error' if this map contains no mapping for the key.@@ -461,7 +495,15 @@ then t else case st' of Empty | A.length ary == 1 -> Empty- | otherwise -> BitmapIndexed (b .&. complement m) (A.delete ary i)+ | A.length ary == 2 ->+ case (i, A.index ary 0, A.index ary 1) of+ (0, _, l) | isLeafOrCollision l -> l+ (1, l, _) | isLeafOrCollision l -> l+ _ -> bIndexed+ | otherwise -> bIndexed+ where+ bIndexed = BitmapIndexed (b .&. complement m) (A.delete ary i)+ l | isLeafOrCollision l && A.length ary == 1 -> l _ -> BitmapIndexed b (A.update ary i st') where m = mask h s i = sparseIndex b m@@ -659,15 +701,19 @@ -- * Transformations -- | /O(n)/ Transform this map by applying a function to every value.-map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2-map f = go+mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2+mapWithKey f = go where go Empty = Empty- go (Leaf h (L k v)) = Leaf h $ L k (f v)+ go (Leaf h (L k v)) = Leaf h $ L k (f k v) go (BitmapIndexed b ary) = BitmapIndexed b $ A.map' go ary go (Full ary) = Full $ A.map' go ary go (Collision h ary) = Collision h $- A.map' (\ (L k v) -> L k (f v)) ary+ A.map' (\ (L k v) -> L k (f k v)) ary+{-# INLINE mapWithKey #-}++map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2+map f = mapWithKey (const f) {-# INLINE map #-} -- TODO: We should be able to use mutation to create the new@@ -808,6 +854,11 @@ step !ary !mary !b i !j !bi n | i >= n = case j of 0 -> return Empty+ 1 -> do+ ch <- A.read mary 0+ case ch of+ t | isLeafOrCollision t -> return t+ _ -> BitmapIndexed b <$> trim mary 1 _ -> do ary2 <- trim mary j return $! if j == maxChildren
Data/HashMap/Strict.hs view
@@ -93,8 +93,8 @@ import qualified Data.HashMap.Array as A import qualified Data.HashMap.Base as HM import Data.HashMap.Base hiding (- adjust, fromList, fromListWith, insert, insertWith, intersectionWith, map,- singleton, unionWith)+ adjust, fromList, fromListWith, insert, insertWith, intersectionWith,+ lookupDefault, map, singleton, unionWith) import Data.HashMap.Unsafe (runST) ------------------------------------------------------------------------@@ -107,6 +107,14 @@ ------------------------------------------------------------------------ -- * Basic interface +-- | /O(log n)/ Return the value to which the specified key is mapped,+-- or the default value if this map contains no mapping for the key.+lookupDefault :: (Eq k, Hashable k)+ => v -- ^ Default value to return.+ -> k -> HashMap k v -> v+lookupDefault !def k t = HM.lookupDefault def k t+{-# INLINABLE lookupDefault #-}+ -- | /O(log n)/ Associate the specified value with the specified -- key in this map. If this map previously contained a mapping for -- the key, the old value is replaced.@@ -318,15 +326,19 @@ -- * Transformations -- | /O(n)/ Transform this map by applying a function to every value.-map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2-map f = go+mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2+mapWithKey f = go where go Empty = Empty- go (Leaf h (L k v)) = let !v' = f v in Leaf h $ L k v'+ go (Leaf h (L k v)) = let !v' = f k v in Leaf h $ L k v' go (BitmapIndexed b ary) = BitmapIndexed b $ A.map' go ary go (Full ary) = Full $ A.map' go ary go (Collision h ary) =- Collision h $ A.map' (\ (L k v) -> let !v' = f v in L k v') ary+ Collision h $ A.map' (\ (L k v) -> let !v' = f k v in L k v') ary+{-# INLINE mapWithKey #-}++map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2+map f = mapWithKey (const f) {-# INLINE map #-} -- TODO: Should we add a strict traverseWithKey?
Data/HashSet.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-} ------------------------------------------------------------------------ -- |@@ -67,15 +67,17 @@ import qualified Data.Foldable as Foldable import qualified Data.HashMap.Lazy as H import qualified Data.List as List+import Data.Typeable (Typeable) #if defined(__GLASGOW_HASKELL__)+import Data.Data hiding (Typeable) import GHC.Exts (build) #endif -- | A set of values. A set cannot contain duplicate values. newtype HashSet a = HashSet { asMap :: HashMap a ()- }+ } deriving (Typeable) instance (NFData a) => NFData (HashSet a) where rnf = rnf . asMap@@ -100,6 +102,23 @@ instance (Show a) => Show (HashSet a) where showsPrec d m = showParen (d > 10) $ showString "fromList " . shows (toList m)++#if __GLASGOW_HASKELL__+instance (Data a, Eq a, Hashable a) => Data (HashSet a) where+ gfoldl f z m = z fromList `f` toList m+ toConstr _ = fromListConstr+ gunfold k z c = case constrIndex c of+ 1 -> k (z fromList)+ _ -> error "gunfold"+ dataTypeOf _ = hashSetDataType+ dataCast1 f = gcast1 f++fromListConstr :: Constr+fromListConstr = mkConstr hashSetDataType "fromList" [] Prefix++hashSetDataType :: DataType+hashSetDataType = mkDataType "Data.HashSet" [fromListConstr]+#endif -- | /O(1)/ Construct an empty set. empty :: HashSet a
benchmarks/Benchmarks.hs view
@@ -21,7 +21,9 @@ import qualified Util.Int as UI import qualified Util.String as US +#if !MIN_VERSION_bytestring(0,10,0) instance NFData BS.ByteString+#endif data B where B :: NFData a => a -> B@@ -90,98 +92,100 @@ , bench "fromList" $ whnf IM.fromList elemsI ] - -- * Basic interface- , bgroup "lookup"- [ bench "String" $ whnf (lookup keys) hm- , bench "ByteString" $ whnf (lookup keysBS) hmbs- , bench "Int" $ whnf (lookup keysI) hmi- ]- , bgroup "lookup-miss"- [ bench "String" $ whnf (lookup keys') hm- , bench "ByteString" $ whnf (lookup keysBS') hmbs- , bench "Int" $ whnf (lookup keysI') hmi- ]- , bgroup "insert"- [ bench "String" $ whnf (insert elems) HM.empty- , bench "ByteString" $ whnf (insert elemsBS) HM.empty- , bench "Int" $ whnf (insert elemsI) HM.empty- ]- , bgroup "insert-dup"- [ bench "String" $ whnf (insert elems) hm- , bench "ByteString" $ whnf (insert elemsBS) hmbs- , bench "Int" $ whnf (insert elemsI) hmi- ]- , bgroup "delete"- [ bench "String" $ whnf (delete keys) hm- , bench "ByteString" $ whnf (delete keysBS) hmbs- , bench "Int" $ whnf (delete keysI) hmi- ]- , bgroup "delete-miss"- [ bench "String" $ whnf (delete keys') hm- , bench "ByteString" $ whnf (delete keysBS') hmbs- , bench "Int" $ whnf (delete keysI') hmi- ]+ , bgroup "HashMap"+ [ -- * Basic interface+ bgroup "lookup"+ [ bench "String" $ whnf (lookup keys) hm+ , bench "ByteString" $ whnf (lookup keysBS) hmbs+ , bench "Int" $ whnf (lookup keysI) hmi+ ]+ , bgroup "lookup-miss"+ [ bench "String" $ whnf (lookup keys') hm+ , bench "ByteString" $ whnf (lookup keysBS') hmbs+ , bench "Int" $ whnf (lookup keysI') hmi+ ]+ , bgroup "insert"+ [ bench "String" $ whnf (insert elems) HM.empty+ , bench "ByteString" $ whnf (insert elemsBS) HM.empty+ , bench "Int" $ whnf (insert elemsI) HM.empty+ ]+ , bgroup "insert-dup"+ [ bench "String" $ whnf (insert elems) hm+ , bench "ByteString" $ whnf (insert elemsBS) hmbs+ , bench "Int" $ whnf (insert elemsI) hmi+ ]+ , bgroup "delete"+ [ bench "String" $ whnf (delete keys) hm+ , bench "ByteString" $ whnf (delete keysBS) hmbs+ , bench "Int" $ whnf (delete keysI) hmi+ ]+ , bgroup "delete-miss"+ [ bench "String" $ whnf (delete keys') hm+ , bench "ByteString" $ whnf (delete keysBS') hmbs+ , bench "Int" $ whnf (delete keysI') hmi+ ] - -- Combine- , bench "union" $ whnf (HM.union hmi) hmi2+ -- Combine+ , bench "union" $ whnf (HM.union hmi) hmi2 - -- Transformations- , bench "map" $ whnf (HM.map (\ v -> v + 1)) hmi+ -- Transformations+ , bench "map" $ whnf (HM.map (\ v -> v + 1)) hmi - -- * Difference and intersection- , bench "difference" $ whnf (HM.difference hmi) hmi2- , bench "intersection" $ whnf (HM.intersection hmi) hmi2+ -- * Difference and intersection+ , bench "difference" $ whnf (HM.difference hmi) hmi2+ , bench "intersection" $ whnf (HM.intersection hmi) hmi2 - -- Folds- , bench "foldl'" $ whnf (HM.foldl' (+) 0) hmi- , bench "foldr" $ nf (HM.foldr (:) []) hmi+ -- Folds+ , bench "foldl'" $ whnf (HM.foldl' (+) 0) hmi+ , bench "foldr" $ nf (HM.foldr (:) []) hmi - -- Filter- , bench "filter" $ whnf (HM.filter (\ v -> v .&. 1 == 0)) hmi- , bench "filterWithKey" $ whnf (HM.filterWithKey (\ k _ -> k .&. 1 == 0)) hmi+ -- Filter+ , bench "filter" $ whnf (HM.filter (\ v -> v .&. 1 == 0)) hmi+ , bench "filterWithKey" $ whnf (HM.filterWithKey (\ k _ -> k .&. 1 == 0)) hmi - -- Size- , bgroup "size"- [ bench "String" $ whnf HM.size hm- , bench "ByteString" $ whnf HM.size hmbs- , bench "Int" $ whnf HM.size hmi- ]+ -- Size+ , bgroup "size"+ [ bench "String" $ whnf HM.size hm+ , bench "ByteString" $ whnf HM.size hmbs+ , bench "Int" $ whnf HM.size hmi+ ] - -- fromList- , bgroup "fromList"- [ bgroup name- [ bgroup "long"- [ bench "String" $ whnf fl1 elems- , bench "ByteString" $ whnf fl2 elemsBS- , bench "Int" $ whnf fl3 elemsI- ]- , bgroup "short"- [ bench "String" $ whnf fl1 elemsDup- , bench "ByteString" $ whnf fl2 elemsDupBS- , bench "Int" $ whnf fl3 elemsDupI+ -- fromList+ , bgroup "fromList"+ [ bgroup name+ [ bgroup "long"+ [ bench "String" $ whnf fl1 elems+ , bench "ByteString" $ whnf fl2 elemsBS+ , bench "Int" $ whnf fl3 elemsI+ ]+ , bgroup "short"+ [ bench "String" $ whnf fl1 elemsDup+ , bench "ByteString" $ whnf fl2 elemsDupBS+ , bench "Int" $ whnf fl3 elemsDupI+ ] ]+ | (name,fl1,fl2,fl3)+ <- [("Base",HM.fromList,HM.fromList,HM.fromList)+ ,("insert",fromList_insert,fromList_insert,fromList_insert)] ]- | (name,fl1,fl2,fl3)- <- [("Base",HM.fromList,HM.fromList,HM.fromList)- ,("insert",fromList_insert,fromList_insert,fromList_insert)]- ]- -- fromList- , bgroup "fromListWith"- [ bgroup name- [ bgroup "long"- [ bench "String" $ whnf (fl1 (+)) elems- , bench "ByteString" $ whnf (fl2 (+)) elemsBS- , bench "Int" $ whnf (fl3 (+)) elemsI- ]- , bgroup "short"- [ bench "String" $ whnf (fl1 (+)) elemsDup- , bench "ByteString" $ whnf (fl2 (+)) elemsDupBS- , bench "Int" $ whnf (fl3 (+)) elemsDupI+ -- fromList+ , bgroup "fromListWith"+ [ bgroup name+ [ bgroup "long"+ [ bench "String" $ whnf (fl1 (+)) elems+ , bench "ByteString" $ whnf (fl2 (+)) elemsBS+ , bench "Int" $ whnf (fl3 (+)) elemsI+ ]+ , bgroup "short"+ [ bench "String" $ whnf (fl1 (+)) elemsDup+ , bench "ByteString" $ whnf (fl2 (+)) elemsDupBS+ , bench "Int" $ whnf (fl3 (+)) elemsDupI+ ] ]+ | (name,fl1,fl2,fl3)+ <- [("Base",HM.fromListWith,HM.fromListWith,HM.fromListWith)+ ,("insert",fromListWith_insert,fromListWith_insert,fromListWith_insert)] ]- | (name,fl1,fl2,fl3)- <- [("Base",HM.fromListWith,HM.fromListWith,HM.fromListWith)- ,("insert",fromListWith_insert,fromListWith_insert,fromListWith_insert)] ] ] where
tests/HashMapProperties.hs view
@@ -1,4 +1,4 @@- {-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -- | Tests for the 'Data.HashMap.Lazy' module. We test functions by -- comparing them to a simpler model, an association list.@@ -7,7 +7,7 @@ import qualified Data.Foldable as Foldable import Data.Function (on)-import Data.Hashable (Hashable(hash))+import Data.Hashable (Hashable(hashWithSalt)) import qualified Data.List as L #if defined(STRICT) import qualified Data.HashMap.Strict as HM@@ -24,7 +24,7 @@ deriving (Arbitrary, Eq, Ord, Show) instance Hashable Key where- hash k = hash (unK k) `mod` 20+ hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20 ------------------------------------------------------------------------ -- * Properties@@ -67,7 +67,7 @@ deriving (Arbitrary, Eq, Ord, Show) instance Hashable AlwaysCollide where- hash _ = 1+ hashWithSalt _ _ = 1 -- White-box test that tests the case of deleting one of two keys from -- a map, where the keys' hash values collide.@@ -142,7 +142,15 @@ where f k v z = (k, v) : z pFoldl' :: Int -> [(Int, Int)] -> Bool-pFoldl' z0 = M.foldlWithKey' (\ z _ v -> v + z) z0 `eq` HM.foldl' (+) z0+pFoldl' z0 = foldlWithKey'Map (\ z _ v -> v + z) z0 `eq` HM.foldl' (+) z0++foldlWithKey'Map :: (b -> k -> a -> b) -> b -> M.Map k a -> b+#if MIN_VERSION_containers(4,2,0)+foldlWithKey'Map = M.foldlWithKey'+#else+-- Equivalent except for bottoms, which we don't test.+foldlWithKey'Map = M.foldlWithKey+#endif ------------------------------------------------------------------------ -- ** Filter
tests/HashSetProperties.hs view
@@ -1,4 +1,4 @@- {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -- | Tests for the 'Data.HashSet' module. We test functions by -- comparing them to a simpler model, a list.@@ -6,7 +6,7 @@ module Main (main) where import qualified Data.Foldable as Foldable-import Data.Hashable (Hashable(hash))+import Data.Hashable (Hashable(hashWithSalt)) import qualified Data.List as L import qualified Data.HashSet as S import qualified Data.Set as Set@@ -19,7 +19,7 @@ deriving (Arbitrary, Enum, Eq, Integral, Num, Ord, Show, Real) instance Hashable Key where- hash k = hash (unK k) `mod` 20+ hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20 ------------------------------------------------------------------------ -- * Properties@@ -69,11 +69,25 @@ -- ** Folds pFoldr :: [Int] -> Bool-pFoldr = (L.sort . Set.foldr (:) []) `eq`+pFoldr = (L.sort . foldrSet (:) []) `eq` (L.sort . S.foldr (:) []) +foldrSet :: (a -> b -> b) -> b -> Set.Set a -> b+#if MIN_VERSION_containers(0,4,2)+foldrSet = Set.foldr+#else+foldrSet = Foldable.foldr+#endif+ pFoldl' :: Int -> [Int] -> Bool-pFoldl' z0 = Set.foldl' (+) z0 `eq` S.foldl' (+) z0+pFoldl' z0 = foldl'Set (+) z0 `eq` S.foldl' (+) z0++foldl'Set :: (a -> b -> a) -> a -> Set.Set b -> a+#if MIN_VERSION_containers(0,4,2)+foldl'Set = Set.foldl'+#else+foldl'Set = Foldable.foldl'+#endif ------------------------------------------------------------------------ -- ** Filter
tests/Regressions.hs view
@@ -1,18 +1,28 @@ module Main where +import Control.Applicative ((<$>))+import Control.Monad (replicateM) import qualified Data.HashMap.Strict as HM+import Data.List (delete) import Data.Maybe import Test.HUnit (Assertion, assert) import Test.Framework (Test, defaultMain) import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck issue32 :: Assertion issue32 = assert $ isJust $ HM.lookup 7 m' where ns = [0..16] :: [Int]- m = HM.fromList (zip ns (repeat [])) + m = HM.fromList (zip ns (repeat [])) m' = HM.delete 10 m +------------------------------------------------------------------------+-- Issue #39++-- First regression+ issue39 :: Assertion issue39 = assert $ hm1 == hm2 where@@ -21,6 +31,46 @@ a = (1, -1) :: (Int, Int) b = (-1, 1) :: (Int, Int) +-- Second regression++newtype Keys = Keys [Int]+ deriving Show++instance Arbitrary Keys where+ arbitrary = sized $ \l -> do+ pis <- replicateM (l+1) positiveInt+ return (Keys $ prefixSum pis)++ shrink (Keys ls) =+ let l = length ls+ in if l == 1+ then []+ else [ Keys (dropAt i ls) | i <- [0..l-1] ]++positiveInt :: Gen Int+positiveInt = (+1) . abs <$> arbitrary++prefixSum :: [Int] -> [Int]+prefixSum = loop 0+ where+ loop _ [] = []+ loop prefix (l:ls) = let n = l + prefix+ in n : loop n ls++dropAt :: Int -> [a] -> [a]+dropAt _ [] = []+dropAt i (l:ls) | i == 0 = ls+ | otherwise = l : dropAt (i-1) ls++propEqAfterDelete :: Keys -> Bool+propEqAfterDelete (Keys keys) =+ let keyMap = mapFromKeys keys+ k = head keys+ in HM.delete k keyMap == mapFromKeys (delete k keys)++mapFromKeys :: [Int] -> HM.HashMap Int ()+mapFromKeys keys = HM.fromList (zip keys (repeat ()))+ ------------------------------------------------------------------------ -- * Test list @@ -28,7 +78,8 @@ tests = [ testCase "issue32" issue32- , testCase "issue39" issue39+ , testCase "issue39a" issue39+ , testProperty "issue39b" propEqAfterDelete ] ------------------------------------------------------------------------
+ tests/Strictness.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main (main) where++import Data.Hashable (Hashable(hashWithSalt))+import Test.ChasingBottoms.IsBottom+import Test.Framework (Test, defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck (Arbitrary(arbitrary))++import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM++-- Key type that generates more hash collisions.+newtype Key = K { unK :: Int }+ deriving (Arbitrary, Eq, Ord, Show)++instance Hashable Key where+ hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20++instance (Arbitrary k, Arbitrary v, Eq k, Hashable k) =>+ Arbitrary (HashMap k v) where+ arbitrary = HM.fromList `fmap` arbitrary++instance Show (Int -> Int) where+ show _ = "<function>"++instance Show (Int -> Int -> Int) where+ show _ = "<function>"++------------------------------------------------------------------------+-- * Properties++------------------------------------------------------------------------+-- ** Strict module++pSingletonKeyStrict :: Int -> Bool+pSingletonKeyStrict v = isBottom $ HM.singleton (bottom :: Key) v++pSingletonValueStrict :: Key -> Bool+pSingletonValueStrict k = isBottom $ (HM.singleton k (bottom :: Int))++pLookupDefaultKeyStrict :: Int -> HashMap Key Int -> Bool+pLookupDefaultKeyStrict def m = isBottom $ HM.lookupDefault def bottom m++pLookupDefaultValueStrict :: Key -> HashMap Key Int -> Bool+pLookupDefaultValueStrict k m = isBottom $ HM.lookupDefault bottom k m++pAdjustKeyStrict :: (Int -> Int) -> HashMap Key Int -> Bool+pAdjustKeyStrict f m = isBottom $ HM.adjust f bottom m++pAdjustValueStrict :: Key -> HashMap Key Int -> Bool+pAdjustValueStrict k m+ | k `HM.member` m = isBottom $ HM.adjust (const bottom) k m+ | otherwise = case HM.keys m of+ [] -> True+ (k':_) -> isBottom $ HM.adjust (const bottom) k' m++pInsertKeyStrict :: Int -> HashMap Key Int -> Bool+pInsertKeyStrict v m = isBottom $ HM.insert bottom v m++pInsertValueStrict :: Key -> HashMap Key Int -> Bool+pInsertValueStrict k m = isBottom $ HM.insert k bottom m++pInsertWithKeyStrict :: (Int -> Int -> Int) -> Int -> HashMap Key Int -> Bool+pInsertWithKeyStrict f v m = isBottom $ HM.insertWith f bottom v m++pInsertWithValueStrict :: (Int -> Int -> Int) -> Key -> Int -> HashMap Key Int+ -> Bool+pInsertWithValueStrict f k v m+ | HM.member k m = isBottom $ HM.insertWith (const2 bottom) k v m+ | otherwise = isBottom $ HM.insertWith f k bottom m++------------------------------------------------------------------------+-- * Test list++tests :: [Test]+tests =+ [+ -- Basic interface+ testGroup "HashMap.Strict"+ [ testProperty "singleton is key-strict" pSingletonKeyStrict+ , testProperty "singleton is value-strict" pSingletonValueStrict+ , testProperty "member is key-strict" $ keyStrict HM.member+ , testProperty "lookup is key-strict" $ keyStrict HM.lookup+ , testProperty "lookupDefault is key-strict" pLookupDefaultKeyStrict+ , testProperty "lookupDefault is value-strict" pLookupDefaultValueStrict+ , testProperty "! is key-strict" $ keyStrict (flip (HM.!))+ , testProperty "delete is key-strict" $ keyStrict HM.delete+ , testProperty "adjust is key-strict" pAdjustKeyStrict+ , testProperty "adjust is value-strict" pAdjustValueStrict+ , testProperty "insert is key-strict" pInsertKeyStrict+ , testProperty "insert is value-strict" pInsertValueStrict+ , testProperty "insertWith is key-strict" pInsertWithKeyStrict+ , testProperty "insertWith is value-strict" pInsertWithValueStrict+ ]+ ]++------------------------------------------------------------------------+-- * Test harness++main :: IO ()+main = defaultMain tests++------------------------------------------------------------------------+-- * Utilities++keyStrict :: (Key -> HashMap Key Int -> a) -> HashMap Key Int -> Bool+keyStrict f m = isBottom $ f bottom m++const2 :: a -> b -> c -> a+const2 x _ _ = x
unordered-containers.cabal view
@@ -1,5 +1,5 @@ name: unordered-containers-version: 0.2.2.1+version: 0.2.3.0 synopsis: Efficient hashing-based container types description: Efficient hashing-based container types. The containers have been@@ -59,7 +59,7 @@ build-depends: base,- containers >= 0.4.1,+ containers >= 0.4, hashable >= 1.0.1.1, QuickCheck >= 2.4.0.1, test-framework >= 0.3.3,@@ -76,7 +76,7 @@ build-depends: base,- containers >= 0.4.1,+ containers >= 0.4, hashable >= 1.0.1.1, QuickCheck >= 2.4.0.1, test-framework >= 0.3.3,@@ -93,7 +93,7 @@ build-depends: base,- containers >= 0.4.2,+ containers >= 0.4, hashable >= 1.0.1.1, QuickCheck >= 2.4.0.1, test-framework >= 0.3.3,@@ -112,8 +112,28 @@ base, hashable >= 1.0.1.1, HUnit,+ QuickCheck >= 2.4.0.1, test-framework >= 0.3.3, test-framework-hunit,+ test-framework-quickcheck2,+ unordered-containers++ ghc-options: -Wall+ cpp-options: -DASSERTS++test-suite strictness-properties+ hs-source-dirs: tests+ main-is: Strictness.hs+ type: exitcode-stdio-1.0++ build-depends:+ base,+ ChasingBottoms,+ containers >= 0.4.2,+ hashable >= 1.0.1.1,+ QuickCheck >= 2.4.0.1,+ test-framework >= 0.3.3,+ test-framework-quickcheck2 >= 0.2.9, unordered-containers ghc-options: -Wall