unordered-containers 0.2.19.1 → 0.2.20
raw patch · 12 files changed
+1023/−941 lines, 12 filesdep ~hashabledep ~template-haskell
Dependency ranges changed: hashable, template-haskell
Files
- CHANGES.md +27/−0
- Data/HashMap/Internal.hs +194/−130
- Data/HashMap/Internal/Array.hs +3/−8
- Data/HashMap/Internal/Debug.hs +149/−0
- Data/HashMap/Internal/List.hs +2/−2
- Data/HashMap/Internal/Strict.hs +35/−28
- Data/HashSet/Internal.hs +6/−6
- tests/Properties/HashMapLazy.hs +403/−524
- tests/Properties/HashSet.hs +115/−213
- tests/Strictness.hs +11/−26
- tests/Util/Key.hs +69/−0
- unordered-containers.cabal +9/−4
CHANGES.md view
@@ -1,3 +1,30 @@+## [0.2.20] - January 2024++* [Allow `template-haskell-2.21`](https://github.com/haskell-unordered-containers/unordered-containers/pull/484)++* [Rename confusing variables](https://github.com/haskell-unordered-containers/unordered-containers/pull/479)++* [Deal with introduction of `Prelude.foldl'`](https://github.com/haskell-unordered-containers/unordered-containers/pull/480)++* [Remove redundant `Hashable` constraints](https://github.com/haskell-unordered-containers/unordered-containers/pull/478)+ from `intersection.*` and `union.*`.++* Various optimizations and cleanups:+ [#458](https://github.com/haskell-unordered-containers/unordered-containers/pull/458),+ [#469](https://github.com/haskell-unordered-containers/unordered-containers/pull/469),+ [#404](https://github.com/haskell-unordered-containers/unordered-containers/pull/404),+ [#460](https://github.com/haskell-unordered-containers/unordered-containers/pull/460),+ [#456](https://github.com/haskell-unordered-containers/unordered-containers/pull/456),+ [#433](https://github.com/haskell-unordered-containers/unordered-containers/pull/433)++* Add invariant tests:+ [#444](https://github.com/haskell-unordered-containers/unordered-containers/pull/444),+ [#455](https://github.com/haskell-unordered-containers/unordered-containers/pull/455)++* [Improve test case generation](https://github.com/haskell-unordered-containers/unordered-containers/pull/442)++* [Improve test failure reporting](https://github.com/haskell-unordered-containers/unordered-containers/pull/440)+ ## [0.2.19.1] – April 2022 * [Fix bug in `intersection[With[Key]]`](https://github.com/haskell-unordered-containers/unordered-containers/pull/427)
Data/HashMap/Internal.hs view
@@ -107,16 +107,21 @@ , fromListWith , fromListWithKey - -- Internals used by the strict version+ -- ** Internals used by the strict version , Hash , Bitmap+ , Shift , bitmapIndexedOrFull , collision , hash , mask , index , bitsPerSubkey- , fullNodeMask+ , maxChildren+ , isLeafOrCollision+ , fullBitmap+ , subkeyMask+ , nextShift , sparseIndex , two , unionArrayBy@@ -129,6 +134,7 @@ , equalKeys1 , lookupRecordCollision , LookupRes(..)+ , lookupResToMaybe , insert' , delete' , lookup'@@ -158,8 +164,8 @@ import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid) import GHC.Exts (Int (..), Int#, TYPE, (==#)) import GHC.Stack (HasCallStack)-import Prelude hiding (filter, foldl, foldr, lookup, map,- null, pred)+import Prelude hiding (Foldable(..), filter, lookup, map,+ pred) import Text.Read hiding (step) import qualified Data.Data as Data@@ -172,9 +178,6 @@ import qualified GHC.Exts as Exts import qualified Language.Haskell.TH.Syntax as TH --- | A set of values. A set cannot contain duplicate values.-------------------------------------------------------------------------- -- | Convenience function. Compute a hash value for the given value. hash :: H.Hashable a => a -> Hash hash = fromIntegral . H.hash@@ -201,17 +204,46 @@ instance NFData2 Leaf where liftRnf2 rnf1 rnf2 (L k v) = rnf1 k `seq` rnf2 v --- Invariant: The length of the 1st argument to 'Full' is--- 2^bitsPerSubkey- -- | A map from keys to values. A map cannot contain duplicate keys; -- each key can map to at most one value. data HashMap k v = Empty+ -- ^ Invariants:+ --+ -- * 'Empty' is not a valid sub-node. It can only appear at the root. (INV1) | BitmapIndexed !Bitmap !(A.Array (HashMap k v))+ -- ^ Invariants:+ --+ -- * Only the lower @maxChildren@ bits of the 'Bitmap' may be set. The+ -- remaining upper bits must be 0. (INV2)+ -- * The array of a 'BitmapIndexed' node stores at least 1 and at most+ -- @'maxChildren' - 1@ sub-nodes. (INV3)+ -- * The number of sub-nodes is equal to the number of 1-bits in its+ -- 'Bitmap'. (INV4)+ -- * If a 'BitmapIndexed' node has only one sub-node, this sub-node must+ -- be a 'BitmapIndexed' or a 'Full' node. (INV5) | Leaf !Hash !(Leaf k v)+ -- ^ Invariants:+ --+ -- * The location of a 'Leaf' or 'Collision' node in the tree must be+ -- compatible with its 'Hash'. (INV6)+ -- (TODO: Document this properly (#425))+ -- * The 'Hash' of a 'Leaf' node must be the 'hash' of its key. (INV7) | Full !(A.Array (HashMap k v))+ -- ^ Invariants:+ --+ -- * The array of a 'Full' node stores exactly 'maxChildren' sub-nodes. (INV8) | Collision !Hash !(A.Array (Leaf k v))+ -- ^ Invariants:+ --+ -- * The location of a 'Leaf' or 'Collision' node in the tree must be+ -- compatible with its 'Hash'. (INV6)+ -- (TODO: Document this properly (#425))+ -- * The array of a 'Collision' node must contain at least two sub-nodes. (INV9)+ -- * The 'hash' of each key in a 'Collision' node must be the one stored in+ -- the node. (INV7)+ -- * No two keys stored in a 'Collision' can be equal according to their+ -- 'Eq' instance. (INV10) type role HashMap nominal representational @@ -314,7 +346,7 @@ -- | This type is used to store the hash of a key, as produced with 'hash'. type Hash = Word --- | A bitmap as contained by a 'BitmapIndexed' node, or a 'fullNodeMask'+-- | A bitmap as contained by a 'BitmapIndexed' node, or a 'fullBitmap' -- corresponding to a 'Full' node. -- -- Only the lower 'maxChildren' bits are used. The remaining bits must be zeros.@@ -366,7 +398,7 @@ liftEq = equal1 -- | Note that, in the presence of hash collisions, equal @HashMap@s may--- behave differently, i.e. substitutivity may be violated:+-- behave differently, i.e. extensionality may be violated: -- -- >>> data D = A | B deriving (Eq, Show) -- >>> instance Hashable D where hashWithSalt salt _d = salt@@ -381,14 +413,11 @@ -- >>> toList y -- [(B,2),(A,1)] ----- In general, the lack of substitutivity can be observed with any function+-- In general, the lack of extensionality can be observed with any function -- that depends on the key ordering, such as folds and traversals. instance (Eq k, Eq v) => Eq (HashMap k v) where (==) = equal1 (==) --- We rely on there being no Empty constructors in the tree!--- This ensures that two equal HashMaps will have the same--- shape, modulo the order of entries in Collisions. equal1 :: Eq k => (v -> v' -> Bool) -> HashMap k v -> HashMap k v' -> Bool@@ -417,8 +446,8 @@ | k1 == k2 && leafEq l1 l2 = go tl1 tl2- go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2)- | k1 == k2 &&+ go (Collision h1 ary1 : tl1) (Collision h2 ary2 : tl2)+ | h1 == h2 && A.length ary1 == A.length ary2 && isPermutationBy leafEq (A.toList ary1) (A.toList ary2) = go tl1 tl2@@ -447,8 +476,8 @@ = compare k1 k2 `mappend` leafCompare l1 l2 `mappend` go tl1 tl2- go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2)- = compare k1 k2 `mappend`+ go (Collision h1 ary1 : tl1) (Collision h2 ary2 : tl2)+ = compare h1 h2 `mappend` compare (A.length ary1) (A.length ary2) `mappend` unorderedCompare leafCompare (A.toList ary1) (A.toList ary2) `mappend` go tl1 tl2@@ -468,8 +497,8 @@ go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) | k1 == k2 && leafEq l1 l2 = go tl1 tl2- go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2)- | k1 == k2 && A.length ary1 == A.length ary2 &&+ go (Collision h1 ary1 : tl1) (Collision h2 ary2 : tl2)+ | h1 == h2 && A.length ary1 == A.length ary2 && isPermutationBy leafEq (A.toList ary1) (A.toList ary2) = go tl1 tl2 go [] [] = True@@ -623,10 +652,15 @@ (# | (# a, _i #) #) -> Just a {-# INLINE lookup' #-} --- The result of a lookup, keeping track of if a hash collision occured.+-- The result of a lookup, keeping track of if a hash collision occurred. -- If a collision did not occur then it will have the Int value (-1). data LookupRes a = Absent | Present a !Int +lookupResToMaybe :: LookupRes a -> Maybe a+lookupResToMaybe Absent = Nothing+lookupResToMaybe (Present x _) = Just x+{-# INLINE lookupResToMaybe #-}+ -- Internal helper for lookup. This version takes the precomputed hash so -- that functions that make multiple calls to lookup and related functions -- (insert, delete) only need to calculate the hash once.@@ -688,10 +722,10 @@ go h k s (BitmapIndexed b v) | b .&. m == 0 = absent (# #) | otherwise =- go h k (s+bitsPerSubkey) (A.index v (sparseIndex b m))+ go h k (nextShift s) (A.index v (sparseIndex b m)) where m = mask h s go h k s (Full v) =- go h k (s+bitsPerSubkey) (A.index v (index h s))+ go h k (nextShift s) (A.index v (index h s)) go h k _ (Collision hx v) | h == hx = lookupInArrayCont absent present k v | otherwise = absent (# #)@@ -757,7 +791,7 @@ -- @unionWith[Key]@ with GHC 9.2.2. See the Core diffs in -- https://github.com/haskell-unordered-containers/unordered-containers/pull/376. bitmapIndexedOrFull b !ary- | b == fullNodeMask = Full ary+ | b == fullBitmap = Full ary | otherwise = BitmapIndexed b ary {-# INLINE bitmapIndexedOrFull #-} @@ -785,7 +819,7 @@ in bitmapIndexedOrFull (b .|. m) ary' | otherwise = let !st = A.index ary i- !st' = go h k x (s+bitsPerSubkey) st+ !st' = go h k x (nextShift s) st in if st' `ptrEq` st then t else BitmapIndexed b (A.update ary i st')@@ -793,7 +827,7 @@ i = sparseIndex b m go h k x s t@(Full ary) = let !st = A.index ary i- !st' = go h k x (s+bitsPerSubkey) st+ !st' = go h k x (nextShift s) st in if st' `ptrEq` st then t else Full (update32 ary i st')@@ -823,13 +857,13 @@ in bitmapIndexedOrFull (b .|. m) ary' | otherwise = let !st = A.index ary i- !st' = go h k x (s+bitsPerSubkey) st+ !st' = go h k x (nextShift s) st in BitmapIndexed b (A.update ary i st') where m = mask h s i = sparseIndex b m go h k x s (Full ary) = let !st = A.index ary i- !st' = go h k x (s+bitsPerSubkey) st+ !st' = go h k x (nextShift s) st in Full (update32 ary i st') where i = index h s go h k x s t@(Collision hy v)@@ -843,36 +877,42 @@ -- -- It is only valid to call this when the key exists in the map and you know the -- hash collision position if there was one. This information can be obtained--- from 'lookupRecordCollision'. If there is no collision pass (-1) as collPos+-- from 'lookupRecordCollision'. If there is no collision, pass (-1) as collPos -- (first argument).------ We can skip the key equality check on a Leaf because we know the leaf must be--- for this key. insertKeyExists :: Int -> Hash -> k -> v -> HashMap k v -> HashMap k v-insertKeyExists !collPos0 !h0 !k0 x0 !m0 = go collPos0 h0 k0 x0 0 m0+insertKeyExists !collPos0 !h0 !k0 x0 !m0 = go collPos0 h0 k0 x0 m0 where- go !_collPos !h !k x !_s (Leaf _hy _kx)+ go !_collPos !_shiftedHash !k x (Leaf h _kx) = Leaf h (L k x)- go collPos h k x s (BitmapIndexed b ary)- | b .&. m == 0 =- let !ary' = A.insert ary i $ Leaf h (L k x)- in bitmapIndexedOrFull (b .|. m) ary'- | otherwise =- let !st = A.index ary i- !st' = go collPos h k x (s+bitsPerSubkey) st- in BitmapIndexed b (A.update ary i st')- where m = mask h s+ go collPos shiftedHash k x (BitmapIndexed b ary) =+ let !st = A.index ary i+ !st' = go collPos (shiftHash shiftedHash) k x st+ in BitmapIndexed b (A.update ary i st')+ where m = mask' shiftedHash i = sparseIndex b m- go collPos h k x s (Full ary) =+ go collPos shiftedHash k x (Full ary) = let !st = A.index ary i- !st' = go collPos h k x (s+bitsPerSubkey) st+ !st' = go collPos (shiftHash shiftedHash) k x st in Full (update32 ary i st')- where i = index h s- go collPos h k x _s (Collision _hy v)+ where i = index' shiftedHash+ go collPos _shiftedHash k x (Collision h v) | collPos >= 0 = Collision h (setAtPosition collPos k x v) | otherwise = Empty -- error "Internal error: go {collPos negative}"- go _ _ _ _ _ Empty = Empty -- error "Internal error: go Empty"+ go _ _ _ _ Empty = Empty -- error "Internal error: go Empty" + -- Customized version of 'index' that doesn't require a 'Shift'.+ index' :: Hash -> Int+ index' w = fromIntegral $ w .&. subkeyMask+ {-# INLINE index' #-}++ -- Customized version of 'mask' that doesn't require a 'Shift'.+ mask' :: Word -> Bitmap+ mask' w = 1 `unsafeShiftL` index' w+ {-# INLINE mask' #-}++ shiftHash h = h `unsafeShiftR` bitsPerSubkey+ {-# INLINE shiftHash #-}+ {-# NOINLINE insertKeyExists #-} -- Replace the ith Leaf with Leaf k v.@@ -902,14 +942,14 @@ return $! bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i- st' <- go h k x (s+bitsPerSubkey) st+ st' <- go h k x (nextShift s) st A.unsafeUpdateM ary i st' return t where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = do st <- A.indexM ary i- st' <- go h k x (s+bitsPerSubkey) st+ st' <- go h k x (nextShift s) st A.unsafeUpdateM ary i st' return t where i = index h s@@ -931,7 +971,7 @@ where go s h1 k1 v1 h2 t2 | bp1 == bp2 = do- st <- go (s+bitsPerSubkey) h1 k1 v1 h2 t2+ st <- go (nextShift s) h1 k1 v1 h2 t2 ary <- A.singletonM st return $ BitmapIndexed bp1 ary | otherwise = do@@ -942,8 +982,15 @@ where bp1 = mask h1 s bp2 = mask h2 s- idx2 | index h1 s < index h2 s = 1- | otherwise = 0+ !(I# i1) = index h1 s+ !(I# i2) = index h2 s+ idx2 = I# (i1 Exts.<# i2)+ -- This way of computing idx2 saves us a branch compared to the previous approach:+ --+ -- idx2 | index h1 s < index h2 s = 1+ -- | otherwise = 0+ --+ -- See https://github.com/haskell-unordered-containers/unordered-containers/issues/75#issuecomment-1128419337 {-# INLINE two #-} -- | \(O(\log n)\) Associate the value with the key in this map. If@@ -984,7 +1031,7 @@ in bitmapIndexedOrFull (b .|. m) ary' | otherwise = let !st = A.index ary i- !st' = go h k (s+bitsPerSubkey) st+ !st' = go h k (nextShift s) st ary' = A.update ary i $! st' in if ptrEq st st' then t@@ -993,7 +1040,7 @@ i = sparseIndex b m go h k s t@(Full ary) = let !st = A.index ary i- !st' = go h k (s+bitsPerSubkey) st+ !st' = go h k (nextShift s) st ary' = update32 ary i $! st' in if ptrEq st st' then t@@ -1051,14 +1098,14 @@ return $! bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i- st' <- go h k x (s+bitsPerSubkey) st+ st' <- go h k x (nextShift s) st A.unsafeUpdateM ary i st' return t where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = do st <- A.indexM ary i- st' <- go h k x (s+bitsPerSubkey) st+ st' <- go h k x (nextShift s) st A.unsafeUpdateM ary i st' return t where i = index h s@@ -1084,7 +1131,7 @@ | b .&. m == 0 = t | otherwise = let !st = A.index ary i- !st' = go h k (s+bitsPerSubkey) st+ !st' = go h k (nextShift s) st in if st' `ptrEq` st then t else case st' of@@ -1103,13 +1150,13 @@ i = sparseIndex b m go h k s t@(Full ary) = let !st = A.index ary i- !st' = go h k (s+bitsPerSubkey) st+ !st' = go h k (nextShift s) st in if st' `ptrEq` st then t else case st' of Empty -> let ary' = A.delete ary i- bm = fullNodeMask .&. complement (1 `unsafeShiftL` i)+ bm = fullBitmap .&. complement (1 `unsafeShiftL` i) in BitmapIndexed bm ary' _ -> Full (A.update ary i st') where i = index h s@@ -1129,18 +1176,15 @@ -- -- It is only valid to call this when the key exists in the map and you know the -- hash collision position if there was one. This information can be obtained--- from 'lookupRecordCollision'. If there is no collision pass (-1) as collPos.------ We can skip:--- - the key equality check on the leaf, if we reach a leaf it must be the key+-- from 'lookupRecordCollision'. If there is no collision, pass (-1) as collPos. deleteKeyExists :: Int -> Hash -> k -> HashMap k v -> HashMap k v-deleteKeyExists !collPos0 !h0 !k0 !m0 = go collPos0 h0 k0 0 m0+deleteKeyExists !collPos0 !h0 !k0 !m0 = go collPos0 h0 k0 m0 where- go :: Int -> Hash -> k -> Int -> HashMap k v -> HashMap k v- go !_collPos !_h !_k !_s (Leaf _ _) = Empty- go collPos h k s (BitmapIndexed b ary) =+ go :: Int -> Word -> k -> HashMap k v -> HashMap k v+ go !_collPos !_shiftedHash !_k (Leaf _ _) = Empty+ go collPos shiftedHash k (BitmapIndexed b ary) = let !st = A.index ary i- !st' = go collPos h k (s+bitsPerSubkey) st+ !st' = go collPos (shiftHash shiftedHash) k st in case st' of Empty | A.length ary == 1 -> Empty | A.length ary == 2 ->@@ -1153,25 +1197,39 @@ 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+ where m = mask' shiftedHash i = sparseIndex b m- go collPos h k s (Full ary) =+ go collPos shiftedHash k (Full ary) = let !st = A.index ary i- !st' = go collPos h k (s+bitsPerSubkey) st+ !st' = go collPos (shiftHash shiftedHash) k st in case st' of Empty -> let ary' = A.delete ary i- bm = fullNodeMask .&. complement (1 `unsafeShiftL` i)+ bm = fullBitmap .&. complement (1 `unsafeShiftL` i) in BitmapIndexed bm ary' _ -> Full (A.update ary i st')- where i = index h s- go collPos h _ _ (Collision _hy v)+ where i = index' shiftedHash+ go collPos _shiftedHash _k (Collision h v) | A.length v == 2 = if collPos == 0 then Leaf h (A.index v 1) else Leaf h (A.index v 0) | otherwise = Collision h (A.delete v collPos)- go !_ !_ !_ !_ Empty = Empty -- error "Internal error: deleteKeyExists empty"+ go !_ !_ !_ Empty = Empty -- error "Internal error: deleteKeyExists empty"++ -- Customized version of 'index' that doesn't require a 'Shift'.+ index' :: Hash -> Int+ index' w = fromIntegral $ w .&. subkeyMask+ {-# INLINE index' #-}++ -- Customized version of 'mask' that doesn't require a 'Shift'.+ mask' :: Word -> Bitmap+ mask' w = 1 `unsafeShiftL` index' w+ {-# INLINE mask' #-}++ shiftHash h = h `unsafeShiftR` bitsPerSubkey+ {-# INLINE shiftHash #-}+ {-# NOINLINE deleteKeyExists #-} -- | \(O(\log n)\) Adjust the value tied to a given key in this map only@@ -1201,7 +1259,7 @@ go h k s t@(BitmapIndexed b ary) | b .&. m == 0 = t | otherwise = let !st = A.index ary i- !st' = go h k (s+bitsPerSubkey) st+ !st' = go h k (nextShift s) st ary' = A.update ary i $! st' in if ptrEq st st' then t@@ -1211,7 +1269,7 @@ go h k s t@(Full ary) = let i = index h s !st = A.index ary i- !st' = go h k (s+bitsPerSubkey) st+ !st' = go h k (nextShift s) st ary' = update32 ary i $! st' in if ptrEq st st' then t@@ -1241,11 +1299,19 @@ -- 'lookup' k ('alter' f k m) = f ('lookup' k m) -- @ alter :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v--- TODO(m-renaud): Consider using specialized insert and delete for alter. alter f k m =- case f (lookup k m) of- Nothing -> delete k m- Just v -> insert k v m+ let !h = hash k+ !lookupRes = lookupRecordCollision h k m+ in case f (lookupResToMaybe lookupRes) of+ Nothing -> case lookupRes of+ Absent -> m+ Present _ collPos -> deleteKeyExists collPos h k m+ Just v' -> case lookupRes of+ Absent -> insertNewKey h k v' m+ Present v collPos ->+ if v `ptrEq` v'+ then m+ else insertKeyExists collPos h k v' m {-# INLINABLE alter #-} -- | \(O(\log n)\) The expression @('alterF' f k map)@ alters the value @x@ at@@ -1388,9 +1454,7 @@ where !h = hash k !lookupRes = lookupRecordCollision h k m- !mv = case lookupRes of- Absent -> Nothing- Present v _ -> Just v+ !mv = lookupResToMaybe lookupRes {-# INLINABLE alterFEager #-} -- | \(O(n \log m)\) Inclusion of maps. A map is included in another map if the keys@@ -1458,21 +1522,21 @@ go s t1@(Collision h1 _) (BitmapIndexed b ls2) | b .&. m == 0 = False | otherwise =- go (s+bitsPerSubkey) t1 (A.index ls2 (sparseIndex b m))+ go (nextShift s) t1 (A.index ls2 (sparseIndex b m)) where m = mask h1 s -- Similar to the previous case we need to traverse l2 at the index for the hash h1. go s t1@(Collision h1 _) (Full ls2) =- go (s+bitsPerSubkey) t1 (A.index ls2 (index h1 s))+ go (nextShift s) t1 (A.index ls2 (index h1 s)) -- In cases where the first and second map are BitmapIndexed or Full, -- traverse down the tree at the appropriate indices. go s (BitmapIndexed b1 ls1) (BitmapIndexed b2 ls2) =- submapBitmapIndexed (go (s+bitsPerSubkey)) b1 ls1 b2 ls2+ submapBitmapIndexed (go (nextShift s)) b1 ls1 b2 ls2 go s (BitmapIndexed b1 ls1) (Full ls2) =- submapBitmapIndexed (go (s+bitsPerSubkey)) b1 ls1 fullNodeMask ls2+ submapBitmapIndexed (go (nextShift s)) b1 ls1 fullBitmap ls2 go s (Full ls1) (Full ls2) =- submapBitmapIndexed (go (s+bitsPerSubkey)) fullNodeMask ls1 fullNodeMask ls2+ submapBitmapIndexed (go (nextShift s)) fullBitmap ls1 fullBitmap ls2 -- Collision and Full nodes always contain at least two entries. Hence it -- cannot be a map of a leaf.@@ -1518,14 +1582,14 @@ -- -- >>> union (fromList [(1,'a'),(2,'b')]) (fromList [(2,'c'),(3,'d')]) -- fromList [(1,'a'),(2,'b'),(3,'d')]-union :: (Eq k, Hashable k) => HashMap k v -> HashMap k v -> HashMap k v+union :: Eq k => HashMap k v -> HashMap k v -> HashMap k v union = unionWith const {-# INLINABLE union #-} -- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the -- result.-unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v+unionWith :: Eq k => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWith f = unionWithKey (const f) {-# INLINE unionWith #-}@@ -1533,7 +1597,7 @@ -- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the -- result.-unionWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> HashMap k v -> HashMap k v+unionWithKey :: Eq k => (k -> v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWithKey f = go 0 where@@ -1558,16 +1622,16 @@ -- branch vs. branch go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = let b' = b1 .|. b2- ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2+ ary' = unionArrayBy (go (nextShift s)) b1 b2 ary1 ary2 in bitmapIndexedOrFull b' ary' go s (BitmapIndexed b1 ary1) (Full ary2) =- let ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2+ let ary' = unionArrayBy (go (nextShift s)) b1 fullBitmap ary1 ary2 in Full ary' go s (Full ary1) (BitmapIndexed b2 ary2) =- let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2+ let ary' = unionArrayBy (go (nextShift s)) fullBitmap b2 ary1 ary2 in Full ary' go s (Full ary1) (Full ary2) =- let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask+ let ary' = unionArrayBy (go (nextShift s)) fullBitmap fullBitmap ary1 ary2 in Full ary' -- leaf vs. branch@@ -1576,7 +1640,7 @@ b' = b1 .|. m2 in bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary1 i $ \st1 ->- go (s+bitsPerSubkey) st1 t2+ go (nextShift s) st1 t2 in BitmapIndexed b1 ary' where h2 = leafHashCode t2@@ -1587,7 +1651,7 @@ b' = b2 .|. m1 in bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary2 i $ \st2 ->- go (s+bitsPerSubkey) t1 st2+ go (nextShift s) t1 st2 in BitmapIndexed b2 ary' where h1 = leafHashCode t1@@ -1596,12 +1660,12 @@ go s (Full ary1) t2 = let h2 = leafHashCode t2 i = index h2 s- ary' = update32With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2+ ary' = update32With' ary1 i $ \st1 -> go (nextShift s) st1 t2 in Full ary' go s t1 (Full ary2) = let h1 = leafHashCode t1 i = index h1 s- ary' = update32With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2+ ary' = update32With' ary2 i $ \st2 -> go (nextShift s) t1 st2 in Full ary' leafHashCode (Leaf h _) = h@@ -1609,7 +1673,7 @@ leafHashCode _ = error "leafHashCode" goDifferentHash s h1 h2 t1 t2- | m1 == m2 = BitmapIndexed m1 (A.singleton $! goDifferentHash (s+bitsPerSubkey) h1 h2 t1 t2)+ | m1 == m2 = BitmapIndexed m1 (A.singleton $! goDifferentHash (nextShift s) h1 h2 t1 t2) | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1) where@@ -1654,7 +1718,7 @@ -- TODO: Figure out the time complexity of 'unions'. -- | Construct a set containing all elements from a list of sets.-unions :: (Eq k, Hashable k) => [HashMap k v] -> HashMap k v+unions :: Eq k => [HashMap k v] -> HashMap k v unions = List.foldl' union empty {-# INLINE unions #-} @@ -1703,9 +1767,6 @@ map f = mapWithKey (const f) {-# INLINE map #-} --- TODO: We should be able to use mutation to create the new--- 'HashMap'.- -- | \(O(n)\) Perform an 'Applicative' action for each key-value pair -- in a 'HashMap' and produce a 'HashMap' of all the results. --@@ -1772,21 +1833,21 @@ -- | \(O(n \log m)\) Intersection of two maps. Return elements of the first -- map for keys existing in the second.-intersection :: (Eq k, Hashable k) => HashMap k v -> HashMap k w -> HashMap k v+intersection :: Eq k => HashMap k v -> HashMap k w -> HashMap k v intersection = Exts.inline intersectionWith const {-# INLINABLE intersection #-} -- | \(O(n \log m)\) Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps.-intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3+intersectionWith :: Eq k => (v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 intersectionWith f = Exts.inline intersectionWithKey $ const f {-# INLINABLE intersectionWith #-} -- | \(O(n \log m)\) Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps.-intersectionWithKey :: (Eq k, Hashable k) => (k -> v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3+intersectionWithKey :: Eq k => (k -> v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 intersectionWithKey f = intersectionWithKey# $ \k v1 v2 -> (# f k v1 v2 #) {-# INLINABLE intersectionWithKey #-} @@ -1811,30 +1872,30 @@ go _ (Collision h1 ls1) (Collision h2 ls2) = intersectionCollisions f h1 h2 ls1 ls2 -- branch vs. branch go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) =- intersectionArrayBy (go (s + bitsPerSubkey)) b1 b2 ary1 ary2+ intersectionArrayBy (go (nextShift s)) b1 b2 ary1 ary2 go s (BitmapIndexed b1 ary1) (Full ary2) =- intersectionArrayBy (go (s + bitsPerSubkey)) b1 fullNodeMask ary1 ary2+ intersectionArrayBy (go (nextShift s)) b1 fullBitmap ary1 ary2 go s (Full ary1) (BitmapIndexed b2 ary2) =- intersectionArrayBy (go (s + bitsPerSubkey)) fullNodeMask b2 ary1 ary2+ intersectionArrayBy (go (nextShift s)) fullBitmap b2 ary1 ary2 go s (Full ary1) (Full ary2) =- intersectionArrayBy (go (s + bitsPerSubkey)) fullNodeMask fullNodeMask ary1 ary2+ intersectionArrayBy (go (nextShift s)) fullBitmap fullBitmap ary1 ary2 -- collision vs. branch go s (BitmapIndexed b1 ary1) t2@(Collision h2 _ls2) | b1 .&. m2 == 0 = Empty- | otherwise = go (s + bitsPerSubkey) (A.index ary1 i) t2+ | otherwise = go (nextShift s) (A.index ary1 i) t2 where m2 = mask h2 s i = sparseIndex b1 m2 go s t1@(Collision h1 _ls1) (BitmapIndexed b2 ary2) | b2 .&. m1 == 0 = Empty- | otherwise = go (s + bitsPerSubkey) t1 (A.index ary2 i)+ | otherwise = go (nextShift s) t1 (A.index ary2 i) where m1 = mask h1 s i = sparseIndex b2 m1- go s (Full ary1) t2@(Collision h2 _ls2) = go (s + bitsPerSubkey) (A.index ary1 i) t2+ go s (Full ary1) t2@(Collision h2 _ls2) = go (nextShift s) (A.index ary1 i) t2 where i = index h2 s- go s t1@(Collision h1 _ls1) (Full ary2) = go (s + bitsPerSubkey) t1 (A.index ary2 i)+ go s t1@(Collision h1 _ls1) (Full ary2) = go (nextShift s) t1 (A.index ary2 i) where i = index h1 s {-# INLINE intersectionWithKey# #-}@@ -2080,7 +2141,7 @@ | Just t' <- onLeaf t = t' | otherwise = Empty go (BitmapIndexed b ary) = filterA ary b- go (Full ary) = filterA ary fullNodeMask+ go (Full ary) = filterA ary fullBitmap go (Collision h ary) = filterC ary h filterA ary0 b0 =@@ -2099,9 +2160,9 @@ ch <- A.read mary 0 case ch of t | isLeafOrCollision t -> return t- _ -> BitmapIndexed b <$> A.trim mary 1+ _ -> BitmapIndexed b <$> (A.unsafeFreeze =<< A.shrink mary 1) _ -> do- ary2 <- A.trim mary j+ ary2 <- A.unsafeFreeze =<< A.shrink mary j return $! if j == maxChildren then Full ary2 else BitmapIndexed b ary2@@ -2128,7 +2189,7 @@ return $! Leaf h l _ | i == j -> do ary2 <- A.unsafeFreeze mary return $! Collision h ary2- | otherwise -> do ary2 <- A.trim mary j+ | otherwise -> do ary2 <- A.unsafeFreeze =<< A.shrink mary j return $! Collision h ary2 | Just el <- onColl $! A.index ary i = A.write mary j el >> step ary mary (i+1) (j+1) n@@ -2197,7 +2258,7 @@ -- > = fromList [('a', [3, 1]), ('b', [2])] -- -- Note that the lists in the resulting map contain elements in reverse order--- from their occurences in the original list.+-- from their occurrences in the original list. -- -- More generally, duplicate entries are accumulated as follows; -- this matters when @f@ is not commutative or not associative.@@ -2411,7 +2472,7 @@ mask w s = 1 `unsafeShiftL` index w s {-# INLINE mask #-} --- | This array index is computed by counting the number of bits below the+-- | This array index is computed by counting the number of 1-bits below the -- 'index' represented by the mask. -- -- >>> sparseIndex 0b0110_0110 0b0010_0000@@ -2426,15 +2487,18 @@ sparseIndex b m = popCount (b .&. (m - 1)) {-# INLINE sparseIndex #-} --- TODO: Should be named _(bit)map_ instead of _mask_- -- | A bitmap with the 'maxChildren' least significant bits set, i.e. -- @0xFF_FF_FF_FF@.-fullNodeMask :: Bitmap+fullBitmap :: Bitmap -- This needs to use 'shiftL' instead of 'unsafeShiftL', to avoid UB. -- See issue #412.-fullNodeMask = complement (complement 0 `shiftL` maxChildren)-{-# INLINE fullNodeMask #-}+fullBitmap = complement (complement 0 `shiftL` maxChildren)+{-# INLINE fullBitmap #-}++-- | Increment a 'Shift' for use at the next deeper level.+nextShift :: Shift -> Shift+nextShift s = s + bitsPerSubkey+{-# INLINE nextShift #-} ------------------------------------------------------------------------ -- Pointer equality
Data/HashMap/Internal/Array.hs view
@@ -52,7 +52,6 @@ , insertM , delete , sameArray1- , trim , unsafeFreeze , unsafeThaw@@ -60,6 +59,7 @@ , run , copy , copyM+ , cloneM -- * Folds , foldl@@ -94,7 +94,7 @@ unsafeFreezeSmallArray#, unsafeThawSmallArray#, writeSmallArray#) import GHC.ST (ST (..))-import Prelude hiding (all, filter, foldMap, foldl, foldr, length,+import Prelude hiding (Foldable(..), all, filter, map, read, traverse) import qualified GHC.Exts as Exts@@ -318,11 +318,6 @@ case cloneSmallMutableArray# mary# off# len# s of (# s', mary'# #) -> (# s', MArray mary'# #) --- | Create a new array of the @n@ first elements of @mary@.-trim :: MArray s a -> Int -> ST s (Array a)-trim mary n = cloneM mary 0 n >>= unsafeFreeze-{-# INLINE trim #-}- -- | \(O(n)\) Insert an element at the given position in this array, -- increasing its size by one. insert :: Array e -> Int -> e -> Array e@@ -356,7 +351,7 @@ where !count = length ary {-# INLINE updateM #-} --- | \(O(n)\) Update the element at the given positio in this array, by+-- | \(O(n)\) Update the element at the given position in this array, by -- applying a function to it. Evaluates the element to WHNF before -- inserting it into the array. updateWith' :: Array e -> Int -> (e -> e) -> Array e
+ Data/HashMap/Internal/Debug.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeApplications #-}++-- | = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+-- = Description+--+-- Debugging utilities for 'HashMap's.++module Data.HashMap.Internal.Debug+ ( valid+ , Validity(..)+ , Error(..)+ , SubHash+ , SubHashPath+ ) where++import Data.Bits (complement, countTrailingZeros, popCount, shiftL,+ unsafeShiftL, (.&.), (.|.))+import Data.Hashable (Hashable)+import Data.HashMap.Internal (Bitmap, Hash, HashMap (..), Leaf (..),+ bitsPerSubkey, fullBitmap, hash,+ isLeafOrCollision, maxChildren, sparseIndex)+import Data.Semigroup (Sum (..))++import qualified Data.HashMap.Internal.Array as A+++#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif++data Validity k = Invalid (Error k) SubHashPath | Valid+ deriving (Eq, Show)++instance Semigroup (Validity k) where+ Valid <> y = y+ x <> _ = x++instance Monoid (Validity k) where+ mempty = Valid+ mappend = (<>)++-- | An error corresponding to a broken invariant.+--+-- See 'HashMap' for the documentation of the invariants.+data Error k+ = INV1_internal_Empty+ | INV2_Bitmap_unexpected_1_bits !Bitmap+ | INV3_bad_BitmapIndexed_size !Int+ | INV4_bitmap_array_size_mismatch !Bitmap !Int+ | INV5_BitmapIndexed_invalid_single_subtree+ | INV6_misplaced_hash !Hash+ | INV7_key_hash_mismatch k !Hash+ | INV8_bad_Full_size !Int+ | INV9_Collision_size !Int+ | INV10_Collision_duplicate_key k !Hash+ deriving (Eq, Show)++-- TODO: Name this 'Index'?!+-- (https://github.com/haskell-unordered-containers/unordered-containers/issues/425)+-- | A part of a 'Hash' with 'bitsPerSubkey' bits.+type SubHash = Word++data SubHashPath = SubHashPath+ { partialHash :: !Word+ -- ^ The bits we already know, starting from the lower bits.+ -- The unknown upper bits are @0@.+ , lengthInBits :: !Int+ -- ^ The number of bits known.+ } deriving (Eq, Show)++initialSubHashPath :: SubHashPath+initialSubHashPath = SubHashPath 0 0++addSubHash :: SubHashPath -> SubHash -> SubHashPath+addSubHash (SubHashPath ph l) sh =+ SubHashPath (ph .|. (sh `unsafeShiftL` l)) (l + bitsPerSubkey)++hashMatchesSubHashPath :: SubHashPath -> Hash -> Bool+hashMatchesSubHashPath (SubHashPath ph l) h = maskToLength h l == ph+ where+ -- Note: This needs to use `shiftL` instead of `unsafeShiftL` because+ -- @l'@ may be greater than 32/64 at the deepest level.+ maskToLength h' l' = h' .&. complement (complement 0 `shiftL` l')++valid :: Hashable k => HashMap k v -> Validity k+valid Empty = Valid+valid t = validInternal initialSubHashPath t+ where+ validInternal p Empty = Invalid INV1_internal_Empty p+ validInternal p (Leaf h l) = validHash p h <> validLeaf p h l+ validInternal p (Collision h ary) = validHash p h <> validCollision p h ary+ validInternal p (BitmapIndexed b ary) = validBitmapIndexed p b ary+ validInternal p (Full ary) = validFull p ary++ validHash p h | hashMatchesSubHashPath p h = Valid+ | otherwise = Invalid (INV6_misplaced_hash h) p++ validLeaf p h (L k _) | hash k == h = Valid+ | otherwise = Invalid (INV7_key_hash_mismatch k h) p++ validCollision p h ary = validCollisionSize <> A.foldMap (validLeaf p h) ary <> distinctKeys+ where+ n = A.length ary+ validCollisionSize | n < 2 = Invalid (INV9_Collision_size n) p+ | otherwise = Valid+ distinctKeys = A.foldMap (\(L k _) -> appearsOnce k) ary+ appearsOnce k | A.foldMap (\(L k' _) -> if k' == k then Sum @Int 1 else Sum 0) ary == 1 = Valid+ | otherwise = Invalid (INV10_Collision_duplicate_key k h) p++ validBitmapIndexed p b ary = validBitmap <> validArraySize <> validSubTrees p b ary+ where+ validBitmap | b .&. complement fullBitmap == 0 = Valid+ | otherwise = Invalid (INV2_Bitmap_unexpected_1_bits b) p+ n = A.length ary+ validArraySize | n < 1 || n >= maxChildren = Invalid (INV3_bad_BitmapIndexed_size n) p+ | popCount b == n = Valid+ | otherwise = Invalid (INV4_bitmap_array_size_mismatch b n) p++ validSubTrees p b ary+ | A.length ary == 1+ , isLeafOrCollision (A.index ary 0)+ = Invalid INV5_BitmapIndexed_invalid_single_subtree p+ | otherwise = go b+ where+ go 0 = Valid+ go b' = validInternal (addSubHash p (fromIntegral c)) (A.index ary i) <> go b''+ where+ c = countTrailingZeros b'+ m = 1 `unsafeShiftL` c+ i = sparseIndex b m+ b'' = b' .&. complement m++ validFull p ary = validArraySize <> validSubTrees p fullBitmap ary+ where+ n = A.length ary+ validArraySize | n == maxChildren = Valid+ | otherwise = Invalid (INV8_bad_Full_size n) p
Data/HashMap/Internal/List.hs view
@@ -32,7 +32,7 @@ import Data.Semigroup ((<>)) #endif --- Note: previous implemenation isPermutation = null (as // bs)+-- Note: previous implementation isPermutation = null (as // bs) -- was O(n^2) too. -- -- This assumes lists are of equal length@@ -53,7 +53,7 @@ -- The idea: ----- Homogeonous version+-- Homogenous version -- -- uc :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering -- uc c as bs = compare (sortBy c as) (sortBy c bs)
Data/HashMap/Internal/Strict.hs view
@@ -130,8 +130,8 @@ -- See Note [Imports from Data.HashMap.Internal] import Data.Hashable (Hashable) import Data.HashMap.Internal (Hash, HashMap (..), Leaf (..), LookupRes (..),- bitsPerSubkey, fullNodeMask, hash, index, mask,- ptrEq, sparseIndex)+ fullBitmap, hash, index, mask, nextShift, ptrEq,+ sparseIndex) import Prelude hiding (lookup, map) -- See Note [Imports from Data.HashMap.Internal]@@ -203,14 +203,14 @@ in HM.bitmapIndexedOrFull (b .|. m) ary' | otherwise = let st = A.index ary i- st' = go h k x (s+bitsPerSubkey) st+ st' = go h k x (nextShift s) st ary' = A.update ary i $! st' in BitmapIndexed b ary' where m = mask h s i = sparseIndex b m go h k x s (Full ary) = let st = A.index ary i- st' = go h k x (s+bitsPerSubkey) st+ st' = go h k x (nextShift s) st ary' = HM.update32 ary i $! st' in Full ary' where i = index h s@@ -244,14 +244,14 @@ return $! HM.bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i- st' <- go h k x (s+bitsPerSubkey) st+ st' <- go h k x (nextShift s) st A.unsafeUpdateM ary i st' return t where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = do st <- A.indexM ary i- st' <- go h k x (s+bitsPerSubkey) st+ st' <- go h k x (nextShift s) st A.unsafeUpdateM ary i st' return t where i = index h s@@ -273,7 +273,7 @@ go h k s t@(BitmapIndexed b ary) | b .&. m == 0 = t | otherwise = let st = A.index ary i- st' = go h k (s+bitsPerSubkey) st+ st' = go h k (nextShift s) st ary' = A.update ary i $! st' in BitmapIndexed b ary' where m = mask h s@@ -281,7 +281,7 @@ go h k s (Full ary) = let i = index h s st = A.index ary i- st' = go h k (s+bitsPerSubkey) st+ st' = go h k (nextShift s) st ary' = HM.update32 ary i $! st' in Full ary' go h k _ t@(Collision hy v)@@ -306,9 +306,18 @@ -- @ alter :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v alter f k m =- case f (HM.lookup k m) of- Nothing -> HM.delete k m- Just v -> insert k v m+ let !h = hash k+ !lookupRes = HM.lookupRecordCollision h k m+ in case f (HM.lookupResToMaybe lookupRes) of+ Nothing -> case lookupRes of+ Absent -> m+ Present _ collPos -> HM.deleteKeyExists collPos h k m+ Just !v' -> case lookupRes of+ Absent -> HM.insertNewKey h k v' m+ Present v collPos ->+ if v `ptrEq` v'+ then m+ else HM.insertKeyExists collPos h k v' m {-# INLINABLE alter #-} -- | \(O(\log n)\) The expression (@'alterF' f k map@) alters the value @x@ at@@ -429,9 +438,7 @@ where !h = hash k !lookupRes = HM.lookupRecordCollision h k m- !mv = case lookupRes of- Absent -> Nothing- Present v _ -> Just v+ !mv = HM.lookupResToMaybe lookupRes {-# INLINABLE alterFEager #-} ------------------------------------------------------------------------@@ -439,14 +446,14 @@ -- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the result.-unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v+unionWith :: Eq k => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWith f = unionWithKey (const f) {-# INLINE unionWith #-} -- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the result.-unionWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> HashMap k v -> HashMap k v+unionWithKey :: Eq k => (k -> v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWithKey f = go 0 where@@ -471,16 +478,16 @@ -- branch vs. branch go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = let b' = b1 .|. b2- ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2+ ary' = HM.unionArrayBy (go (nextShift s)) b1 b2 ary1 ary2 in HM.bitmapIndexedOrFull b' ary' go s (BitmapIndexed b1 ary1) (Full ary2) =- let ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2+ let ary' = HM.unionArrayBy (go (nextShift s)) b1 fullBitmap ary1 ary2 in Full ary' go s (Full ary1) (BitmapIndexed b2 ary2) =- let ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2+ let ary' = HM.unionArrayBy (go (nextShift s)) fullBitmap b2 ary1 ary2 in Full ary' go s (Full ary1) (Full ary2) =- let ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask+ let ary' = HM.unionArrayBy (go (nextShift s)) fullBitmap fullBitmap ary1 ary2 in Full ary' -- leaf vs. branch@@ -489,7 +496,7 @@ b' = b1 .|. m2 in HM.bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary1 i $ \st1 ->- go (s+bitsPerSubkey) st1 t2+ go (nextShift s) st1 t2 in BitmapIndexed b1 ary' where h2 = leafHashCode t2@@ -500,7 +507,7 @@ b' = b2 .|. m1 in HM.bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary2 i $ \st2 ->- go (s+bitsPerSubkey) t1 st2+ go (nextShift s) t1 st2 in BitmapIndexed b2 ary' where h1 = leafHashCode t1@@ -509,12 +516,12 @@ go s (Full ary1) t2 = let h2 = leafHashCode t2 i = index h2 s- ary' = HM.update32With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2+ ary' = HM.update32With' ary1 i $ \st1 -> go (nextShift s) st1 t2 in Full ary' go s t1 (Full ary2) = let h1 = leafHashCode t1 i = index h1 s- ary' = HM.update32With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2+ ary' = HM.update32With' ary2 i $ \st2 -> go (nextShift s) t1 st2 in Full ary' leafHashCode (Leaf h _) = h@@ -522,7 +529,7 @@ leafHashCode _ = error "leafHashCode" goDifferentHash s h1 h2 t1 t2- | m1 == m2 = BitmapIndexed m1 (A.singleton $! goDifferentHash (s+bitsPerSubkey) h1 h2 t1 t2)+ | m1 == m2 = BitmapIndexed m1 (A.singleton $! goDifferentHash (nextShift s) h1 h2 t1 t2) | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1) where@@ -615,7 +622,7 @@ -- | \(O(n+m)\) Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps.-intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1+intersectionWith :: Eq k => (v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 intersectionWith f = Exts.inline intersectionWithKey $ const f {-# INLINABLE intersectionWith #-}@@ -623,7 +630,7 @@ -- | \(O(n+m)\) Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps.-intersectionWithKey :: (Eq k, Hashable k) => (k -> v1 -> v2 -> v3)+intersectionWithKey :: Eq k => (k -> v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 intersectionWithKey f = HM.intersectionWithKey# $ \k v1 v2 -> let !v3 = f k v1 v2 in (# v3 #) {-# INLINABLE intersectionWithKey #-}@@ -661,7 +668,7 @@ -- > = fromList [('a', [3, 1]), ('b', [2])] -- -- Note that the lists in the resulting map contain elements in reverse order--- from their occurences in the original list.+-- from their occurrences in the original list. -- -- More generally, duplicate entries are accumulated as follows; -- this matters when @f@ is not commutative or not associative.
Data/HashSet/Internal.hs view
@@ -98,7 +98,7 @@ import Data.HashMap.Internal (HashMap, equalKeys, equalKeys1, foldMapWithKey, foldlWithKey, foldrWithKey) import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid)-import Prelude hiding (filter, foldl, foldr, map, null)+import Prelude hiding (Foldable(..), filter, map) import Text.Read import qualified Data.Data as Data@@ -127,7 +127,7 @@ liftRnf rnf1 = liftRnf2 rnf1 rnf . asMap -- | Note that, in the presence of hash collisions, equal @HashSet@s may--- behave differently, i.e. substitutivity may be violated:+-- behave differently, i.e. extensionality may be violated: -- -- >>> data D = A | B deriving (Eq, Show) -- >>> instance Hashable D where hashWithSalt salt _d = salt@@ -142,7 +142,7 @@ -- >>> toList y -- [B,A] ----- In general, the lack of substitutivity can be observed with any function+-- In general, the lack of extensionality can be observed with any function -- that depends on the key ordering, such as folds and traversals. instance (Eq a) => Eq (HashSet a) where HashSet a == HashSet b = equalKeys a b@@ -306,14 +306,14 @@ -- -- >>> union (fromList [1,2]) (fromList [2,3]) -- fromList [1,2,3]-union :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a+union :: Eq a => HashSet a -> HashSet a -> HashSet a union s1 s2 = HashSet $ H.union (asMap s1) (asMap s2) {-# INLINE union #-} -- TODO: Figure out the time complexity of 'unions'. -- | Construct a set containing all elements from a list of sets.-unions :: (Eq a, Hashable a) => [HashSet a] -> HashSet a+unions :: Eq a => [HashSet a] -> HashSet a unions = List.foldl' union empty {-# INLINE unions #-} @@ -391,7 +391,7 @@ -- -- >>> HashSet.intersection (HashSet.fromList [1,2,3]) (HashSet.fromList [2,3,4]) -- fromList [2,3]-intersection :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a+intersection :: Eq a => HashSet a -> HashSet a -> HashSet a intersection (HashSet a) (HashSet b) = HashSet (H.intersection a b) {-# INLINABLE intersection #-}
tests/Properties/HashMapLazy.hs view
@@ -1,10 +1,15 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v)+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-} --- | Tests for the 'Data.HashMap.Lazy' module. We test functions by--- comparing them to @Map@ from @containers@.+{-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v)+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- https://github.com/nick8325/quickcheck/issues/344 +-- | Tests for "Data.HashMap.Lazy" and "Data.HashMap.Strict". We test functions by+-- comparing them to @Map@ from @containers@. @Map@ is referred to as the /model/+-- for 'HashMap'+ #if defined(STRICT) #define MODULE_NAME Properties.HashMapStrict #else@@ -13,22 +18,23 @@ module MODULE_NAME (tests) where -import Control.Applicative (Const (..))-import Control.Monad (guard)+import Control.Applicative (Const (..)) import Data.Bifoldable-import Data.Function (on)-import Data.Functor.Identity (Identity (..))-import Data.Hashable (Hashable (hashWithSalt))-import Data.Ord (comparing)-import Test.QuickCheck (Arbitrary (..), Property, elements, forAll,- (===), (==>))-import Test.QuickCheck.Function (Fun, apply)-import Test.QuickCheck.Poly (A, B)-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.QuickCheck (testProperty)+import Data.Function (on)+import Data.Functor.Identity (Identity (..))+import Data.Hashable (Hashable (hashWithSalt))+import Data.HashMap.Internal.Debug (Validity (..), valid)+import Data.Ord (comparing)+import Test.QuickCheck (Arbitrary (..), Fun, Property, pattern Fn,+ pattern Fn2, pattern Fn3, (===), (==>))+import Test.QuickCheck.Poly (A, B, C)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)+import Util.Key (Key, incKey, keyToInt) -import qualified Data.Foldable as Foldable-import qualified Data.List as List+import qualified Data.Foldable as Foldable+import qualified Data.List as List+import qualified Test.QuickCheck as QC #if defined(STRICT) import Data.HashMap.Strict (HashMap)@@ -40,375 +46,24 @@ import qualified Data.Map.Lazy as M #endif --- Key type that generates more hash collisions.-newtype Key = K { unK :: Int }- deriving (Arbitrary, Eq, Ord, Read, Show, Num)--instance Hashable Key where- hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20- instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where- arbitrary = fmap (HM.fromList) arbitrary----------------------------------------------------------------------------- * Properties----------------------------------------------------------------------------- ** Instances--pEq :: [(Key, Int)] -> [(Key, Int)] -> Bool-pEq xs = (M.fromList xs ==) `eq` (HM.fromList xs ==)--pNeq :: [(Key, Int)] -> [(Key, Int)] -> Bool-pNeq xs = (M.fromList xs /=) `eq` (HM.fromList xs /=)---- We cannot compare to `Data.Map` as ordering is different.-pOrd1 :: [(Key, Int)] -> Bool-pOrd1 xs = compare x x == EQ- where- x = HM.fromList xs--pOrd2 :: [(Key, Int)] -> [(Key, Int)] -> [(Key, Int)] -> Bool-pOrd2 xs ys zs = case (compare x y, compare y z) of- (EQ, o) -> compare x z == o- (o, EQ) -> compare x z == o- (LT, LT) -> compare x z == LT- (GT, GT) -> compare x z == GT- (LT, GT) -> True -- ys greater than xs and zs.- (GT, LT) -> True- where- x = HM.fromList xs- y = HM.fromList ys- z = HM.fromList zs--pOrd3 :: [(Key, Int)] -> [(Key, Int)] -> Bool-pOrd3 xs ys = case (compare x y, compare y x) of- (EQ, EQ) -> True- (LT, GT) -> True- (GT, LT) -> True- _ -> False- where- x = HM.fromList xs- y = HM.fromList ys--pOrdEq :: [(Key, Int)] -> [(Key, Int)] -> Bool-pOrdEq xs ys = case (compare x y, x == y) of- (EQ, True) -> True- (LT, False) -> True- (GT, False) -> True- _ -> False- where- x = HM.fromList xs- y = HM.fromList ys--pReadShow :: [(Key, Int)] -> Bool-pReadShow xs = M.fromList xs == read (show (M.fromList xs))--pFunctor :: [(Key, Int)] -> Bool-pFunctor = fmap (+ 1) `eq_` fmap (+ 1)--pFoldable :: [(Int, Int)] -> Bool-pFoldable = (List.sort . Foldable.foldr (:) []) `eq`- (List.sort . Foldable.foldr (:) [])--pHashable :: [(Key, Int)] -> [Int] -> Int -> Property-pHashable xs is salt =- x == y ==> hashWithSalt salt x === hashWithSalt salt y- where- xs' = List.nubBy (\(k,_) (k',_) -> k == k') xs- ys = shuffle is xs'- x = HM.fromList xs'- y = HM.fromList ys- -- Shuffle the list using indexes in the second- shuffle :: [Int] -> [a] -> [a]- shuffle idxs = List.map snd- . List.sortBy (comparing fst)- . List.zip (idxs ++ [List.maximum (0:is) + 1 ..])----------------------------------------------------------------------------- ** Basic interface--pSize :: [(Key, Int)] -> Bool-pSize = M.size `eq` HM.size--pMember :: Key -> [(Key, Int)] -> Bool-pMember k = M.member k `eq` HM.member k--pLookup :: Key -> [(Key, Int)] -> Bool-pLookup k = M.lookup k `eq` HM.lookup k--pLookupOperator :: Key -> [(Key, Int)] -> Bool-pLookupOperator k = M.lookup k `eq` (HM.!? k)--pInsert :: Key -> Int -> [(Key, Int)] -> Bool-pInsert k v = M.insert k v `eq_` HM.insert k v--pDelete :: Key -> [(Key, Int)] -> Bool-pDelete k = M.delete k `eq_` HM.delete k--newtype AlwaysCollide = AC Int- deriving (Arbitrary, Eq, Ord, Show)--instance Hashable AlwaysCollide where- hashWithSalt _ _ = 1---- White-box test that tests the case of deleting one of two keys from--- a map, where the keys' hash values collide.-pDeleteCollision :: AlwaysCollide -> AlwaysCollide -> AlwaysCollide -> Int- -> Property-pDeleteCollision k1 k2 k3 idx = (k1 /= k2) && (k2 /= k3) && (k1 /= k3) ==>- HM.member toKeep $ HM.delete toDelete $- HM.fromList [(k1, 1 :: Int), (k2, 2), (k3, 3)]- where- which = idx `mod` 3- toDelete- | which == 0 = k1- | which == 1 = k2- | which == 2 = k3- | otherwise = error "Impossible"- toKeep- | which == 0 = k2- | which == 1 = k3- | which == 2 = k1- | otherwise = error "Impossible"--pInsertWith :: Key -> [(Key, Int)] -> Bool-pInsertWith k = M.insertWith (+) k 1 `eq_` HM.insertWith (+) k 1--pAdjust :: Key -> [(Key, Int)] -> Bool-pAdjust k = M.adjust succ k `eq_` HM.adjust succ k--pUpdateAdjust :: Key -> [(Key, Int)] -> Bool-pUpdateAdjust k = M.update (Just . succ) k `eq_` HM.update (Just . succ) k--pUpdateDelete :: Key -> [(Key, Int)] -> Bool-pUpdateDelete k = M.update (const Nothing) k `eq_` HM.update (const Nothing) k--pAlterAdjust :: Key -> [(Key, Int)] -> Bool-pAlterAdjust k = M.alter (fmap succ) k `eq_` HM.alter (fmap succ) k--pAlterInsert :: Key -> [(Key, Int)] -> Bool-pAlterInsert k = M.alter (const $ Just 3) k `eq_` HM.alter (const $ Just 3) k--pAlterDelete :: Key -> [(Key, Int)] -> Bool-pAlterDelete k = M.alter (const Nothing) k `eq_` HM.alter (const Nothing) k----- We choose the list functor here because we don't fuss with--- it in alterF rules and because it has a sufficiently interesting--- structure to have a good chance of breaking if something is wrong.-pAlterF :: Key -> Fun (Maybe A) [Maybe A] -> [(Key, A)] -> Property-pAlterF k f xs =- fmap M.toAscList (M.alterF (apply f) k (M.fromList xs))- ===- fmap toAscList (HM.alterF (apply f) k (HM.fromList xs))--pAlterFAdjust :: Key -> [(Key, Int)] -> Bool-pAlterFAdjust k =- runIdentity . M.alterF (Identity . fmap succ) k `eq_`- runIdentity . HM.alterF (Identity . fmap succ) k--pAlterFInsert :: Key -> [(Key, Int)] -> Bool-pAlterFInsert k =- runIdentity . M.alterF (const . Identity . Just $ 3) k `eq_`- runIdentity . HM.alterF (const . Identity . Just $ 3) k--pAlterFInsertWith :: Key -> Fun Int Int -> [(Key, Int)] -> Bool-pAlterFInsertWith k f =- runIdentity . M.alterF (Identity . Just . maybe 3 (apply f)) k `eq_`- runIdentity . HM.alterF (Identity . Just . maybe 3 (apply f)) k--pAlterFDelete :: Key -> [(Key, Int)] -> Bool-pAlterFDelete k =- runIdentity . M.alterF (const (Identity Nothing)) k `eq_`- runIdentity . HM.alterF (const (Identity Nothing)) k--pAlterFLookup :: Key- -> Fun (Maybe A) B- -> [(Key, A)] -> Bool-pAlterFLookup k f =- getConst . M.alterF (Const . apply f :: Maybe A -> Const B (Maybe A)) k- `eq`- getConst . HM.alterF (Const . apply f) k--pSubmap :: [(Key, Int)] -> [(Key, Int)] -> Bool-pSubmap xs ys = M.isSubmapOf (M.fromList xs) (M.fromList ys) ==- HM.isSubmapOf (HM.fromList xs) (HM.fromList ys)--pSubmapReflexive :: HashMap Key Int -> Bool-pSubmapReflexive m = HM.isSubmapOf m m--pSubmapUnion :: HashMap Key Int -> HashMap Key Int -> Bool-pSubmapUnion m1 m2 = HM.isSubmapOf m1 (HM.union m1 m2)--pNotSubmapUnion :: HashMap Key Int -> HashMap Key Int -> Property-pNotSubmapUnion m1 m2 = not (HM.isSubmapOf m1 m2) ==> HM.isSubmapOf m1 (HM.union m1 m2)--pSubmapDifference :: HashMap Key Int -> HashMap Key Int -> Bool-pSubmapDifference m1 m2 = HM.isSubmapOf (HM.difference m1 m2) m1--pNotSubmapDifference :: HashMap Key Int -> HashMap Key Int -> Property-pNotSubmapDifference m1 m2 =- not (HM.null (HM.intersection m1 m2)) ==>- not (HM.isSubmapOf m1 (HM.difference m1 m2))--pSubmapDelete :: HashMap Key Int -> Property-pSubmapDelete m = not (HM.null m) ==>- forAll (elements (HM.keys m)) $ \k ->- HM.isSubmapOf (HM.delete k m) m--pNotSubmapDelete :: HashMap Key Int -> Property-pNotSubmapDelete m =- not (HM.null m) ==>- forAll (elements (HM.keys m)) $ \k ->- not (HM.isSubmapOf m (HM.delete k m))--pSubmapInsert :: Key -> Int -> HashMap Key Int -> Property-pSubmapInsert k v m = not (HM.member k m) ==> HM.isSubmapOf m (HM.insert k v m)--pNotSubmapInsert :: Key -> Int -> HashMap Key Int -> Property-pNotSubmapInsert k v m = not (HM.member k m) ==> not (HM.isSubmapOf (HM.insert k v m) m)----------------------------------------------------------------------------- ** Combine--pUnion :: [(Key, Int)] -> [(Key, Int)] -> Bool-pUnion xs ys = M.union (M.fromList xs) `eq_` HM.union (HM.fromList xs) $ ys--pUnionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool-pUnionWith xs ys = M.unionWith (-) (M.fromList xs) `eq_`- HM.unionWith (-) (HM.fromList xs) $ ys--pUnionWithKey :: [(Key, Int)] -> [(Key, Int)] -> Bool-pUnionWithKey xs ys = M.unionWithKey go (M.fromList xs) `eq_`- HM.unionWithKey go (HM.fromList xs) $ ys- where- go :: Key -> Int -> Int -> Int- go (K k) i1 i2 = k - i1 + i2--pUnions :: [[(Key, Int)]] -> Bool-pUnions xss = M.toAscList (M.unions (map M.fromList xss)) ==- toAscList (HM.unions (map HM.fromList xss))----------------------------------------------------------------------------- ** Transformations--pMap :: [(Key, Int)] -> Bool-pMap = M.map (+ 1) `eq_` HM.map (+ 1)--pTraverse :: [(Key, Int)] -> Bool-pTraverse xs =- List.sort (fmap (List.sort . M.toList) (M.traverseWithKey (\_ v -> [v + 1, v + 2]) (M.fromList (take 10 xs))))- == List.sort (fmap (List.sort . HM.toList) (HM.traverseWithKey (\_ v -> [v + 1, v + 2]) (HM.fromList (take 10 xs))))--pMapKeys :: [(Int, Int)] -> Bool-pMapKeys = M.mapKeys (+1) `eq_` HM.mapKeys (+1)----------------------------------------------------------------------------- ** Difference and intersection--pDifference :: [(Key, Int)] -> [(Key, Int)] -> Bool-pDifference xs ys = M.difference (M.fromList xs) `eq_`- HM.difference (HM.fromList xs) $ ys--pDifferenceWith :: [(Key, Int)] -> [(Key, Int)] -> Bool-pDifferenceWith xs ys = M.differenceWith f (M.fromList xs) `eq_`- HM.differenceWith f (HM.fromList xs) $ ys- where- f x y = if x == 0 then Nothing else Just (x - y)--pIntersection :: [(Key, Int)] -> [(Key, Int)] -> Bool-pIntersection xs ys = - M.intersection (M.fromList xs)- `eq_` HM.intersection (HM.fromList xs)- $ ys--pIntersectionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool-pIntersectionWith xs ys = M.intersectionWith (-) (M.fromList xs) `eq_`- HM.intersectionWith (-) (HM.fromList xs) $ ys--pIntersectionWithKey :: [(Key, Int)] -> [(Key, Int)] -> Bool-pIntersectionWithKey xs ys = M.intersectionWithKey go (M.fromList xs) `eq_`- HM.intersectionWithKey go (HM.fromList xs) $ ys- where- go :: Key -> Int -> Int -> Int- go (K k) i1 i2 = k - i1 - i2----------------------------------------------------------------------------- ** Folds--pFoldr :: [(Int, Int)] -> Bool-pFoldr = (List.sort . M.foldr (:) []) `eq` (List.sort . HM.foldr (:) [])--pFoldl :: [(Int, Int)] -> Bool-pFoldl = (List.sort . M.foldl (flip (:)) []) `eq` (List.sort . HM.foldl (flip (:)) [])--pBifoldMap :: [(Int, Int)] -> Bool-pBifoldMap xs = concatMap f (HM.toList m) == bifoldMap (:[]) (:[]) m- where f (k, v) = [k, v]- m = HM.fromList xs--pBifoldr :: [(Int, Int)] -> Bool-pBifoldr xs = concatMap f (HM.toList m) == bifoldr (:) (:) [] m- where f (k, v) = [k, v]- m = HM.fromList xs--pBifoldl :: [(Int, Int)] -> Bool-pBifoldl xs = reverse (concatMap f $ HM.toList m) == bifoldl (flip (:)) (flip (:)) [] m- where f (k, v) = [k, v]- m = HM.fromList xs--pFoldrWithKey :: [(Int, Int)] -> Bool-pFoldrWithKey = (sortByKey . M.foldrWithKey f []) `eq`- (sortByKey . HM.foldrWithKey f [])- where f k v z = (k, v) : z--pFoldMapWithKey :: [(Int, Int)] -> Bool-pFoldMapWithKey = (sortByKey . M.foldMapWithKey f) `eq`- (sortByKey . HM.foldMapWithKey f)- where f k v = [(k, v)]--pFoldrWithKey' :: [(Int, Int)] -> Bool-pFoldrWithKey' = (sortByKey . M.foldrWithKey' f []) `eq`- (sortByKey . HM.foldrWithKey' f [])- where f k v z = (k, v) : z--pFoldlWithKey :: [(Int, Int)] -> Bool-pFoldlWithKey = (sortByKey . M.foldlWithKey f []) `eq`- (sortByKey . HM.foldlWithKey f [])- where f z k v = (k, v) : z--pFoldlWithKey' :: [(Int, Int)] -> Bool-pFoldlWithKey' = (sortByKey . M.foldlWithKey' f []) `eq`- (sortByKey . HM.foldlWithKey' f [])- where f z k v = (k, v) : z--pFoldl' :: [(Int, Int)] -> Bool-pFoldl' = (List.sort . M.foldl' (flip (:)) []) `eq` (List.sort . HM.foldl' (flip (:)) [])--pFoldr' :: [(Int, Int)] -> Bool-pFoldr' = (List.sort . M.foldr' (:) []) `eq` (List.sort . HM.foldr' (:) [])+ arbitrary = HM.fromList <$> arbitrary+ shrink = fmap HM.fromList . shrink . HM.toList --------------------------------------------------------------------------- ** Filter--pMapMaybeWithKey :: [(Key, Int)] -> Bool-pMapMaybeWithKey = M.mapMaybeWithKey f `eq_` HM.mapMaybeWithKey f- where f k v = guard (odd (unK k + v)) >> Just (v + 1)+-- Helpers -pMapMaybe :: [(Key, Int)] -> Bool-pMapMaybe = M.mapMaybe f `eq_` HM.mapMaybe f- where f v = guard (odd v) >> Just (v + 1)+type HMK = HashMap Key+type HMKI = HMK Int -pFilter :: [(Key, Int)] -> Bool-pFilter = M.filter odd `eq_` HM.filter odd+sortByKey :: Ord k => [(k, v)] -> [(k, v)]+sortByKey = List.sortBy (compare `on` fst) -pFilterWithKey :: [(Key, Int)] -> Bool-pFilterWithKey = M.filterWithKey p `eq_` HM.filterWithKey p- where p k v = odd (unK k + v)+toOrdMap :: Ord k => HashMap k v -> M.Map k v+toOrdMap = M.fromList . HM.toList ---------------------------------------------------------------------------- ** Conversions+isValid :: (Eq k, Hashable k, Show k) => HashMap k v -> Property+isValid m = valid m === Valid -- The free magma is used to test that operations are applied in the -- same order.@@ -421,32 +76,8 @@ hashWithSalt s (Leaf a) = hashWithSalt s (hashWithSalt (1::Int) a) hashWithSalt s (Op m n) = hashWithSalt s (hashWithSalt (hashWithSalt (2::Int) m) n) --- 'eq_' already calls fromList.-pFromList :: [(Key, Int)] -> Bool-pFromList = id `eq_` id--pFromListWith :: [(Key, Int)] -> Bool-pFromListWith kvs = (M.toAscList $ M.fromListWith Op kvsM) ==- (toAscList $ HM.fromListWith Op kvsM)- where kvsM = fmap (fmap Leaf) kvs--pFromListWithKey :: [(Key, Int)] -> Bool-pFromListWithKey kvs = (M.toAscList $ M.fromListWithKey combine kvsM) ==- (toAscList $ HM.fromListWithKey combine kvsM)- where kvsM = fmap (\(K k,v) -> (Leaf k, Leaf v)) kvs- combine k v1 v2 = Op k (Op v1 v2)--pToList :: [(Key, Int)] -> Bool-pToList = M.toAscList `eq` toAscList--pElems :: [(Key, Int)] -> Bool-pElems = (List.sort . M.elems) `eq` (List.sort . HM.elems)--pKeys :: [(Key, Int)] -> Bool-pKeys = (List.sort . M.keys) `eq` (List.sort . HM.keys)- --------------------------------------------------------------------------- * Test list+-- Test list tests :: TestTree tests =@@ -459,135 +90,383 @@ [ -- Instances testGroup "instances"- [ testProperty "==" pEq- , testProperty "/=" pNeq- , testProperty "compare reflexive" pOrd1- , testProperty "compare transitive" pOrd2- , testProperty "compare antisymmetric" pOrd3- , testProperty "Ord => Eq" pOrdEq- , testProperty "Read/Show" pReadShow- , testProperty "Functor" pFunctor- , testProperty "Foldable" pFoldable- , testProperty "Hashable" pHashable+ [ testGroup "Eq"+ [ testProperty "==" $+ \(x :: HMKI) y -> (x == y) === (toOrdMap x == toOrdMap y)+ , testProperty "/=" $+ \(x :: HMKI) y -> (x == y) === (toOrdMap x == toOrdMap y)+ ]+ , testGroup "Ord"+ [ testProperty "compare reflexive" $+ \(m :: HMKI) -> compare m m === EQ+ , testProperty "compare transitive" $+ \(x :: HMKI) y z -> case (compare x y, compare y z) of+ (EQ, o) -> compare x z === o+ (o, EQ) -> compare x z === o+ (LT, LT) -> compare x z === LT+ (GT, GT) -> compare x z === GT+ (LT, GT) -> QC.property True -- ys greater than xs and zs.+ (GT, LT) -> QC.property True+ , testProperty "compare antisymmetric" $+ \(x :: HMKI) y -> case (compare x y, compare y x) of+ (EQ, EQ) -> True+ (LT, GT) -> True+ (GT, LT) -> True+ _ -> False+ , testProperty "Ord => Eq" $+ \(x :: HMKI) y -> case (compare x y, x == y) of+ (EQ, True) -> True+ (LT, False) -> True+ (GT, False) -> True+ _ -> False+ ]+ , testProperty "Read/Show" $+ \(x :: HMKI) -> x === read (show x)+ , testProperty "Functor" $+ \(x :: HMKI) (Fn f :: Fun Int Int) ->+ toOrdMap (fmap f x) === fmap f (toOrdMap x)+ , testProperty "Foldable" $+ \(x :: HMKI) ->+ let f = List.sort . Foldable.foldr (:) []+ in f x === f (toOrdMap x)+ , testGroup "Bifoldable"+ [ testProperty "bifoldMap" $+ \(m :: HMK Key) ->+ bifoldMap (:[]) (:[]) m === concatMap (\(k, v) -> [k, v]) (HM.toList m)+ , testProperty "bifoldr" $+ \(m :: HMK Key) ->+ bifoldr (:) (:) [] m === concatMap (\(k, v) -> [k, v]) (HM.toList m)+ , testProperty "bifoldl" $+ \(m :: HMK Key) ->+ bifoldl (flip (:)) (flip (:)) [] m+ ===+ reverse (concatMap (\(k, v) -> [k, v]) (HM.toList m))+ ]+ , testProperty "Hashable" $+ \(xs :: [(Key, Int)]) is salt ->+ let xs' = List.nubBy (\(k,_) (k',_) -> k == k') xs+ -- Shuffle the list using indexes in the second+ shuffle :: [Int] -> [a] -> [a]+ shuffle idxs = List.map snd+ . List.sortBy (comparing fst)+ . List.zip (idxs ++ [List.maximum (0:is) + 1 ..])+ ys = shuffle is xs'+ x = HM.fromList xs'+ y = HM.fromList ys+ in x == y ==> hashWithSalt salt x === hashWithSalt salt y ]+ -- Construction+ , testGroup "empty"+ [ testProperty "valid" $ QC.once $+ isValid (HM.empty :: HMKI)+ ]+ , testGroup "singleton"+ [ testProperty "valid" $+ \(k :: Key) (v :: A) -> isValid (HM.singleton k v)+ ] -- Basic interface- , testGroup "basic interface"- [ testProperty "size" pSize- , testProperty "member" pMember- , testProperty "lookup" pLookup- , testProperty "!?" pLookupOperator- , testProperty "insert" pInsert- , testProperty "delete" pDelete- , testProperty "deleteCollision" pDeleteCollision- , testProperty "insertWith" pInsertWith- , testProperty "adjust" pAdjust- , testProperty "updateAdjust" pUpdateAdjust- , testProperty "updateDelete" pUpdateDelete- , testProperty "alterAdjust" pAlterAdjust- , testProperty "alterInsert" pAlterInsert- , testProperty "alterDelete" pAlterDelete- , testProperty "alterF" pAlterF- , testProperty "alterFAdjust" pAlterFAdjust- , testProperty "alterFInsert" pAlterFInsert- , testProperty "alterFInsertWith" pAlterFInsertWith- , testProperty "alterFDelete" pAlterFDelete- , testProperty "alterFLookup" pAlterFLookup- , testGroup "isSubmapOf"- [ testProperty "container compatibility" pSubmap- , testProperty "m ⊆ m" pSubmapReflexive- , testProperty "m1 ⊆ m1 ∪ m2" pSubmapUnion- , testProperty "m1 ⊈ m2 ⇒ m1 ∪ m2 ⊈ m1" pNotSubmapUnion- , testProperty "m1\\m2 ⊆ m1" pSubmapDifference- , testProperty "m1 ∩ m2 ≠ ∅ ⇒ m1 ⊈ m1\\m2 " pNotSubmapDifference- , testProperty "delete k m ⊆ m" pSubmapDelete- , testProperty "m ⊈ delete k m " pNotSubmapDelete- , testProperty "k ∉ m ⇒ m ⊆ insert k v m" pSubmapInsert- , testProperty "k ∉ m ⇒ insert k v m ⊈ m" pNotSubmapInsert+ , testProperty "size" $+ \(x :: HMKI) -> HM.size x === M.size (toOrdMap x)+ , testProperty "member" $+ \(k :: Key) (m :: HMKI) -> HM.member k m === M.member k (toOrdMap m)+ , testProperty "lookup" $+ \(k :: Key) (m :: HMKI) -> HM.lookup k m === M.lookup k (toOrdMap m)+ , testProperty "!?" $+ \(k :: Key) (m :: HMKI) -> m HM.!? k === M.lookup k (toOrdMap m)+ , testGroup "insert"+ [ testProperty "model" $+ \(k :: Key) (v :: Int) x ->+ let y = HM.insert k v x+ in toOrdMap y === M.insert k v (toOrdMap x)+ , testProperty "valid" $+ \(k :: Key) (v :: Int) x -> isValid (HM.insert k v x)+ ]+ , testGroup "insertWith"+ [ testProperty "insertWith" $+ \(Fn2 f) k v (x :: HMKI) ->+ toOrdMap (HM.insertWith f k v x) === M.insertWith f k v (toOrdMap x)+ , testProperty "valid" $+ \(Fn2 f) k v (x :: HMKI) -> isValid (HM.insertWith f k v x)+ ]+ , testGroup "delete"+ [ testProperty "model" $+ \(k :: Key) (x :: HMKI) ->+ let y = HM.delete k x+ in toOrdMap y === M.delete k (toOrdMap x)+ , testProperty "valid" $+ \(k :: Key) (x :: HMKI) -> isValid (HM.delete k x)+ ]+ , testGroup "adjust" + [ testProperty "model" $+ \(Fn f) k (x :: HMKI) ->+ toOrdMap (HM.adjust f k x) === M.adjust f k (toOrdMap x)+ , testProperty "valid" $+ \(Fn f) k (x :: HMKI) -> isValid (HM.adjust f k x)+ ]+ , testGroup "update" + [ testProperty "model" $+ \(Fn f) k (x :: HMKI) ->+ toOrdMap (HM.update f k x) === M.update f k (toOrdMap x)+ , testProperty "valid" $+ \(Fn f) k (x :: HMKI) -> isValid (HM.update f k x)+ ]+ , testGroup "alter"+ [ testProperty "model" $+ \(Fn f) k (x :: HMKI) ->+ toOrdMap (HM.alter f k x) === M.alter f k (toOrdMap x)+ , testProperty "valid" $+ \(Fn f) k (x :: HMKI) -> isValid (HM.alter f k x)+ ]+ , testGroup "alterF"+ [ testGroup "model"+ [ -- We choose the list functor here because we don't fuss with+ -- it in alterF rules and because it has a sufficiently interesting+ -- structure to have a good chance of breaking if something is wrong.+ testProperty "[]" $+ \(Fn f :: Fun (Maybe A) [Maybe A]) k (x :: HMK A) ->+ map toOrdMap (HM.alterF f k x) === M.alterF f k (toOrdMap x)+ , testProperty "adjust" $+ \(Fn f) k (x :: HMKI) ->+ let g = Identity . fmap f+ in fmap toOrdMap (HM.alterF g k x) === M.alterF g k (toOrdMap x)+ , testProperty "insert" $+ \v k (x :: HMKI) ->+ let g = const . Identity . Just $ v+ in fmap toOrdMap (HM.alterF g k x) === M.alterF g k (toOrdMap x)+ , testProperty "insertWith" $+ \(Fn f) k v (x :: HMKI) ->+ let g = Identity . Just . maybe v f+ in fmap toOrdMap (HM.alterF g k x) === M.alterF g k (toOrdMap x)+ , testProperty "delete" $+ \k (x :: HMKI) ->+ let f = const (Identity Nothing)+ in fmap toOrdMap (HM.alterF f k x) === M.alterF f k (toOrdMap x)+ , testProperty "lookup" $+ \(Fn f :: Fun (Maybe A) B) k (x :: HMK A) ->+ let g = Const . f+ in fmap toOrdMap (HM.alterF g k x) === M.alterF g k (toOrdMap x) ]+ , testProperty "valid" $+ \(Fn f :: Fun (Maybe A) [Maybe A]) k (x :: HMK A) ->+ let ys = HM.alterF f k x+ in map valid ys === (Valid <$ ys) ]+ , testGroup "isSubmapOf"+ [ testProperty "model" $+ \(x :: HMKI) y -> HM.isSubmapOf x y === M.isSubmapOf (toOrdMap x) (toOrdMap y)+ , testProperty "m ⊆ m" $+ \(x :: HMKI) -> HM.isSubmapOf x x+ , testProperty "m1 ⊆ m1 ∪ m2" $+ \(x :: HMKI) y -> HM.isSubmapOf x (HM.union x y)+ , testProperty "m1 ⊈ m2 ⇒ m1 ∪ m2 ⊈ m1" $+ \(m1 :: HMKI) m2 -> not (HM.isSubmapOf m1 m2) ==> HM.isSubmapOf m1 (HM.union m1 m2)+ , testProperty "m1\\m2 ⊆ m1" $+ \(m1 :: HMKI) (m2 :: HMKI) -> HM.isSubmapOf (HM.difference m1 m2) m1+ , testProperty "m1 ∩ m2 ≠ ∅ ⇒ m1 ⊈ m1\\m2 " $+ \(m1 :: HMKI) (m2 :: HMKI) ->+ not (HM.null (HM.intersection m1 m2)) ==>+ not (HM.isSubmapOf m1 (HM.difference m1 m2))+ , testProperty "delete k m ⊆ m" $+ \(m :: HMKI) ->+ not (HM.null m) ==>+ QC.forAll (QC.elements (HM.keys m)) $ \k ->+ HM.isSubmapOf (HM.delete k m) m+ , testProperty "m ⊈ delete k m " $+ \(m :: HMKI) ->+ not (HM.null m) ==>+ QC.forAll (QC.elements (HM.keys m)) $ \k ->+ not (HM.isSubmapOf m (HM.delete k m))+ , testProperty "k ∉ m ⇒ m ⊆ insert k v m" $+ \k v (m :: HMKI) -> not (HM.member k m) ==> HM.isSubmapOf m (HM.insert k v m)+ , testProperty "k ∉ m ⇒ insert k v m ⊈ m" $+ \k v (m :: HMKI) -> not (HM.member k m) ==> not (HM.isSubmapOf (HM.insert k v m) m)+ ] -- Combine- , testProperty "union" pUnion- , testProperty "unionWith" pUnionWith- , testProperty "unionWithKey" pUnionWithKey- , testProperty "unions" pUnions+ , testGroup "union"+ [ testProperty "model" $+ \(x :: HMKI) y ->+ let z = HM.union x y+ in toOrdMap z === M.union (toOrdMap x) (toOrdMap y)+ , testProperty "valid" $+ \(x :: HMKI) y -> isValid (HM.union x y)+ ]+ , testGroup "unionWith"+ [ testProperty "model" $+ \(Fn2 f) (x :: HMKI) y ->+ toOrdMap (HM.unionWith f x y) === M.unionWith f (toOrdMap x) (toOrdMap y)+ , testProperty "valid" $+ \(Fn2 f) (x :: HMKI) y -> isValid (HM.unionWith f x y)+ ]+ , testGroup "unionWithKey"+ [ testProperty "model" $+ \(Fn3 f) (x :: HMKI) y ->+ toOrdMap (HM.unionWithKey f x y) === M.unionWithKey f (toOrdMap x) (toOrdMap y)+ , testProperty "valid" $+ \(Fn3 f) (x :: HMKI) y -> isValid (HM.unionWithKey f x y)+ ]+ , testGroup "unions"+ [ testProperty "model" $+ \(ms :: [HMKI]) -> toOrdMap (HM.unions ms) === M.unions (map toOrdMap ms)+ , testProperty "valid" $+ \(ms :: [HMKI]) -> isValid (HM.unions ms)+ ]+ , testGroup "difference"+ [ testProperty "model" $+ \(x :: HMKI) (y :: HMKI) ->+ toOrdMap (HM.difference x y) === M.difference (toOrdMap x) (toOrdMap y)+ , testProperty "valid" $+ \(x :: HMKI) (y :: HMKI) -> isValid (HM.difference x y)+ ]+ , testGroup "differenceWith"+ [ testProperty "model" $+ \(Fn2 f) (x :: HMK A) (y :: HMK B) ->+ toOrdMap (HM.differenceWith f x y) === M.differenceWith f (toOrdMap x) (toOrdMap y)+ , testProperty "valid" $+ \(Fn2 f) (x :: HMK A) (y :: HMK B) -> isValid (HM.differenceWith f x y)+ ]+ , testGroup "intersection"+ [ testProperty "model" $+ \(x :: HMKI) (y :: HMKI) ->+ toOrdMap (HM.intersection x y) === M.intersection (toOrdMap x) (toOrdMap y)+ , testProperty "valid" $+ \(x :: HMKI) (y :: HMKI) ->+ isValid (HM.intersection x y)+ ]+ , testGroup "intersectionWith"+ [ testProperty "model" $+ \(Fn2 f :: Fun (A, B) C) (x :: HMK A) (y :: HMK B) ->+ toOrdMap (HM.intersectionWith f x y) === M.intersectionWith f (toOrdMap x) (toOrdMap y)+ , testProperty "valid" $+ \(Fn2 f :: Fun (A, B) C) (x :: HMK A) (y :: HMK B) ->+ isValid (HM.intersectionWith f x y)+ ]+ , testGroup "intersectionWithKey"+ [ testProperty "model" $+ \(Fn3 f :: Fun (Key, A, B) C) (x :: HMK A) (y :: HMK B) ->+ toOrdMap (HM.intersectionWithKey f x y)+ ===+ M.intersectionWithKey f (toOrdMap x) (toOrdMap y)+ , testProperty "valid" $+ \(Fn3 f :: Fun (Key, A, B) C) (x :: HMK A) (y :: HMK B) ->+ isValid (HM.intersectionWithKey f x y)+ ]+ , testGroup "compose"+ [ testProperty "valid" $+ \(x :: HMK Int) (y :: HMK Key) -> isValid (HM.compose x y)+ ] -- Transformations- , testProperty "map" pMap- , testProperty "traverse" pTraverse- , testProperty "mapKeys" pMapKeys- -- Folds- , testGroup "folds"- [ testProperty "foldr" pFoldr- , testProperty "foldl" pFoldl- , testProperty "bifoldMap" pBifoldMap- , testProperty "bifoldr" pBifoldr- , testProperty "bifoldl" pBifoldl- , testProperty "foldrWithKey" pFoldrWithKey- , testProperty "foldlWithKey" pFoldlWithKey- , testProperty "foldrWithKey'" pFoldrWithKey'- , testProperty "foldlWithKey'" pFoldlWithKey'- , testProperty "foldl'" pFoldl'- , testProperty "foldr'" pFoldr'- , testProperty "foldMapWithKey" pFoldMapWithKey+ , testGroup "map"+ [ testProperty "model" $+ \(Fn f :: Fun A B) (m :: HMK A) -> toOrdMap (HM.map f m) === M.map f (toOrdMap m)+ , testProperty "valid" $+ \(Fn f :: Fun A B) (m :: HMK A) -> isValid (HM.map f m) ]- , testGroup "difference and intersection"- [ testProperty "difference" pDifference- , testProperty "differenceWith" pDifferenceWith- , testProperty "intersection" pIntersection- , testProperty "intersectionWith" pIntersectionWith- , testProperty "intersectionWithKey" pIntersectionWithKey+ , testGroup "traverseWithKey"+ [ testProperty "model" $ QC.mapSize (\s -> s `div` 8) $+ \(x :: HMKI) ->+ let f k v = [keyToInt k + v + 1, keyToInt k + v + 2]+ ys = HM.traverseWithKey f x+ in List.sort (fmap toOrdMap ys) === List.sort (M.traverseWithKey f (toOrdMap x))+ , testProperty "valid" $ QC.mapSize (\s -> s `div` 8) $+ \(x :: HMKI) ->+ let f k v = [keyToInt k + v + 1, keyToInt k + v + 2]+ ys = HM.traverseWithKey f x+ in fmap valid ys === (Valid <$ ys) ]+ , testGroup "mapKeys"+ [ testProperty "model" $+ \(m :: HMKI) -> toOrdMap (HM.mapKeys incKey m) === M.mapKeys incKey (toOrdMap m)+ , testProperty "valid" $+ \(Fn f :: Fun Key Key) (m :: HMKI) -> isValid (HM.mapKeys f m)+ ]+ -- Folds+ , testProperty "foldr" $+ \(m :: HMKI) -> List.sort (HM.foldr (:) [] m) === List.sort (M.foldr (:) [] (toOrdMap m))+ , testProperty "foldl" $+ \(m :: HMKI) ->+ List.sort (HM.foldl (flip (:)) [] m) === List.sort (M.foldl (flip (:)) [] (toOrdMap m))+ , testProperty "foldrWithKey" $+ \(m :: HMKI) ->+ let f k v z = (k, v) : z+ in sortByKey (HM.foldrWithKey f [] m) === sortByKey (M.foldrWithKey f [] (toOrdMap m))+ , testProperty "foldlWithKey" $+ \(m :: HMKI) ->+ let f z k v = (k, v) : z+ in sortByKey (HM.foldlWithKey f [] m) === sortByKey (M.foldlWithKey f [] (toOrdMap m))+ , testProperty "foldrWithKey'" $+ \(m :: HMKI) ->+ let f k v z = (k, v) : z+ in sortByKey (HM.foldrWithKey' f [] m) === sortByKey (M.foldrWithKey' f [] (toOrdMap m))+ , testProperty "foldlWithKey'" $+ \(m :: HMKI) ->+ let f z k v = (k, v) : z+ in sortByKey (HM.foldlWithKey' f [] m) === sortByKey (M.foldlWithKey' f [] (toOrdMap m))+ , testProperty "foldl'" $+ \(m :: HMKI) ->+ List.sort (HM.foldl' (flip (:)) [] m) === List.sort (M.foldl' (flip (:)) [] (toOrdMap m))+ , testProperty "foldr'" $+ \(m :: HMKI) -> List.sort (HM.foldr' (:) [] m) === List.sort (M.foldr' (:) [] (toOrdMap m))+ , testProperty "foldMapWithKey" $+ \(m :: HMKI) ->+ let f k v = [(k, v)]+ in sortByKey (HM.foldMapWithKey f m) === sortByKey (M.foldMapWithKey f (toOrdMap m)) -- Filter , testGroup "filter"- [ testProperty "filter" pFilter- , testProperty "filterWithKey" pFilterWithKey- , testProperty "mapMaybe" pMapMaybe- , testProperty "mapMaybeWithKey" pMapMaybeWithKey+ [ testProperty "model" $+ \(Fn p) (m :: HMKI) -> toOrdMap (HM.filter p m) === M.filter p (toOrdMap m)+ , testProperty "valid" $+ \(Fn p) (m :: HMKI) -> isValid (HM.filter p m) ]+ , testGroup "filterWithKey"+ [ testProperty "model" $+ \(Fn2 p) (m :: HMKI) ->+ toOrdMap (HM.filterWithKey p m) === M.filterWithKey p (toOrdMap m)+ , testProperty "valid" $+ \(Fn2 p) (m :: HMKI) -> isValid (HM.filterWithKey p m)+ ]+ , testGroup "mapMaybe"+ [ testProperty "model" $+ \(Fn f :: Fun A (Maybe B)) (m :: HMK A) ->+ toOrdMap (HM.mapMaybe f m) === M.mapMaybe f (toOrdMap m)+ , testProperty "valid" $+ \(Fn f :: Fun A (Maybe B)) (m :: HMK A) -> isValid (HM.mapMaybe f m)+ ]+ , testGroup "mapMaybeWithKey"+ [ testProperty "model" $+ \(Fn2 f :: Fun (Key, A) (Maybe B)) (m :: HMK A) ->+ toOrdMap (HM.mapMaybeWithKey f m) === M.mapMaybeWithKey f (toOrdMap m)+ , testProperty "valid" $+ \(Fn2 f :: Fun (Key, A) (Maybe B)) (m :: HMK A) ->+ isValid (HM.mapMaybeWithKey f m)+ ] -- Conversions- , testGroup "conversions"- [ testProperty "elems" pElems- , testProperty "keys" pKeys- , testProperty "fromList" pFromList- , testProperty "fromListWith" pFromListWith- , testProperty "fromListWithKey" pFromListWithKey- , testProperty "toList" pToList+ , testProperty "elems" $+ \(m :: HMKI) -> List.sort (HM.elems m) === List.sort (M.elems (toOrdMap m))+ , testProperty "keys" $+ \(m :: HMKI) -> List.sort (HM.keys m) === List.sort (M.keys (toOrdMap m))+ , testGroup "fromList"+ [ testProperty "model" $+ \(kvs :: [(Key, Int)]) -> toOrdMap (HM.fromList kvs) === M.fromList kvs+ , testProperty "valid" $+ \(kvs :: [(Key, Int)]) -> isValid (HM.fromList kvs) ]+ , testGroup "fromListWith"+ [ testProperty "model" $+ \(kvs :: [(Key, Int)]) ->+ let kvsM = map (fmap Leaf) kvs+ in toOrdMap (HM.fromListWith Op kvsM) === M.fromListWith Op kvsM+ , testProperty "valid" $+ \(Fn2 f) (kvs :: [(Key, A)]) -> isValid (HM.fromListWith f kvs)+ ]+ , testGroup "fromListWithKey"+ [ testProperty "model" $+ \(kvs :: [(Key, Int)]) ->+ let kvsM = fmap (\(k,v) -> (Leaf (keyToInt k), Leaf v)) kvs+ combine k v1 v2 = Op k (Op v1 v2)+ in toOrdMap (HM.fromListWithKey combine kvsM) === M.fromListWithKey combine kvsM+ , testProperty "valid" $+ \(Fn3 f) (kvs :: [(Key, A)]) -> isValid (HM.fromListWithKey f kvs)+ ]+ , testProperty "toList" $+ \(m :: HMKI) -> List.sort (HM.toList m) === List.sort (M.toList (toOrdMap m)) ]----------------------------------------------------------------------------- * Model--type Model k v = M.Map k v---- | Check that a function operating on a 'HashMap' is equivalent to--- one operating on a 'Model'.-eq :: (Eq a, Eq k, Hashable k, Ord k)- => (Model k v -> a) -- ^ Function that modifies a 'Model'- -> (HM.HashMap k v -> a) -- ^ Function that modified a 'HashMap' in the same- -- way- -> [(k, v)] -- ^ Initial content of the 'HashMap' and 'Model'- -> Bool -- ^ True if the functions are equivalent-eq f g xs = g (HM.fromList xs) == f (M.fromList xs)--infix 4 `eq`--eq_ :: (Eq k, Eq v, Hashable k, Ord k)- => (Model k v -> Model k v) -- ^ Function that modifies a 'Model'- -> (HM.HashMap k v -> HM.HashMap k v) -- ^ Function that modified a- -- 'HashMap' in the same way- -> [(k, v)] -- ^ Initial content of the 'HashMap'- -- and 'Model'- -> Bool -- ^ True if the functions are- -- equivalent-eq_ f g = (M.toAscList . f) `eq` (toAscList . g)--infix 4 `eq_`----------------------------------------------------------------------------- * Helpers--sortByKey :: Ord k => [(k, v)] -> [(k, v)]-sortByKey = List.sortBy (compare `on` fst)--toAscList :: Ord k => HM.HashMap k v -> [(k, v)]-toAscList = List.sortBy (compare `on` fst) . HM.toList
tests/Properties/HashSet.hs view
@@ -1,236 +1,138 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- because of the Arbitrary instances+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- https://github.com/nick8325/quickcheck/issues/344+ -- | Tests for the 'Data.HashSet' module. We test functions by--- comparing them to @Set@ from @containers@.+-- comparing them to @Set@ from @containers@. @Set@ is referred to as a+-- /model/ for @HashSet@. module Properties.HashSet (tests) where import Data.Hashable (Hashable (hashWithSalt))+import Data.HashMap.Lazy (HashMap)+import Data.HashSet (HashSet) import Data.Ord (comparing)-import Test.QuickCheck (Arbitrary, Property, (===), (==>))+import Data.Set (Set)+import Test.QuickCheck (Fun, pattern Fn, (===), (==>)) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.QuickCheck (testProperty)--import qualified Data.Foldable as Foldable-import qualified Data.HashSet as S-import qualified Data.List as List-import qualified Data.Set as Set---- Key type that generates more hash collisions.-newtype Key = K { unK :: Int }- deriving (Arbitrary, Enum, Eq, Integral, Num, Ord, Read, Show, Real)--instance Hashable Key where- hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20----------------------------------------------------------------------------- * Properties----------------------------------------------------------------------------- ** Instances--pEq :: [Key] -> [Key] -> Bool-pEq xs = (Set.fromList xs ==) `eq` (S.fromList xs ==)--pNeq :: [Key] -> [Key] -> Bool-pNeq xs = (Set.fromList xs /=) `eq` (S.fromList xs /=)---- We cannot compare to `Data.Map` as ordering is different.-pOrd1 :: [Key] -> Bool-pOrd1 xs = compare x x == EQ- where- x = S.fromList xs--pOrd2 :: [Key] -> [Key] -> [Key] -> Bool-pOrd2 xs ys zs = case (compare x y, compare y z) of- (EQ, o) -> compare x z == o- (o, EQ) -> compare x z == o- (LT, LT) -> compare x z == LT- (GT, GT) -> compare x z == GT- (LT, GT) -> True -- ys greater than xs and zs.- (GT, LT) -> True- where- x = S.fromList xs- y = S.fromList ys- z = S.fromList zs--pOrd3 :: [Key] -> [Key] -> Bool-pOrd3 xs ys = case (compare x y, compare y x) of- (EQ, EQ) -> True- (LT, GT) -> True- (GT, LT) -> True- _ -> False- where- x = S.fromList xs- y = S.fromList ys--pOrdEq :: [Key] -> [Key] -> Bool-pOrdEq xs ys = case (compare x y, x == y) of- (EQ, True) -> True- (LT, False) -> True- (GT, False) -> True- _ -> False- where- x = S.fromList xs- y = S.fromList ys--pReadShow :: [Key] -> Bool-pReadShow xs = Set.fromList xs == read (show (Set.fromList xs))--pFoldable :: [Int] -> Bool-pFoldable = (List.sort . Foldable.foldr (:) []) `eq`- (List.sort . Foldable.foldr (:) [])--pPermutationEq :: [Key] -> [Int] -> Bool-pPermutationEq xs is = S.fromList xs == S.fromList ys- where- ys = shuffle is xs- shuffle idxs = List.map snd- . List.sortBy (comparing fst)- . List.zip (idxs ++ [List.maximum (0:is) + 1 ..])--pHashable :: [Key] -> [Int] -> Int -> Property-pHashable xs is salt =- x == y ==> hashWithSalt salt x === hashWithSalt salt y- where- xs' = List.nub xs- ys = shuffle is xs'- x = S.fromList xs'- y = S.fromList ys- shuffle idxs = List.map snd- . List.sortBy (comparing fst)- . List.zip (idxs ++ [List.maximum (0:is) + 1 ..])----------------------------------------------------------------------------- ** Basic interface--pSize :: [Key] -> Bool-pSize = Set.size `eq` S.size--pMember :: Key -> [Key] -> Bool-pMember k = Set.member k `eq` S.member k--pInsert :: Key -> [Key] -> Bool-pInsert a = Set.insert a `eq_` S.insert a--pDelete :: Key -> [Key] -> Bool-pDelete a = Set.delete a `eq_` S.delete a----------------------------------------------------------------------------- ** Combine--pUnion :: [Key] -> [Key] -> Bool-pUnion xs ys = Set.union (Set.fromList xs) `eq_`- S.union (S.fromList xs) $ ys----------------------------------------------------------------------------- ** Transformations--pMap :: [Key] -> Bool-pMap = Set.map (+ 1) `eq_` S.map (+ 1)----------------------------------------------------------------------------- ** Folds--pFoldr :: [Int] -> Bool-pFoldr = (List.sort . foldrSet (:) []) `eq`- (List.sort . S.foldr (:) [])+import Test.Tasty.QuickCheck (Arbitrary (..), testProperty)+import Util.Key (Key, keyToInt) -foldrSet :: (a -> b -> b) -> b -> Set.Set a -> b-foldrSet = Set.foldr+import qualified Data.Foldable as Foldable+import qualified Data.HashMap.Lazy as HM+import qualified Data.HashSet as HS+import qualified Data.List as List+import qualified Data.Set as S+import qualified Test.QuickCheck as QC -pFoldl' :: Int -> [Int] -> Bool-pFoldl' z0 = foldl'Set (+) z0 `eq` S.foldl' (+) z0+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where+ arbitrary = HM.fromList <$> arbitrary+ shrink = fmap HM.fromList . shrink . HM.toList -foldl'Set :: (a -> b -> a) -> a -> Set.Set b -> a-foldl'Set = Set.foldl'+instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where+ arbitrary = HS.fromMap <$> arbitrary+ shrink = fmap HS.fromMap . shrink . HS.toMap --------------------------------------------------------------------------- ** Filter--pFilter :: [Key] -> Bool-pFilter = Set.filter odd `eq_` S.filter odd+-- Helpers ---------------------------------------------------------------------------- ** Conversions+type HSK = HashSet Key -pToList :: [Key] -> Bool-pToList = Set.toAscList `eq` toAscList+toOrdSet :: Ord a => HashSet a -> Set a+toOrdSet = S.fromList . HS.toList --------------------------------------------------------------------------- * Test list+-- Test list tests :: TestTree tests = testGroup "Data.HashSet"- [- -- Instances- testGroup "instances"- [ testProperty "==" pEq- , testProperty "Permutation ==" pPermutationEq- , testProperty "/=" pNeq- , testProperty "compare reflexive" pOrd1- , testProperty "compare transitive" pOrd2- , testProperty "compare antisymmetric" pOrd3- , testProperty "Ord => Eq" pOrdEq- , testProperty "Read/Show" pReadShow- , testProperty "Foldable" pFoldable- , testProperty "Hashable" pHashable- ]- -- Basic interface- , testGroup "basic interface"- [ testProperty "size" pSize- , testProperty "member" pMember- , testProperty "insert" pInsert- , testProperty "delete" pDelete- ]- -- Combine- , testProperty "union" pUnion- -- Transformations- , testProperty "map" pMap- -- Folds- , testGroup "folds"- [ testProperty "foldr" pFoldr- , testProperty "foldl'" pFoldl'- ]- -- Filter- , testGroup "filter"- [ testProperty "filter" pFilter+ [ -- Instances+ testGroup "instances"+ [ testGroup "Eq"+ [ testProperty "==" $+ \(x :: HSK) y -> (x == y) === (toOrdSet x == toOrdSet y)+ , testProperty "== permutations" $+ \(xs :: [Key]) (is :: [Int]) ->+ let shuffle idxs = List.map snd+ . List.sortBy (comparing fst)+ . List.zip (idxs ++ [List.maximum (0:is) + 1 ..])+ ys = shuffle is xs+ in HS.fromList xs === HS.fromList ys+ , testProperty "/=" $+ \(x :: HSK) y -> (x /= y) === (toOrdSet x /= toOrdSet y) ]- -- Conversions- , testGroup "conversions"- [ testProperty "toList" pToList+ , testGroup "Ord"+ [ testProperty "compare reflexive" $+ -- We cannot compare to `Data.Map` as ordering is different.+ \(x :: HSK) -> compare x x === EQ+ , testProperty "compare transitive" $+ \(x :: HSK) y z -> case (compare x y, compare y z) of+ (EQ, o) -> compare x z === o+ (o, EQ) -> compare x z === o+ (LT, LT) -> compare x z === LT+ (GT, GT) -> compare x z === GT+ (LT, GT) -> QC.property True -- ys greater than xs and zs.+ (GT, LT) -> QC.property True+ , testProperty "compare antisymmetric" $+ \(x :: HSK) y -> case (compare x y, compare y x) of+ (EQ, EQ) -> True+ (LT, GT) -> True+ (GT, LT) -> True+ _ -> False+ , testProperty "Ord => Eq" $+ \(x :: HSK) y -> case (compare x y, x == y) of+ (EQ, True) -> True+ (LT, False) -> True+ (GT, False) -> True+ _ -> False ]+ , testProperty "Read/Show" $+ \(x :: HSK) -> x === read (show x)+ , testProperty "Foldable" $+ \(x :: HSK) ->+ List.sort (Foldable.foldr (:) [] x)+ ===+ List.sort (Foldable.foldr (:) [] (toOrdSet x))+ , testProperty "Hashable" $+ \(xs :: [Key]) (is :: [Int]) salt ->+ let shuffle idxs = List.map snd+ . List.sortBy (comparing fst)+ . List.zip (idxs ++ [List.maximum (0:is) + 1 ..])+ xs' = List.nub xs+ ys = shuffle is xs'+ x = HS.fromList xs'+ y = HS.fromList ys+ in x == y ==> hashWithSalt salt x === hashWithSalt salt y ]----------------------------------------------------------------------------- * Model---- Invariant: the list is sorted in ascending order, by key.-type Model a = Set.Set a---- | Check that a function operating on a 'HashMap' is equivalent to--- one operating on a 'Model'.-eq :: (Eq a, Hashable a, Ord a, Eq b)- => (Model a -> b) -- ^ Function that modifies a 'Model' in the same- -- way- -> (S.HashSet a -> b) -- ^ Function that modified a 'HashSet'- -> [a] -- ^ Initial content of the 'HashSet' and 'Model'- -> Bool -- ^ True if the functions are equivalent-eq f g xs = g (S.fromList xs) == f (Set.fromList xs)--eq_ :: (Eq a, Hashable a, Ord a)- => (Model a -> Model a) -- ^ Function that modifies a 'Model'- -> (S.HashSet a -> S.HashSet a) -- ^ Function that modified a- -- 'HashSet' in the same way- -> [a] -- ^ Initial content of the 'HashSet'- -- and 'Model'- -> Bool -- ^ True if the functions are- -- equivalent-eq_ f g = (Set.toAscList . f) `eq` (toAscList . g)----------------------------------------------------------------------------- * Helpers--toAscList :: Ord a => S.HashSet a -> [a]-toAscList = List.sort . S.toList+ -- Basic interface+ , testProperty "size" $+ \(x :: HSK) -> HS.size x === List.length (HS.toList x)+ , testProperty "member" $+ \e (s :: HSK) -> HS.member e s === S.member e (toOrdSet s)+ , testProperty "insert" $+ \e (s :: HSK) -> toOrdSet (HS.insert e s) === S.insert e (toOrdSet s)+ , testProperty "delete" $+ \e (s :: HSK) -> toOrdSet (HS.delete e s) === S.delete e (toOrdSet s)+ -- Combine+ , testProperty "union" $+ \(x :: HSK) y -> toOrdSet (HS.union x y) === S.union (toOrdSet x) (toOrdSet y)+ -- Transformations+ , testProperty "map" $+ \(Fn f :: Fun Key Key) (s :: HSK) -> toOrdSet (HS.map f s) === S.map f (toOrdSet s)+ -- Folds+ , testProperty "foldr" $+ \(s :: HSK) ->+ List.sort (HS.foldr (:) [] s) === List.sort (S.foldr (:) [] (toOrdSet s))+ , testProperty "foldl'" $+ \(s :: HSK) z0 ->+ let f z k = keyToInt k + z+ in HS.foldl' f z0 s === S.foldl' f z0 (toOrdSet s)+ -- Filter+ , testProperty "filter" $+ \(Fn p) (s :: HSK) -> toOrdSet (HS.filter p s) === S.filter p (toOrdSet s)+ -- Conversions+ , testProperty "toList" $+ \(xs :: [Key]) -> List.sort (HS.toList (HS.fromList xs)) === S.toAscList (S.fromList xs)+ ]
tests/Strictness.hs view
@@ -1,42 +1,27 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v) module Strictness (tests) where import Control.Arrow (second) import Control.Monad (guard) import Data.Foldable (foldl')-import Data.Hashable (Hashable (hashWithSalt))+import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import Data.Maybe (fromMaybe, isJust) import Test.ChasingBottoms.IsBottom-import Test.QuickCheck (Arbitrary (arbitrary), Property, (.&&.),- (===))+import Test.QuickCheck (Arbitrary (..), Property, (.&&.), (===)) import Test.QuickCheck.Function import Test.QuickCheck.Poly (A) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty)+import Text.Show.Functions ()+import Util.Key (Key) 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>"+instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where+ arbitrary = HM.fromList <$> arbitrary+ shrink = fmap HM.fromList . shrink . HM.toList ------------------------------------------------------------------------ -- * Properties@@ -84,8 +69,8 @@ pFromListKeyStrict :: Bool pFromListKeyStrict = isBottom $ HM.fromList [(undefined :: Key, 1 :: Int)] -pFromListValueStrict :: Bool-pFromListValueStrict = isBottom $ HM.fromList [(K 1, undefined)]+pFromListValueStrict :: Key -> Bool+pFromListValueStrict k = isBottom $ HM.fromList [(k, undefined)] pFromListWithKeyStrict :: (Int -> Int -> Int) -> Bool pFromListWithKeyStrict f =@@ -113,7 +98,7 @@ -- argument, just the first argument, just the second argument, -- or both arguments are bottom. It would be quite tempting to -- just use Maybe A -> Maybe A -> Maybe A, but that would not--- necessarily be continous.+-- necessarily be continuous. pFromListWithValueResultStrict :: [(Key, Maybe A)] -> Fun (Maybe A, Maybe A) A -> Fun (Maybe A, Maybe A) Bool
+ tests/Util/Key.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-}++module Util.Key (Key(..), keyToInt, incKey, collisionAtHash) where++import Data.Bits (bit, (.&.))+import Data.Hashable (Hashable (hashWithSalt))+import Data.Word (Word16)+import GHC.Generics (Generic)+import Test.QuickCheck (Arbitrary (..), CoArbitrary (..), Function, Gen, Large)++import qualified Test.QuickCheck as QC++-- Key type that generates more hash collisions.+data Key = K+ { hash :: !Int+ -- ^ The hash of the key+ , _x :: !SmallSum+ -- ^ Additional data, so we can have collisions for any hash+ } deriving (Eq, Ord, Read, Show, Generic, Function, CoArbitrary)++instance Hashable Key where+ hashWithSalt _ (K h _) = h++data SmallSum = A | B | C | D+ deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded, Function, CoArbitrary)++instance Arbitrary SmallSum where+ arbitrary = QC.arbitraryBoundedEnum+ shrink = shrinkSmallSum++shrinkSmallSum :: SmallSum -> [SmallSum]+shrinkSmallSum A = []+shrinkSmallSum B = [A]+shrinkSmallSum C = [A, B]+shrinkSmallSum D = [A, B, C]++instance Arbitrary Key where+ arbitrary = K <$> arbitraryHash <*> arbitrary+ shrink = QC.genericShrink++arbitraryHash :: Gen Int+arbitraryHash = do+ let gens =+ [ (2, fromIntegral . QC.getLarge <$> arbitrary @(Large Word16))+ , (1, QC.getSmall <$> arbitrary)+ , (1, QC.getLarge <$> arbitrary)+ ]+ i <- QC.frequency gens+ moreCollisions' <- QC.elements [moreCollisions, id]+ pure (moreCollisions' i)++-- | Mask out most bits to produce more collisions+moreCollisions :: Int -> Int+moreCollisions w = fromIntegral (w .&. mask)++mask :: Int+mask = sum [bit n | n <- [0, 3, 8, 14, 61]]++keyToInt :: Key -> Int+keyToInt (K h x) = h * fromEnum x++incKey :: Key -> Key+incKey (K h x) = K (h + 1) x++-- | 4 colliding keys at a given hash.+collisionAtHash :: Int -> (Key, Key, Key, Key)+collisionAtHash h = (K h A, K h B, K h C, K h D)
unordered-containers.cabal view
@@ -1,5 +1,5 @@ name: unordered-containers-version: 0.2.19.1+version: 0.2.20 synopsis: Efficient hashing-based container types description: Efficient hashing-based container types. The containers have been@@ -29,7 +29,10 @@ extra-source-files: CHANGES.md tested-with:- GHC ==9.2.1+ GHC ==9.8.1+ || ==9.6.3+ || ==9.4.7+ || ==9.2.8 || ==9.0.2 || ==8.10.7 || ==8.8.4@@ -45,6 +48,7 @@ exposed-modules: Data.HashMap.Internal Data.HashMap.Internal.Array+ Data.HashMap.Internal.Debug Data.HashMap.Internal.List Data.HashMap.Internal.Strict Data.HashMap.Lazy@@ -56,7 +60,7 @@ base >= 4.10 && < 5, deepseq >= 1.4.3, hashable >= 1.2.5 && < 1.5,- template-haskell < 2.19+ template-haskell < 2.22 default-language: Haskell2010 @@ -89,6 +93,7 @@ Properties.HashSet Properties.List Strictness+ Util.Key build-depends: base,@@ -108,7 +113,7 @@ nothunks >= 0.1.3 default-language: Haskell2010- ghc-options: -Wall+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N cpp-options: -DASSERTS benchmark benchmarks