diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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) diff --git a/Data/HashMap/Internal.hs b/Data/HashMap/Internal.hs --- a/Data/HashMap/Internal.hs +++ b/Data/HashMap/Internal.hs @@ -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 diff --git a/Data/HashMap/Internal/Array.hs b/Data/HashMap/Internal/Array.hs --- a/Data/HashMap/Internal/Array.hs +++ b/Data/HashMap/Internal/Array.hs @@ -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 diff --git a/Data/HashMap/Internal/Debug.hs b/Data/HashMap/Internal/Debug.hs new file mode 100644 --- /dev/null +++ b/Data/HashMap/Internal/Debug.hs @@ -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 diff --git a/Data/HashMap/Internal/List.hs b/Data/HashMap/Internal/List.hs --- a/Data/HashMap/Internal/List.hs +++ b/Data/HashMap/Internal/List.hs @@ -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) diff --git a/Data/HashMap/Internal/Strict.hs b/Data/HashMap/Internal/Strict.hs --- a/Data/HashMap/Internal/Strict.hs +++ b/Data/HashMap/Internal/Strict.hs @@ -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. diff --git a/Data/HashSet/Internal.hs b/Data/HashSet/Internal.hs --- a/Data/HashSet/Internal.hs +++ b/Data/HashSet/Internal.hs @@ -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 #-} diff --git a/tests/Properties/HashMapLazy.hs b/tests/Properties/HashMapLazy.hs --- a/tests/Properties/HashMapLazy.hs +++ b/tests/Properties/HashMapLazy.hs @@ -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 diff --git a/tests/Properties/HashSet.hs b/tests/Properties/HashSet.hs --- a/tests/Properties/HashSet.hs +++ b/tests/Properties/HashSet.hs @@ -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) + ] diff --git a/tests/Strictness.hs b/tests/Strictness.hs --- a/tests/Strictness.hs +++ b/tests/Strictness.hs @@ -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 _ = "" - -instance Show (Int -> Int -> Int) where - show _ = "" +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 diff --git a/tests/Util/Key.hs b/tests/Util/Key.hs new file mode 100644 --- /dev/null +++ b/tests/Util/Key.hs @@ -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) diff --git a/unordered-containers.cabal b/unordered-containers.cabal --- a/unordered-containers.cabal +++ b/unordered-containers.cabal @@ -1,5 +1,5 @@ name: unordered-containers -version: 0.2.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