diff --git a/Data/HashMap/Base.hs b/Data/HashMap/Base.hs --- a/Data/HashMap/Base.hs +++ b/Data/HashMap/Base.hs @@ -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 diff --git a/Data/HashMap/Strict.hs b/Data/HashMap/Strict.hs --- a/Data/HashMap/Strict.hs +++ b/Data/HashMap/Strict.hs @@ -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? diff --git a/Data/HashSet.hs b/Data/HashSet.hs --- a/Data/HashSet.hs +++ b/Data/HashSet.hs @@ -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 diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs --- a/benchmarks/Benchmarks.hs +++ b/benchmarks/Benchmarks.hs @@ -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 diff --git a/tests/HashMapProperties.hs b/tests/HashMapProperties.hs --- a/tests/HashMapProperties.hs +++ b/tests/HashMapProperties.hs @@ -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 diff --git a/tests/HashSetProperties.hs b/tests/HashSetProperties.hs --- a/tests/HashSetProperties.hs +++ b/tests/HashSetProperties.hs @@ -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 diff --git a/tests/Regressions.hs b/tests/Regressions.hs --- a/tests/Regressions.hs +++ b/tests/Regressions.hs @@ -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 ] ------------------------------------------------------------------------ diff --git a/tests/Strictness.hs b/tests/Strictness.hs new file mode 100644 --- /dev/null +++ b/tests/Strictness.hs @@ -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 _ = "" + +instance Show (Int -> Int -> Int) where + show _ = "" + +------------------------------------------------------------------------ +-- * 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 diff --git a/unordered-containers.cabal b/unordered-containers.cabal --- a/unordered-containers.cabal +++ b/unordered-containers.cabal @@ -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