unordered-containers 0.1.4.6 → 0.2.21
raw patch · 32 files changed
Files
- CHANGES.md +321/−0
- Data/FullList/Lazy.hs +0/−353
- Data/FullList/Strict.hs +0/−132
- Data/HashMap/Common.hs +0/−338
- Data/HashMap/Internal.hs +2994/−0
- Data/HashMap/Internal/Array.hs +662/−0
- Data/HashMap/Internal/Debug.hs +148/−0
- Data/HashMap/Internal/List.hs +81/−0
- Data/HashMap/Internal/Strict.hs +782/−0
- Data/HashMap/Lazy.hs +56/−295
- Data/HashMap/Lazy/Internal.hs +0/−48
- Data/HashMap/Strict.hs +58/−146
- Data/HashMap/Strict/Internal.hs +0/−19
- Data/HashSet.hs +102/−178
- Data/HashSet/Internal.hs +482/−0
- benchmarks/Benchmarks.hs +394/−105
- benchmarks/FineGrained.hs +608/−0
- benchmarks/Key/Bytes.hs +46/−0
- benchmarks/Makefile +0/−45
- benchmarks/Util/ByteString.hs +2/−3
- tests/Main.hs +17/−0
- tests/MapProperties.hs +0/−222
- tests/Properties.hs +16/−0
- tests/Properties/HashMapLazy.hs +484/−0
- tests/Properties/HashMapStrict.hs +5/−0
- tests/Properties/HashSet.hs +138/−0
- tests/Properties/List.hs +64/−0
- tests/Regressions.hs +289/−0
- tests/SetProperties.hs +0/−171
- tests/Strictness.hs +175/−0
- tests/Util/Key.hs +80/−0
- unordered-containers.cabal +117/−48
+ CHANGES.md view
@@ -0,0 +1,321 @@+## [0.2.21] - December 2025++* API enhancements:+ * [Add `HashMap.lookupKey` and `HashSet.lookupElement`](https://github.com/haskell-unordered-containers/unordered-containers/pull/554)+ * [Add `differenceWithKey`](https://github.com/haskell-unordered-containers/unordered-containers/pull/542)+ * [Add `disjoint`](https://github.com/haskell-unordered-containers/unordered-containers/pull/559)++* Performance improvements:+ * [`HashSet.fromList`: Use `unsafeInsert`](https://github.com/haskell-unordered-containers/unordered-containers/pull/515)+ * [Use tree-diffing for `difference`](https://github.com/haskell-unordered-containers/unordered-containers/pull/535)+ * [Remove some unnecessary forcing of HashMaps](https://github.com/haskell-unordered-containers/unordered-containers/pull/545)+ * [Remove the `Array.index` function](https://github.com/haskell-unordered-containers/unordered-containers/pull/539)+ * [`hashWithSalt`: Ensure that the salt `Int` is unboxed](https://github.com/haskell-unordered-containers/unordered-containers/pull/569)++* Documentation changes:+ * [Turn some comments into docstrings](https://github.com/haskell-unordered-containers/unordered-containers/pull/516)+ * [Reword disclaimer regarding hash collision attacks](https://github.com/haskell-unordered-containers/unordered-containers/pull/557)+ * [Update time complexity of some HashSet functions](https://github.com/haskell-unordered-containers/unordered-containers/pull/568)+ * [Update instructions for code inspection](https://github.com/haskell-unordered-containers/unordered-containers/pull/567)++* Other changes:+ * [Drop support for GHC < 8.10](https://github.com/haskell-unordered-containers/unordered-containers/pull/510)+ * [Address deprecation warnings and other warnings](https://github.com/haskell-unordered-containers/unordered-containers/pull/512)+ * [Optimize indexing in arrays of length 2](https://github.com/haskell-unordered-containers/unordered-containers/pull/528)+ * [Introduce `ShiftedHash`](https://github.com/haskell-unordered-containers/unordered-containers/pull/529)+ * [New "fine-grained" benchmarks](https://github.com/haskell-unordered-containers/unordered-containers/pull/526)+ * [Make it compile with MicroHs](https://github.com/haskell-unordered-containers/unordered-containers/pull/553). Thanks, @augustss!+ * [Remove redundant `Eq` constraints](https://github.com/haskell-unordered-containers/unordered-containers/pull/558)+ * [Refactor `delete`](https://github.com/haskell-unordered-containers/unordered-containers/pull/571)+ * [`difference[With]`: Undo constraint relaxation](https://github.com/haskell-unordered-containers/unordered-containers/pull/573)++[0.2.21]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.20.1...v0.2.21++## [0.2.20.1] - October 2025++* [Fix infinite loop in `isSubmapOf[By]` / `isSubsetOf` on 32-bit platforms](https://github.com/haskell-unordered-containers/unordered-containers/pull/501).+ To fix this bug and potentially other similar bugs, we return to a branching factor of 16 on 32-bit platforms.++* [Relax bounds for GHC 9.12](https://github.com/haskell-unordered-containers/unordered-containers/pull/499)++* [Require `hashable >= 1.4`](https://github.com/haskell-unordered-containers/unordered-containers/pull/506)++* Documentation changes:+ * [Fix documentation about branching factor in `Data.HashMap.Strict`](https://github.com/haskell-unordered-containers/unordered-containers/pull/494)+ * [Improve documentation for `Data.HashMap.compose`](https://github.com/haskell-unordered-containers/unordered-containers/pull/500)+ * [Fixes docs of `Data.HashMap.Lazy.fromList`: it takes O(n * log(n))](https://github.com/haskell-unordered-containers/unordered-containers/pull/498)+ * [Add disclaimer to `Data.HashSet.toList`](https://github.com/haskell-unordered-containers/unordered-containers/pull/507)++* [Remove bad `isSubmapOf` testcase](https://github.com/haskell-unordered-containers/unordered-containers/pull/504)++[0.2.20.1]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.20...v0.2.20.1++## [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.20]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.19.1...v0.2.20++## [0.2.19.1] – April 2022++* [Fix bug in `intersection[With[Key]]`](https://github.com/haskell-unordered-containers/unordered-containers/pull/427)++* [Improve docs of bit twiddling functions](https://github.com/haskell-unordered-containers/unordered-containers/pull/396)++[0.2.19.1]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.19.0...v0.2.19.1++## [0.2.19.0] – April 2022++* [Make intersections much faster](https://github.com/haskell-unordered-containers/unordered-containers/pull/406)++* [Fix undefined behaviour on 32-bit platforms](https://github.com/haskell-unordered-containers/unordered-containers/pull/413)++* Speed up some array-appending operations: [#407](https://github.com/haskell-unordered-containers/unordered-containers/pull/407), [#409](https://github.com/haskell-unordered-containers/unordered-containers/pull/409)++* [Use MathJax format for complexity annotations](https://github.com/haskell-unordered-containers/unordered-containers/pull/411)++[0.2.19.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.18.0...v0.2.19.0++## [0.2.18.0]++* [Fix strictness properties of `Strict.mapMaybe[WithKey]`](https://github.com/haskell-unordered-containers/unordered-containers/pull/385)++* [Fix strictness properties of `Strict.alterFEager`](https://github.com/haskell-unordered-containers/unordered-containers/pull/384)++* [Fix space leaks in `union[With[Key]]`](https://github.com/haskell-unordered-containers/unordered-containers/pull/380)++* [Fix space leak in `Lazy.fromListWith`](https://github.com/haskell-unordered-containers/unordered-containers/pull/386)++* [Speed up `difference*` and `intersection*` with `unsafeInsert`](https://github.com/haskell-unordered-containers/unordered-containers/pull/372)++* [`unionArrayBy`: Find next 1-bits with `countTrailingZeros`](https://github.com/haskell-unordered-containers/unordered-containers/pull/395)+ - This speeds up `union*` for sparsely filled nodes, while penalizing `union` operations on densely filled nodes.++* [Reduce reboxing in internal array operations](https://github.com/haskell-unordered-containers/unordered-containers/pull/377)++* [Reduce code size of array operations in `union*`](https://github.com/haskell-unordered-containers/unordered-containers/pull/376)++[0.2.18.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.17.0...v0.2.18.0++## [0.2.17.0]++* [Define `dataCast1` for `HashMap`](https://github.com/haskell-unordered-containers/unordered-containers/pull/345)++* [Add `Lift` instances for Template Haskell](https://github.com/haskell-unordered-containers/unordered-containers/pull/343)++* [Add definitions for `stimes`](https://github.com/haskell-unordered-containers/unordered-containers/pull/340)++* [Expose internal constructors for `HashSet`, `Array` and `MArray`](https://github.com/haskell-unordered-containers/unordered-containers/pull/347)++* [Tweak internal `Array.insertM` function](https://github.com/haskell-unordered-containers/unordered-containers/pull/359)++* [Drop support for GHC 8.0](https://github.com/haskell-unordered-containers/unordered-containers/pull/354)++* [Drop support for `hashable < 1.2.5`](https://github.com/haskell-unordered-containers/unordered-containers/pull/355)++* Various cleanup and documentation improvements++[0.2.17.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.16.0...v0.2.17.0++## [0.2.16.0]++* [Increase maximum branching factor from 16 to 32](https://github.com/haskell-unordered-containers/unordered-containers/pull/317)++* [Tweak `union.goDifferentHash`](https://github.com/haskell-unordered-containers/unordered-containers/pull/277)++* [Fix debug mode bounds check in `cloneM`](https://github.com/haskell-unordered-containers/unordered-containers/pull/331)++* [Remove some old internal compatibility code](https://github.com/haskell-unordered-containers/unordered-containers/pull/334)++[0.2.16.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.15.0...v0.2.16.0++## [0.2.15.0]++* [Add security advisory regarding hash collision attacks](https://github.com/haskell-unordered-containers/unordered-containers/pull/320)++* [Add support for hashable 1.4](https://github.com/haskell-unordered-containers/unordered-containers/pull/324)++* [Drop support for GHC < 8](https://github.com/haskell-unordered-containers/unordered-containers/pull/323)++[0.2.15.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.14.0...v0.2.15.0++## [0.2.14.0]++* [Add `HashMap.mapKeys`.](https://github.com/haskell-unordered-containers/unordered-containers/pull/308) Thanks, Marco Perone!++* [Add instances for `NFData1` and `NFData2`.](https://github.com/haskell-unordered-containers/unordered-containers/pull/314) Thanks, Isaac Elliott and Oleg Grenrus!++* [Fix `@since`-annotation for `compose`.](https://github.com/haskell-unordered-containers/unordered-containers/pull/303) Thanks, @Mathnerd314!++[0.2.14.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.13.0...v0.2.14.0++## [0.2.13.0]++* [Add `HashMap.compose`.](https://github.com/haskell-unordered-containers/unordered-containers/pull/299) Thanks Alexandre Esteves.++[0.2.13.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.12.0...v0.2.13.0++## [0.2.12.0]++* Add `HashMap.isSubmapOf[By]` and `HashSet.isSubsetOf`. Thanks Sven Keidel. ([#282])++* Expose internal modules. ([#283])++* Documentation improvements in `Data.HashSet`, including a beginner-friendly+ introduction. Thanks Matt Renaud. ([#267])++* `HashMap.alterF`: Skip key deletion for absent keys. ([#288])++* Remove custom `unsafeShift{L,R}` definitions. ([#281])++* Various other documentation improvements.++[0.2.12.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.11.0...v0.2.12.0+[#267]: https://github.com/haskell-unordered-containers/unordered-containers/pull/267+[#281]: https://github.com/haskell-unordered-containers/unordered-containers/pull/281+[#282]: https://github.com/haskell-unordered-containers/unordered-containers/pull/282+[#283]: https://github.com/haskell-unordered-containers/unordered-containers/pull/283+[#288]: https://github.com/haskell-unordered-containers/unordered-containers/pull/288++## 0.2.11.0++ * Add `HashMap.findWithDefault` (soft-deprecates `HashMap.lookupDefault`).+ Thanks, Matt Renaud.++ * Add `HashMap.fromListWithKey`. Thanks, Josef Svenningsson.++ * Add more folding functions and use them in `Foldable` instances. Thanks,+ David Feuer.++ * Add `HashMap.!?`, a flipped version of `lookup`. Thanks, Matt Renaud.++ * Add a `Bifoldable` instance for `HashMap`. Thanks, Joseph Sible.++ * Add a `HasCallStack` constraint to `(!)`. Thanks, Roman Cheplyaka.++### Bug fixes++ * Fix a space leak affecting updates on keys with hash collisions. Thanks,+ Neil Mitchell. ([#254])++ * Get rid of some silly thunks that could be left lying around. ([#232]).+ Thanks, David Feuer.++### Other changes++ * Speed up the `Hashable` instances for `HashMap` and `HashSet`. Thanks,+ Edward Amsden.++ * Remove a dependency cycle hack from the benchmark suite. Thanks,+ Andrew Martin.++ * Improve documentation. Thanks, Tristan McLeay, Li-yao Xia, Gareth Smith,+ Simon Jakobi, Sergey Vinokurov, and likely others.++[#232]: https://github.com/haskell-unordered-containers/unordered-containers/issues/232+[#254]: https://github.com/haskell-unordered-containers/unordered-containers/issues/254++## 0.2.10.0++ * Add `HashMap.alterF`.++ * Add `HashMap.keysSet`.++ * Make `HashMap.Strict.traverseWithKey` force the results before+ installing them in the map.++## 0.2.9.0++ * Add `Ord/Ord1/Ord2` instances. (Thanks, Oleg Grenrus)++ * Use `SmallArray#` instead of `Array#` for GHC versions 7.10 and above.+ (Thanks, Dmitry Ivanov)++ * Adjust for `Semigroup => Monoid` proposal implementation.+ (Thanks, Ryan Scott)++### Bug fixes++ * Fix a strictness bug in `fromListWith`.++ * Enable eager blackholing for pre-8.2 GHC versions to work around+ a runtime system bug. (Thanks, Ben Gamari)++ * Avoid sketchy reimplementation of `ST` when compiling with recent+ GHC.++### Other changes++ * Remove support for GHC versions before 7.8. (Thanks, Dmitry Ivanov)++ * Add internal documentaton. (Thanks, Johan Tibell)++## 0.2.8.0++ * Add `Eq1/2`, `Show1/2`, `Read1` instances with `base-4.9`++ * `Eq (HashSet a)` doesn't require `Hashable a` anymore, only `Eq a`.++ * Add `Hashable1/2` with `hashable-1.2.6.0`++ * Add `differenceWith` function.++## 0.2.7.2++ * Don't use -fregs-graphs++ * Fix benchmark compilation on stack.++## 0.2.7.1++ * Fix linker error related to popcnt.++ * Haddock improvements.++ * Fix benchmark compilation when downloaded from Hackage.++## 0.2.7.0++ * Support criterion 1.1++ * Add unionWithKey for hash maps.++## 0.2.6.0++ * Mark several modules as Trustworthy.++ * Add Hashable instances for HashMap and HashSet.++ * Add mapMaybe, mapMaybeWithKey, update, alter, and+ intersectionWithKey.++ * Add roles.++ * Add Hashable and Semigroup instances.++## 0.2.5.1 (2014-10-11)++ * Support base-4.8
− Data/FullList/Lazy.hs
@@ -1,353 +0,0 @@-{-# LANGUAGE BangPatterns, CPP #-}----------------------------------------------------------------------------- |--- Module : Data.FullList.Lazy--- Copyright : 2010-2011 Johan Tibell--- License : BSD-style--- Maintainer : johan.tibell@gmail.com--- Stability : provisional--- Portability : portable------ Non-empty lists of key/value pairs. The lists are strict in the--- keys and lazy in the values.--module Data.FullList.Lazy- ( FullList(..)- , List(..)-- -- * Basic interface- , size- , singleton- , lookup- , insert- , delete- , insertWith- , adjust-- -- * Combine- -- * Union- , union- , unionWith-- -- * Transformations- , map- , traverseWithKey-- -- * Folds- , foldlWithKey'- , foldrWithKey-- -- * Filter- , filterWithKey- -- * For use by FL.Strict- , lookupL- , deleteL- ) where--import Control.Applicative-import Control.DeepSeq (NFData(rnf))-import Prelude hiding (lookup, map)----------------------------------------------------------------------------- * The 'FullList' type---- The 'FullList' type has two benefits:------ * it is guaranteed to be non-empty, and------ * it can be unpacked into a data constructor.---- Invariant: the same key only appears once in a 'FullList'.---- | A non-empty list of key/value pairs.-data FullList k v = FL !k v !(List k v)- deriving Show--instance (Eq k, Eq v) => Eq (FullList k v) where- (FL k1 v1 xs) == (FL k2 v2 ys) = k1 == k2 && v1 == v2 && xs == ys- (FL k1 v1 xs) /= (FL k2 v2 ys) = k1 /= k2 || v1 /= v2 || xs /= ys--instance (NFData k, NFData v) => NFData (FullList k v)--data List k v = Nil | Cons !k v !(List k v)- deriving Show--instance (Eq k, Eq v) => Eq (List k v) where- (Cons k1 v1 xs) == (Cons k2 v2 ys) = k1 == k2 && v1 == v2 && xs == ys- Nil == Nil = True- _ == _ = False-- (Cons k1 v1 xs) /= (Cons k2 v2 ys) = k1 /= k2 || v1 /= v2 || xs /= ys- Nil /= Nil = False- _ /= _ = True--instance (NFData k, NFData v) => NFData (List k v) where- rnf Nil = ()- rnf (Cons k v xs) = rnf k `seq` rnf v `seq` rnf xs---- TODO: Check if evaluation is forced.----------------------------------------------------------------------------- * FullList---- The 'List' functions are not inlined as they should be seldomly--- called in practice (i.e. we expect few collisions.)--size :: FullList k v -> Int-size (FL _ _ xs) = 1 + sizeL xs--sizeL :: List k v -> Int-sizeL Nil = 0-sizeL (Cons _ _ xs) = 1 + sizeL xs--singleton :: k -> v -> FullList k v-singleton k v = FL k v Nil--lookup :: Eq k => k -> FullList k v -> Maybe v-lookup !k (FL k' v xs)- | k == k' = Just v- | otherwise = lookupL k xs-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE lookup #-}-#endif--lookupL :: Eq k => k -> List k v -> Maybe v-lookupL = go- where- go !_ Nil = Nothing- go k (Cons k' v xs)- | k == k' = Just v- | otherwise = go k xs-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE lookupL #-}-#endif--member :: Eq k => k -> FullList k v -> Bool-member !k (FL k' _ xs)- | k == k' = True- | otherwise = memberL k xs-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE member #-}-#endif--memberL :: Eq k => k -> List k v -> Bool-memberL = go- where- go !_ Nil = False- go k (Cons k' _ xs)- | k == k' = True- | otherwise = go k xs-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE memberL #-}-#endif--insert :: Eq k => k -> v -> FullList k v -> FullList k v-insert !k v (FL k' v' xs)- | k == k' = FL k v xs- | otherwise = FL k' v' (insertL k v xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insert #-}-#endif---- | /O(n)/ Insert at the head of the list to avoid copying the whole--- list.-insertL :: Eq k => k -> v -> List k v -> List k v-insertL = go- where- go !k v Nil = Cons k v Nil- go k v (Cons k' v' xs)- | k == k' = Cons k v xs- | otherwise = Cons k' v' (go k v xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertL #-}-#endif--delete :: Eq k => k -> FullList k v -> Maybe (FullList k v)-delete !k (FL k' v xs)- | k == k' = case xs of- Nil -> Nothing- Cons k'' v' xs' -> Just $ FL k'' v' xs'- | otherwise = let ys = deleteL k xs- in ys `seq` Just (FL k' v ys)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE delete #-}-#endif--deleteL :: Eq k => k -> List k v -> List k v-deleteL = go- where- go !_ Nil = Nil- go k (Cons k' v xs)- | k == k' = xs- | otherwise = Cons k' v (go k xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE deleteL #-}-#endif--insertWith :: Eq k => (v -> v -> v) -> k -> v -> FullList k v -> FullList k v-insertWith f !k v (FL k' v' xs)- | k == k' = FL k (f v v') xs- | otherwise = FL k' v' (insertWithL f k v xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertWith #-}-#endif--insertWithL :: Eq k => (v -> v -> v) -> k -> v -> List k v -> List k v-insertWithL = go- where- go _ !k v Nil = Cons k v Nil- go f k v (Cons k' v' xs)- | k == k' = Cons k (f v v') xs- | otherwise = Cons k' v' (go f k v xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertWithL #-}-#endif--adjust :: Eq k => (v -> v) -> k -> FullList k v -> FullList k v-adjust f !k (FL k' v xs)- | k == k' = FL k' (f v) xs- | otherwise = FL k' v (adjustL f k xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE adjust #-}-#endif--adjustL :: Eq k => (v -> v) -> k -> List k v -> List k v-adjustL f = go- where- go !_ Nil = Nil- go k (Cons k' v xs)- | k == k' = Cons k' (f v) xs- | otherwise = Cons k' v (go k xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE adjustL #-}-#endif----------------------------------------------------------------------------- * Combine---- | /O(n^2)/ Left biased union.-union :: Eq k => FullList k v -> FullList k v -> FullList k v-union xs (FL k v ys)- | k `member` xs = unionL xs ys- | otherwise = case unionL xs ys of- FL k' v' zs -> FL k v $ Cons k' v' zs-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE union #-}-#endif--unionL :: Eq k => FullList k v -> List k v -> FullList k v-unionL xs@(FL k v zs) = FL k v . go- where- go Nil = zs- go (Cons k' v' ys)- | k' `member` xs = go ys- | otherwise = Cons k' v' $ go ys-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE unionL #-}-#endif--unionWith :: Eq k => (v -> v -> v) -> FullList k v -> FullList k v -> FullList k v-unionWith f xs (FL k vy ys) =- case lookup k xs of- Just vx ->- let flCon = FL k (f vx vy)- in case delete k xs of- Nothing -> flCon ys- Just xs' ->- case unionWithL f xs' ys of- FL k' v' zs -> flCon $ Cons k' v' zs- Nothing ->- case unionWithL f xs ys of- FL k' v' zs -> FL k vy $ Cons k' v' zs-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE unionWith #-}-#endif--unionWithL :: Eq k => (v -> v -> v) -> FullList k v -> List k v -> FullList k v-unionWithL f (FL k v zs) ys =- case lookupL k ys of - Just vy -> FL k (f v vy) $ go zs (deleteL k ys)- Nothing -> FL k v (go zs ys)- where- go ws Nil = ws- go ws (Cons k' vy ys') =- case lookupL k' ws of- Just vx -> Cons k' (f vx vy) $ go (deleteL k' ws) ys'- Nothing -> Cons k' vy $ go ws ys'-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE unionWithL #-}-#endif----------------------------------------------------------------------------- * Transformations--map :: (k1 -> v1 -> (k2, v2)) -> FullList k1 v1 -> FullList k2 v2-map f (FL k v xs) = let (k', v') = f k v- in FL k' v' (mapL f xs)-{-# INLINE map #-}--mapL :: (k1 -> v1 -> (k2, v2)) -> List k1 v1 -> List k2 v2-mapL f = go- where- go Nil = Nil- go (Cons k v xs) = let (k', v') = f k v- in Cons k' v' (go xs)-{-# INLINE mapL #-}--traverseWithKey :: Applicative m => (k -> v1 -> m v2) -> FullList k v1 -> m (FullList k v2)-traverseWithKey f (FL k v xs) = FL k <$> f k v <*> traverseWithKeyL f xs-{-# INLINE traverseWithKey #-}--traverseWithKeyL :: Applicative m => (k -> v1 -> m v2) -> List k v1 -> m (List k v2)-traverseWithKeyL f = go- where- go Nil = pure Nil- go (Cons k v xs) = Cons k <$> f k v <*> go xs-{-# INLINE traverseWithKeyL #-}----------------------------------------------------------------------------- * Folds--foldlWithKey' :: (a -> k -> v -> a) -> a -> FullList k v -> a-foldlWithKey' f !z (FL k v xs) = foldlWithKey'L f (f z k v) xs-{-# INLINE foldlWithKey' #-}--foldlWithKey'L :: (a -> k -> v -> a) -> a -> List k v -> a-foldlWithKey'L f = go- where- go !z Nil = z- go z (Cons k v xs) = go (f z k v) xs-{-# INLINE foldlWithKey'L #-}--foldrWithKey :: (k -> v -> a -> a) -> a -> FullList k v -> a-foldrWithKey f z (FL k v xs) = f k v (foldrWithKeyL f z xs)-{-# INLINE foldrWithKey #-}--foldrWithKeyL :: (k -> v -> a -> a) -> a -> List k v -> a-foldrWithKeyL f = go- where- go z Nil = z- go z (Cons k v xs) = f k v (go z xs)-{-# INLINE foldrWithKeyL #-}----------------------------------------------------------------------------- * Filter--filterWithKey :: (k -> v -> Bool) -> FullList k v -> Maybe (FullList k v)-filterWithKey p (FL k v xs)- | p k v = Just (FL k v ys)- | otherwise = case ys of- Nil -> Nothing- Cons k' v' zs -> Just $ FL k' v' zs- where !ys = filterWithKeyL p xs-{-# INLINE filterWithKey #-}--filterWithKeyL :: (k -> v -> Bool) -> List k v -> List k v-filterWithKeyL p = go- where- go Nil = Nil- go (Cons k v xs)- | p k v = Cons k v (go xs)- | otherwise = go xs-{-# INLINE filterWithKeyL #-}
− Data/FullList/Strict.hs
@@ -1,132 +0,0 @@-{-# LANGUAGE BangPatterns, CPP #-}----------------------------------------------------------------------------- |--- Module : Data.FullList.Strict--- Copyright : 2010-2011 Johan Tibell--- License : BSD-style--- Maintainer : johan.tibell@gmail.com--- Stability : provisional--- Portability : portable------ Non-empty lists of key/value pairs. The lists are strict in the--- keys and the values.--module Data.FullList.Strict- ( FullList-- -- * Basic interface- , size- , singleton- , lookup- , insert- , delete- , insertWith- , adjust-- -- * Combine- -- ** Union- , unionWith-- -- * Transformations- , map- , traverseWithKey-- -- * Folds- , foldlWithKey'- , foldrWithKey-- -- * Filter- , filterWithKey- ) where--import Prelude hiding (lookup, map)--import Data.FullList.Lazy hiding (insertWith, map, adjust, unionWith)--insertWith :: Eq k => (v -> v -> v) -> k -> v -> FullList k v -> FullList k v-insertWith f !k v (FL k' v' xs)- | k == k' = let v'' = f v v' in v'' `seq` FL k v'' xs- | otherwise = FL k' v' (insertWithL f k v xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertWith #-}-#endif--insertWithL :: Eq k => (v -> v -> v) -> k -> v -> List k v -> List k v-insertWithL = go- where- go _ !k v Nil = Cons k v Nil- go f k v (Cons k' v' xs)- | k == k' = let v'' = f v v' in v'' `seq` Cons k v'' xs- | otherwise = Cons k' v' (go f k v xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertWithL #-}-#endif--adjust :: Eq k => (v -> v) -> k -> FullList k v -> FullList k v-adjust f !k (FL k' v xs)- | k == k' = let v' = f v in v' `seq` FL k' v' xs- | otherwise = FL k' v (adjustL f k xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE adjust #-}-#endif--adjustL :: Eq k => (v -> v) -> k -> List k v -> List k v-adjustL f = go- where- go !_ Nil = Nil- go k (Cons k' v xs)- | k == k' = let v' = f v in v' `seq` Cons k' v' xs- | otherwise = Cons k' v (go k xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE adjustL #-}-#endif----------------------------------------------------------------------------- * Transformations--map :: (k1 -> v1 -> (k2, v2)) -> FullList k1 v1 -> FullList k2 v2-map f (FL k v xs) = let !(k', !v') = f k v- in FL k' v' (mapL f xs)-{-# INLINE map #-}--mapL :: (k1 -> v1 -> (k2, v2)) -> List k1 v1 -> List k2 v2-mapL f = go- where- go Nil = Nil- go (Cons k v xs) = let !(k', !v') = f k v- in Cons k' v' (go xs)-{-# INLINE mapL #-}--unionWith :: Eq k => (v -> v -> v) -> FullList k v -> FullList k v -> FullList k v-unionWith f xs (FL k vy ys) =- case lookup k xs of- Just vx ->- let !vFinal = f vx vy- flCon = FL k vFinal- in case delete k xs of- Nothing -> flCon ys- Just xs' ->- case unionWithL f xs' ys of- FL k' v' zs -> flCon $ Cons k' v' zs- Nothing ->- case unionWithL f xs ys of- FL k' v' zs -> FL k vy $ Cons k' v' zs-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE unionWith #-}-#endif--unionWithL :: Eq k => (v -> v -> v) -> FullList k v -> List k v -> FullList k v-unionWithL f (FL k v zs) ys =- case lookupL k ys of- Just vy -> let !vFinal = f v vy in FL k vFinal $ go zs (deleteL k ys)- Nothing -> FL k v (go zs ys)- where- go ws Nil = ws- go ws (Cons k' vy ys') =- case lookupL k' ws of- Just vx -> let !vFinal = f vx vy in Cons k' vFinal $ go (deleteL k' ws) ys'- Nothing -> Cons k' vy $ go ws ys'-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE unionWithL #-}-#endif
− Data/HashMap/Common.hs
@@ -1,338 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable #-}---- | Code shared between the lazy and strict versions.--module Data.HashMap.Common- (- -- * Types- HashMap(..)-- -- * Helpers- , join- , bin- , zero- , nomatch-- -- * Construction- , empty-- -- * Combine- , union-- -- * Transformations- , toList- , filterMapWithKey- , traverseWithKey-- -- * Folds- , foldrWithKey-- -- * Helpers- , shorter- , insertCollidingWith- ) where--#include "MachDeps.h"--import Control.Applicative (Applicative((<*>), pure), (<$>))-import Control.DeepSeq (NFData(rnf))-import Data.Bits (Bits(..), (.&.), xor)-import qualified Data.Foldable as Foldable-import Data.Monoid (Monoid(mempty, mappend))-import Data.Traversable (Traversable(..))-import Data.Typeable (Typeable)-import Data.Word (Word)-import Prelude hiding (foldr, map)--#if defined(__GLASGOW_HASKELL__)-import GHC.Exts (build)-#endif--import qualified Data.FullList.Lazy as FL----------------------------------------------------------------------------- * The 'HashMap' type---- | 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- = Bin {-# UNPACK #-} !SuffixMask- !(HashMap k v)- !(HashMap k v)- | Tip {-# UNPACK #-} !Hash- {-# UNPACK #-} !(FL.FullList k v)- | Nil- deriving (Typeable)--type Suffix = Int-type Hash = Int---- | A SuffixMask stores a path to a Bin node in the hash map. The--- uppermost set bit, the Mask, indicates the bit used to distinguish--- hashes in the left and right subtrees. The lower-order bits (below--- the highest set bit), the Suffix, are set the same way in all the--- hashes contained in this subtree of the map. Thus, hashes in the--- right subtree will match all the bits in the SuffixMask, but may--- have set bits above the Mask. Hashes in the left subtree will not--- match the Mask bit, but will match all the Suffix bits.-type SuffixMask = Int----------------------------------------------------------------------------- * Instances---- Since both the lazy and the strict API shares one data type we can--- only provide one set of instances. We provide the lazy ones.--instance (Eq k, Eq v) => Eq (HashMap k v) where- t1 == t2 = equal t1 t2- t1 /= t2 = nequal t1 t2---- | /O(n)/ Return a list of this map's elements. The list is--- produced lazily.-toList :: HashMap k v -> [(k, v)]-#if defined(__GLASGOW_HASKELL__)-toList t = build (\ c z -> foldrWithKey (curry c) z t)-#else-toList = foldrWithKey (\ k v xs -> (k, v) : xs) []-#endif-{-# INLINE toList #-}--equal :: (Eq k, Eq v) => HashMap k v -> HashMap k v -> Bool-equal (Bin sm1 l1 r1) (Bin sm2 l2 r2) =- (sm1 == sm2) && (equal l1 l2) && (equal r1 r2)-equal (Tip h1 l1) (Tip h2 l2) = (h1 == h2) && (l1 == l2)-equal Nil Nil = True-equal _ _ = False--nequal :: (Eq k, Eq v) => HashMap k v -> HashMap k v -> Bool-nequal (Bin sm1 l1 r1) (Bin sm2 l2 r2) =- (sm1 /= sm2) || (nequal l1 l2) || (nequal r1 r2)-nequal (Tip h1 l1) (Tip h2 l2) = (h1 /= h2) || (l1 /= l2)-nequal Nil Nil = False-nequal _ _ = True--instance (NFData k, NFData v) => NFData (HashMap k v) where- rnf Nil = ()- rnf (Tip _ xs) = rnf xs- rnf (Bin _ l r) = rnf l `seq` rnf r--instance Functor (HashMap k) where- fmap = map--instance (Show k, Show v) => Show (HashMap k v) where- showsPrec d m = showParen (d > 10) $- showString "fromList " . shows (toList m)---- | /O(n)/ Transform this map by applying a function to every value.-map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2-map f = go- where- go (Bin sm l r) = Bin sm (go l) (go r)- go (Tip h l) = Tip h (FL.map f' l)- go Nil = Nil- f' k v = (k, f v)-{-# INLINE map #-}--instance Foldable.Foldable (HashMap k) where- foldr f = foldrWithKey (const f)---- | /O(n)/ Reduce this map by applying a binary operator to all--- elements, using the given starting value (typically the--- right-identity of the operator).-foldrWithKey :: (k -> v -> a -> a) -> a -> HashMap k v -> a-foldrWithKey f = go- where- go z (Bin _ l r) = go (go z r) l- go z (Tip _ l) = FL.foldrWithKey f z l- go z Nil = z-{-# INLINE foldrWithKey #-}--instance Eq k => Monoid (HashMap k v) where- mempty = empty- {-# INLINE mempty #-}- mappend = union- {-# INLINE mappend #-}---- | /O(1)/ Construct an empty map.-empty :: HashMap k v-empty = Nil---- | /O(n+m)/ The union of two maps. If a key occurs in both maps,--- the mapping from the first will be the mapping in the result.-union :: Eq k => HashMap k v -> HashMap k v -> HashMap k v-union t1@(Bin sm1 l1 r1) t2@(Bin sm2 l2 r2)- | sm1 == sm2 = Bin sm1 (union l1 l2) (union r1 r2)- | shorter sm1 sm2 = union1- | shorter sm2 sm1 = union2- | otherwise = join sm1 t1 sm2 t2- where- union1 | nomatch sm2 sm1 = join sm1 t1 sm2 t2- | zero sm2 sm1 = Bin sm1 (union l1 t2) r1- | otherwise = Bin sm1 l1 (union r1 t2)-- union2 | nomatch sm1 sm2 = join sm1 t1 sm2 t2- | zero sm1 sm2 = Bin sm2 (union t1 l2) r2- | otherwise = Bin sm2 l2 (union t1 r2)-union (Tip h l) t = insertCollidingL h l t-union t (Tip h l) = insertCollidingR h l t -- right bias-union Nil t = t-union t Nil = t-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE union #-}-#endif---- | Insert a list of key-value pairs which keys all hash to the same--- hash value. Prefer key-value pairs in the list to key-value pairs--- already in the map.-insertCollidingL :: Eq k => Hash -> FL.FullList k v -> HashMap k v -> HashMap k v-insertCollidingL = insertCollidingWith FL.union-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertCollidingL #-}-#endif---- | Insert a list of key-value pairs which keys all hash to the same--- hash value. Prefer key-value pairs already in the map to key-value--- pairs in the list.-insertCollidingR :: Eq k => Hash -> FL.FullList k v -> HashMap k v -> HashMap k v-insertCollidingR = insertCollidingWith (flip FL.union)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertCollidingR #-}-#endif---- | Insert a list of key-value pairs which keys all hash to the same--- hash value. Merge the list of key-value pairs to be inserted @xs@--- with any existing key-values pairs @ys@ by applying @f xs ys@.-insertCollidingWith :: Eq k- => (FL.FullList k v -> FL.FullList k v -> FL.FullList k v)- -> Hash -> FL.FullList k v- -> HashMap k v -> HashMap k v-insertCollidingWith f h0 l0 t0 = go h0 l0 t0- where- go !h !xs t@(Bin sm l r)- | nomatch h sm = join h (Tip h xs) sm t- | zero h sm = Bin sm (go h xs l) r- | otherwise = Bin sm l (go h xs r)- go h xs t@(Tip h' l)- | h == h' = Tip h $ f xs l- | otherwise = join h (Tip h xs) h' t- go h xs Nil = Tip h xs-{-# INLINE insertCollidingWith #-}--instance Traversable (HashMap k) where- traverse f = traverseWithKey (const f)---- | /O(n)/ Transform this map by applying a function to every value;--- when f k v returns Just x, keep an entry mapping k to x, otherwise--- do not include k in the result.-filterMapWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2-filterMapWithKey f = go- where- go (Bin sm l r) = bin sm (go l) (go r)- go (Tip h vs) =- case FL.foldrWithKey ff FL.Nil vs of- FL.Nil -> Nil- FL.Cons k v xs -> Tip h (FL.FL k v xs)- go Nil = Nil- ff k v xs =- case f k v of- Nothing -> xs- Just x -> FL.Cons k x xs-{-# INLINE filterMapWithKey #-}---- | /O(n)/ Transform this map by accumulating an Applicative result--- from every value.-traverseWithKey :: Applicative f => (k -> v1 -> f v2) -> HashMap k v1- -> f (HashMap k v2)-traverseWithKey f = go- where- go (Bin sm l r) = Bin sm <$> go l <*> go r- go (Tip h l) = Tip h <$> FL.traverseWithKey f l- go Nil = pure Nil-{-# INLINE traverseWithKey #-}----------------------------------------------------------------------------- Helpers--join :: Suffix -> HashMap k v -> Suffix -> HashMap k v -> HashMap k v-join s1 t1 s2 t2- | zero s1 sm = Bin sm t1 t2- | otherwise = Bin sm t2 t1- where- sm = branchSuffixMask s1 s2-{-# INLINE join #-}---- | @bin@ assures that we never have empty trees within a tree.-bin :: SuffixMask -> HashMap k v -> HashMap k v -> HashMap k v-bin _ l Nil = l-bin _ Nil r = r-bin sm l r = Bin sm l r-{-# INLINE bin #-}----------------------------------------------------------------------------- Endian independent bit twiddling---- Actually detects if every set bit of sm is set in i (and returns--- false if so). In most cases, the Suffix will already match, and--- this just tests the Mask. For lookup it can send us down the wrong--- path, but that's OK; we'll detect this when we reach a Tip and--- don't match. We could have checked (i .|. fromIntegral sm) /= i--- instead.-zero :: Hash -> SuffixMask -> Bool-zero i sm = (i .&. smi) /= smi- where smi = fromIntegral sm-{-# INLINE zero #-}---- We want to detect Suffix bits in the Hash that differ from--- SuffixMask. To do this, we find the first bit that differs between--- Hash and SuffixMask, then check if that bit is smaller than the--- Mask bit. We do this by observing that if we set this bit and all--- bits to its right, we'll obtain a number >= the suffixmask if all--- bits are the same (cb == 0, setting all bits) or if the first bit of--- difference is >= the Mask. Note: this comparison must be unsigned.-nomatch :: Hash -> SuffixMask -> Bool-nomatch i sm = (cb + cb - 1) < fromIntegral sm- where cb = differentBit i (fromIntegral sm)-{-# INLINE nomatch #-}----------------------------------------------------------------------------- Big endian operations---- | Compute the first (lowest-order) bit at which h1 and h2 differ.--- This is the mask that distinguishes them.-differentBit :: Hash -> Hash -> Word-differentBit h1 h2 =- fromIntegral (critBit (fromIntegral h1 `xor` fromIntegral h2))---- | Given mask bit m expressed as a word, compute the suffix bits of--- hash i, also expressed as a word.-suffixW :: Word -> Word -> Word-suffixW i m = i .&. (m-1)-{-# INLINE suffixW #-}---- | Given two hashes and/or SuffixMasks for which nomatch p1 p2 &&--- nomatch p2 p1, compute SuffixMask that differentiates them, by--- first computing the mask m and then using that to derive a suffix--- from one of them (it won't matter which, as those bits are the--- same).-branchSuffixMask :: Suffix -> Suffix -> SuffixMask-branchSuffixMask p1 p2 =- fromIntegral (m + suffixW w1 m)- where m = differentBit p1 p2- w1 = fromIntegral p1-{-# INLINE branchSuffixMask #-}---- | Is the mask of sm1 closer to the root of the tree (lower order)--- than the mask of sm2? This is actually approximate, and returns--- junk when both sm1 and sm2 are at the same tree level. This must--- be disambiguated by first checking sm1==sm2, and subsequently by--- checking nomatch in the appropriate direction (which will need to--- happen anyway to determine if insertion or branching is--- appropriate).-shorter :: SuffixMask -> SuffixMask -> Bool-shorter sm1 sm2 = (fromIntegral sm1 :: Word) < (fromIntegral sm2 :: Word)-{-# INLINE shorter #-}---- | Return a 'Word' whose single set bit corresponds to the lowest set bit of w.-critBit :: Word -> Word-critBit w = w .&. (negate w)-{-# INLINE critBit #-}
+ Data/HashMap/Internal.hs view
@@ -0,0 +1,2994 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-}+{-# OPTIONS_HADDOCK not-home #-}++#include "MachDeps.h"++-- | = 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.++module Data.HashMap.Internal+ (+ HashMap(..)+ , Leaf(..)++ -- * Construction+ , empty+ , singleton++ -- * Basic interface+ , null+ , size+ , member+ , lookup+ , (!?)+ , findWithDefault+ , lookupDefault+ , (!)+ , lookupKey+ , insert+ , insertWith+ , unsafeInsert+ , delete+ , adjust+ , update+ , alter+ , alterF+ , isSubmapOf+ , isSubmapOfBy++ -- * Combine+ -- ** Union+ , union+ , unionWith+ , unionWithKey+ , unions++ -- ** Compose+ , compose++ -- * Transformations+ , map+ , mapWithKey+ , traverseWithKey+ , mapKeys++ -- * Difference and intersection+ , difference+ , differenceWith+ , differenceWithKey+ , intersection+ , intersectionWith+ , intersectionWithKey+ , intersectionWithKey#+ , disjoint++ -- * Folds+ , foldr'+ , foldl'+ , foldrWithKey'+ , foldlWithKey'+ , foldr+ , foldl+ , foldrWithKey+ , foldlWithKey+ , foldMapWithKey++ -- * Filter+ , mapMaybe+ , mapMaybeWithKey+ , filter+ , filterWithKey++ -- * Conversions+ , keys+ , elems++ -- ** Lists+ , toList+ , fromList+ , fromListWith+ , fromListWithKey++ -- ** Internals used by the strict version+ , Hash+ , Bitmap+ , Shift+ , bitmapIndexedOrFull+ , collision+ , hash+ , mask+ , index+ , bitsPerSubkey+ , maxChildren+ , isLeafOrCollision+ , fullBitmap+ , subkeyMask+ , nextShift+ , sparseIndex+ , two+ , unionArrayBy+ , updateFullArray+ , updateFullArrayM+ , updateFullArrayWith'+ , updateOrConcatWithKey+ , filterMapAux+ , equalKeys+ , equalKeys1+ , lookupRecordCollision+ , LookupRes(..)+ , lookupResToMaybe+ , insert'+ , delete'+ , lookup'+ , insertNewKey+ , insertKeyExists+ , deleteKeyExists+ , insertModifying+ , ptrEq+ , adjust#+ ) where++import Data.Traversable -- MicroHs needs this since its Prelude does not have Foldable&Traversable.+ -- It's harmless for GHC, and putting it first avoid a warning.++import Control.Applicative (Const (..))+import Control.DeepSeq (NFData (..), NFData1 (..), NFData2 (..))+import Control.Monad.ST (ST, runST)+import Data.Bifoldable (Bifoldable (..))+import Data.Bits (complement, countTrailingZeros, popCount,+ shiftL, unsafeShiftL, unsafeShiftR, (.&.),+ (.|.))+import Data.Coerce (coerce)+import Data.Data (Constr, Data (..), DataType)+import Data.Functor.Classes (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..),+ Read1 (..), Show1 (..), Show2 (..))+import Data.Functor.Identity (Identity (..))+import Data.Hashable (Hashable)+import Data.Hashable.Lifted (Hashable1, Hashable2)+import Data.HashMap.Internal.List (isPermutationBy, unorderedCompare)+import Data.Maybe (isNothing)+import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid)+import GHC.Exts (Int (..), Int#, TYPE, (==#))+import GHC.Stack (HasCallStack)+import Prelude hiding (Foldable (..), filter, lookup, map,+ pred)+import Text.Read hiding (step)++import qualified Data.Data as Data+import qualified Data.Foldable as Foldable+import qualified Data.Functor.Classes as FC+import qualified Data.Hashable as H+import qualified Data.Hashable.Lifted as H+import qualified Data.HashMap.Internal.Array as A+import qualified Data.List as List+import qualified GHC.Exts as Exts+import qualified Language.Haskell.TH.Syntax as TH++-- | Convenience function. Compute a hash value for the given value.+hash :: H.Hashable a => a -> Hash+hash = fromIntegral . H.hash++data Leaf k v = L !k v+ deriving (Eq)++instance (NFData k, NFData v) => NFData (Leaf k v) where+ rnf (L k v) = rnf k `seq` rnf v++#if defined(__GLASGOW_HASKELL__)+-- | @since 0.2.17.0+instance (TH.Lift k, TH.Lift v) => TH.Lift (Leaf k v) where+ liftTyped (L k v) = [|| L k $! v ||]+#endif++-- | @since 0.2.14.0+instance NFData k => NFData1 (Leaf k) where+ liftRnf = liftRnf2 rnf++-- | @since 0.2.14.0+instance NFData2 Leaf where+ liftRnf2 rnf1 rnf2 (L k v) = rnf1 k `seq` rnf2 v++-- | 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++-- | @since 0.2.17.0+deriving instance (TH.Lift k, TH.Lift v) => TH.Lift (HashMap k v)++instance (NFData k, NFData v) => NFData (HashMap k v) where+ rnf Empty = ()+ rnf (BitmapIndexed _ ary) = rnf ary+ rnf (Leaf _ l) = rnf l+ rnf (Full ary) = rnf ary+ rnf (Collision _ ary) = rnf ary++-- | @since 0.2.14.0+instance NFData k => NFData1 (HashMap k) where+ liftRnf = liftRnf2 rnf++-- | @since 0.2.14.0+instance NFData2 HashMap where+ liftRnf2 _ _ Empty = ()+ liftRnf2 rnf1 rnf2 (BitmapIndexed _ ary) = liftRnf (liftRnf2 rnf1 rnf2) ary+ liftRnf2 rnf1 rnf2 (Leaf _ l) = liftRnf2 rnf1 rnf2 l+ liftRnf2 rnf1 rnf2 (Full ary) = liftRnf (liftRnf2 rnf1 rnf2) ary+ liftRnf2 rnf1 rnf2 (Collision _ ary) = liftRnf (liftRnf2 rnf1 rnf2) ary++instance Functor (HashMap k) where+ fmap = map++instance Foldable.Foldable (HashMap k) where+ foldMap f = foldMapWithKey (\ _k v -> f v)+ {-# INLINE foldMap #-}+ foldr = foldr+ {-# INLINE foldr #-}+ foldl = foldl+ {-# INLINE foldl #-}+ foldr' = foldr'+ {-# INLINE foldr' #-}+ foldl' = foldl'+ {-# INLINE foldl' #-}+ null = null+ {-# INLINE null #-}+ length = size+ {-# INLINE length #-}++-- | @since 0.2.11+instance Bifoldable HashMap where+ bifoldMap f g = foldMapWithKey (\ k v -> f k `mappend` g v)+ {-# INLINE bifoldMap #-}+ bifoldr f g = foldrWithKey (\ k v acc -> k `f` (v `g` acc))+ {-# INLINE bifoldr #-}+ bifoldl f g = foldlWithKey (\ acc k v -> (acc `f` k) `g` v)+ {-# INLINE bifoldl #-}++-- | '<>' = 'union'+--+-- If a key occurs in both maps, the mapping from the first will be the mapping in the result.+--+-- ==== __Examples__+--+-- >>> fromList [(1,'a'),(2,'b')] <> fromList [(2,'c'),(3,'d')]+-- fromList [(1,'a'),(2,'b'),(3,'d')]+instance Hashable k => Semigroup (HashMap k v) where+ (<>) = union+ {-# INLINE (<>) #-}+ stimes = stimesIdempotentMonoid+ {-# INLINE stimes #-}++-- | 'mempty' = 'empty'+--+-- 'mappend' = 'union'+--+-- If a key occurs in both maps, the mapping from the first will be the mapping in the result.+--+-- ==== __Examples__+--+-- >>> mappend (fromList [(1,'a'),(2,'b')]) (fromList [(2,'c'),(3,'d')])+-- fromList [(1,'a'),(2,'b'),(3,'d')]+instance Hashable k => Monoid (HashMap k v) where+ mempty = empty+ {-# INLINE mempty #-}+ mappend = (<>)+ {-# INLINE mappend #-}++instance (Data k, Data v, Hashable k) => Data (HashMap k v) where+ gfoldl f z m = z fromList `f` toList m+ toConstr _ = fromListConstr+ gunfold k z c = case Data.constrIndex c of+ 1 -> k (z fromList)+ _ -> error "gunfold"+ dataTypeOf _ = hashMapDataType+ dataCast1 f = Data.gcast1 f+ dataCast2 f = Data.gcast2 f++fromListConstr :: Constr+fromListConstr = Data.mkConstr hashMapDataType "fromList" [] Data.Prefix++hashMapDataType :: DataType+hashMapDataType = Data.mkDataType "Data.HashMap.Internal.HashMap" [fromListConstr]++-- | 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 'fullBitmap'+-- corresponding to a 'Full' node.+--+-- Only the lower 'maxChildren' bits are used. The remaining bits must be zeros.+type Bitmap = Word++-- | A 'Shift' value is the offset of the subkey in the hash and corresponds+-- to the level of the tree that we're currently operating at. At the root+-- level the 'Shift' is @0@. For the subsequent levels the 'Shift' values are+-- 'bitsPerSubkey', @2*'bitsPerSubkey'@ etc.+--+-- Valid values are non-negative and less than @bitSize (0 :: Word)@.+type Shift = Int++instance Show2 HashMap where+ liftShowsPrec2 spk slk spv slv d m =+ FC.showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)+ where+ sp = liftShowsPrec2 spk slk spv slv+ sl = liftShowList2 spk slk spv slv++instance Show k => Show1 (HashMap k) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++instance (Hashable k, Read k) => Read1 (HashMap k) where+ liftReadsPrec rp rl = FC.readsData $+ FC.readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList+ where+ rp' = liftReadsPrec rp rl+ rl' = liftReadList rp rl++instance (Hashable k, Read k, Read e) => Read (HashMap k e) where+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ fromList <$> readPrec++ readListPrec = readListPrecDefault++instance (Show k, Show v) => Show (HashMap k v) where+ showsPrec d m = showParen (d > 10) $+ showString "fromList " . shows (toList m)++instance Traversable (HashMap k) where+ traverse f = traverseWithKey (const f)+ {-# INLINABLE traverse #-}++instance Eq2 HashMap where+ liftEq2 = equal2++instance Eq k => Eq1 (HashMap k) where+ liftEq = equal1++-- | Note that, in the presence of hash collisions, equal @HashMap@s may+-- behave differently, i.e. extensionality may be violated:+--+-- >>> data D = A | B deriving (Eq, Show)+-- >>> instance Hashable D where hashWithSalt salt _d = salt+--+-- >>> x = fromList [(A,1), (B,2)]+-- >>> y = fromList [(B,2), (A,1)]+--+-- >>> x == y+-- True+-- >>> toList x+-- [(A,1),(B,2)]+-- >>> toList y+-- [(B,2),(A,1)]+--+-- 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 (==)++equal1 :: Eq k+ => (v -> v' -> Bool)+ -> HashMap k v -> HashMap k v' -> Bool+equal1 eq = go+ where+ go Empty Empty = True+ go (BitmapIndexed bm1 ary1) (BitmapIndexed bm2 ary2)+ = bm1 == bm2 && A.sameArray1 go ary1 ary2+ go (Leaf h1 l1) (Leaf h2 l2) = h1 == h2 && leafEq l1 l2+ go (Full ary1) (Full ary2) = A.sameArray1 go ary1 ary2+ go (Collision h1 ary1) (Collision h2 ary2)+ = h1 == h2 && isPermutationBy leafEq (A.toList ary1) (A.toList ary2)+ go _ _ = False++ leafEq (L k1 v1) (L k2 v2) = k1 == k2 && eq v1 v2++equal2 :: (k -> k' -> Bool) -> (v -> v' -> Bool)+ -> HashMap k v -> HashMap k' v' -> Bool+equal2 eqk eqv t1 t2 = go (leavesAndCollisions t1 []) (leavesAndCollisions t2 [])+ where+ -- If the two trees are the same, then their lists of 'Leaf's and+ -- 'Collision's read from left to right should be the same (modulo the+ -- order of elements in 'Collision').++ go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2)+ | k1 == k2 &&+ leafEq l1 l2+ = go tl1 tl2+ 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+ go _ _ = False++ leafEq (L k v) (L k' v') = eqk k k' && eqv v v'++instance Ord2 HashMap where+ liftCompare2 = cmp++instance Ord k => Ord1 (HashMap k) where+ liftCompare = cmp compare++-- | The ordering is total and consistent with the `Eq` instance. However,+-- nothing else about the ordering is specified, and it may change from+-- version to version of either this package or of @hashable@.+instance (Ord k, Ord v) => Ord (HashMap k v) where+ compare = cmp compare compare++cmp :: (k -> k' -> Ordering) -> (v -> v' -> Ordering)+ -> HashMap k v -> HashMap k' v' -> Ordering+cmp cmpk cmpv t1 t2 = go (leavesAndCollisions t1 []) (leavesAndCollisions t2 [])+ where+ go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2)+ = compare k1 k2 `mappend`+ leafCompare l1 l2 `mappend`+ go tl1 tl2+ 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+ go (Leaf _ _ : _) (Collision _ _ : _) = LT+ go (Collision _ _ : _) (Leaf _ _ : _) = GT+ go [] [] = EQ+ go [] _ = LT+ go _ [] = GT+ go _ _ = error "cmp: Should never happen, leavesAndCollisions includes non Leaf / Collision"++ leafCompare (L k v) (L k' v') = cmpk k k' `mappend` cmpv v v'++-- | Same as 'equal2' but doesn't compare the values.+equalKeys1 :: (k -> k' -> Bool) -> HashMap k v -> HashMap k' v' -> Bool+equalKeys1 eq t1 t2 = go (leavesAndCollisions t1 []) (leavesAndCollisions t2 [])+ where+ go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2)+ | k1 == k2 && leafEq l1 l2+ = go tl1 tl2+ 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+ go _ _ = False++ leafEq (L k _) (L k' _) = eq k k'++-- | Same as 'equal1' but doesn't compare the values.+equalKeys :: Eq k => HashMap k v -> HashMap k v' -> Bool+equalKeys = go+ where+ go :: Eq k => HashMap k v -> HashMap k v' -> Bool+ go Empty Empty = True+ go (BitmapIndexed bm1 ary1) (BitmapIndexed bm2 ary2)+ = bm1 == bm2 && A.sameArray1 go ary1 ary2+ go (Leaf h1 l1) (Leaf h2 l2) = h1 == h2 && leafEq l1 l2+ go (Full ary1) (Full ary2) = A.sameArray1 go ary1 ary2+ go (Collision h1 ary1) (Collision h2 ary2)+ = h1 == h2 && isPermutationBy leafEq (A.toList ary1) (A.toList ary2)+ go _ _ = False++ leafEq (L k1 _) (L k2 _) = k1 == k2++instance Hashable2 HashMap where+ liftHashWithSalt2 hk hv salt hm = go salt (leavesAndCollisions hm [])+ where+ -- go :: Int -> [HashMap k v] -> Int+ go s [] = s+ go s (Leaf _ l : tl)+ = s `hashLeafWithSalt` l `go` tl+ -- For collisions we hashmix hash value+ -- and then array of values' hashes sorted+ go s (Collision h a : tl)+ = (s `H.hashWithSalt` h) `hashCollisionWithSalt` a `go` tl+ go s (_ : tl) = s `go` tl++ -- hashLeafWithSalt :: Int -> Leaf k v -> Int+ hashLeafWithSalt s (L k v) = (s `hk` k) `hv` v++ -- hashCollisionWithSalt :: Int -> A.Array (Leaf k v) -> Int+ hashCollisionWithSalt s+ = List.foldl' H.hashWithSalt s . arrayHashesSorted s++ -- arrayHashesSorted :: Int -> A.Array (Leaf k v) -> [Int]+ arrayHashesSorted s = List.sort . List.map (hashLeafWithSalt s) . A.toList++instance (Hashable k) => Hashable1 (HashMap k) where+ liftHashWithSalt = H.liftHashWithSalt2 H.hashWithSalt++instance (Hashable k, Hashable v) => Hashable (HashMap k v) where+ hashWithSalt salt hm = go salt hm+ where+ go :: Int -> HashMap k v -> Int+ go !s Empty = s+ go s (BitmapIndexed _ a) = A.foldl' go s a+ go s (Leaf h (L _ v))+ = s `H.hashWithSalt` h `H.hashWithSalt` v+ -- For collisions we hashmix hash value+ -- and then array of values' hashes sorted+ go s (Full a) = A.foldl' go s a+ go s (Collision h a)+ = (s `H.hashWithSalt` h) `hashCollisionWithSalt` a++ hashLeafWithSalt :: Int -> Leaf k v -> Int+ hashLeafWithSalt s (L k v) = s `H.hashWithSalt` k `H.hashWithSalt` v++ hashCollisionWithSalt :: Int -> A.Array (Leaf k v) -> Int+ hashCollisionWithSalt s+ = List.foldl' H.hashWithSalt s . arrayHashesSorted s++ arrayHashesSorted :: Int -> A.Array (Leaf k v) -> [Int]+ arrayHashesSorted s = List.sort . List.map (hashLeafWithSalt s) . A.toList++-- | Helper to get 'Leaf's and 'Collision's as a list.+leavesAndCollisions :: HashMap k v -> [HashMap k v] -> [HashMap k v]+leavesAndCollisions (BitmapIndexed _ ary) a = A.foldr leavesAndCollisions a ary+leavesAndCollisions (Full ary) a = A.foldr leavesAndCollisions a ary+leavesAndCollisions l@(Leaf _ _) a = l : a+leavesAndCollisions c@(Collision _ _) a = c : a+leavesAndCollisions Empty a = a++-- | Helper function to detect 'Leaf's and 'Collision's.+isLeafOrCollision :: HashMap k v -> Bool+isLeafOrCollision (Leaf _ _) = True+isLeafOrCollision (Collision _ _) = True+isLeafOrCollision _ = False++------------------------------------------------------------------------+-- * Construction++-- | \(O(1)\) Construct an empty map.+empty :: HashMap k v+empty = Empty++-- | \(O(1)\) Construct a map with a single element.+singleton :: (Hashable k) => k -> v -> HashMap k v+singleton k v = Leaf (hash k) (L k v)++------------------------------------------------------------------------+-- * Basic interface++-- | \(O(1)\) Return 'True' if this map is empty, 'False' otherwise.+null :: HashMap k v -> Bool+null Empty = True+null _ = False++-- | \(O(n)\) Return the number of key-value mappings in this map.+size :: HashMap k v -> Int+size t = go t 0+ where+ go Empty !n = n+ go (Leaf _ _) n = n + 1+ go (BitmapIndexed _ ary) n = A.foldl' (flip go) n ary+ go (Full ary) n = A.foldl' (flip go) n ary+ go (Collision _ ary) n = n + A.length ary++-- | \(O(\log n)\) Return 'True' if the specified key is present in the+-- map, 'False' otherwise.+member :: Hashable k => k -> HashMap k a -> Bool+member k m = case lookup k m of+ Nothing -> False+ Just _ -> True+{-# INLINABLE member #-}++-- | \(O(\log n)\) Return the value to which the specified key is mapped,+-- or 'Nothing' if this map contains no mapping for the key.+lookup :: Hashable k => k -> HashMap k v -> Maybe v+-- GHC does not yet perform a worker-wrapper transformation on+-- unboxed sums automatically. That seems likely to happen at some+-- point (possibly as early as GHC 8.6) but for now we do it manually.+lookup k m = case lookup# k m of+ (# (# #) | #) -> Nothing+ (# | a #) -> Just a+{-# INLINE lookup #-}++lookup# :: Hashable k => k -> HashMap k v -> (# (# #) | v #)+lookup# k m = lookupCont (\_ -> (# (# #) | #)) (\v _i -> (# | v #)) (hash k) k 0 m+{-# INLINABLE lookup# #-}++-- | lookup' is a version of lookup that takes the hash separately.+-- It is used to implement alterF.+lookup' :: Eq k => Hash -> k -> HashMap k v -> Maybe v+-- GHC does not yet perform a worker-wrapper transformation on+-- unboxed sums automatically. That seems likely to happen at some+-- point (possibly as early as GHC 8.6) but for now we do it manually.+-- lookup' would probably prefer to be implemented in terms of its own+-- lookup'#, but it's not important enough and we don't want too much+-- code.+lookup' h k m = case lookupRecordCollision# h k m of+ (# (# #) | #) -> Nothing+ (# | (# a, _i #) #) -> Just a+{-# INLINE lookup' #-}++-- | 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.+--+-- It is used by 'alterF' so that hash computation and key comparison only needs+-- to be performed once. With this information you can use the more optimized+-- versions of insert ('insertNewKey', 'insertKeyExists') and delete+-- ('deleteKeyExists')+--+-- Outcomes:+-- Key not in map => Absent+-- Key in map, no collision => Present v (-1)+-- Key in map, collision => Present v position+lookupRecordCollision :: Eq k => Hash -> k -> HashMap k v -> LookupRes v+lookupRecordCollision h k m = case lookupRecordCollision# h k m of+ (# (# #) | #) -> Absent+ (# | (# a, i #) #) -> Present a (I# i) -- GHC will eliminate the I#+{-# INLINE lookupRecordCollision #-}++-- | Why do we produce an Int# instead of an Int? Unfortunately, GHC is not+-- yet any good at unboxing things *inside* products, let alone sums. That+-- may be changing in GHC 8.6 or so (there is some work in progress), but+-- for now we use Int# explicitly here. We don't need to push the Int#+-- into lookupCont because inlining takes care of that.+lookupRecordCollision# :: Eq k => Hash -> k -> HashMap k v -> (# (# #) | (# v, Int# #) #)+lookupRecordCollision# h k m =+ lookupCont (\_ -> (# (# #) | #)) (\v (I# i) -> (# | (# v, i #) #)) h k 0 m+-- INLINABLE to specialize to the Eq instance.+{-# INLINABLE lookupRecordCollision# #-}++-- | A two-continuation version of lookupRecordCollision. This lets us+-- share source code between lookup and lookupRecordCollision without+-- risking any performance degradation.+--+-- The absent continuation has type @((# #) -> r)@ instead of just @r@+-- so we can be representation-polymorphic in the result type. Since+-- this whole thing is always inlined, we don't have to worry about+-- any extra CPS overhead.+lookupCont ::+#if defined(__GLASGOW_HASKELL__)+ forall rep (r :: TYPE rep) k v.+#else+ forall r k v.+#endif+ Eq k+ => ((# #) -> r) -- Absent continuation+ -> (v -> Int -> r) -- Present continuation+ -> Hash -- The hash of the key+ -> k+ -> Shift+ -> HashMap k v -> r+lookupCont absent present !h0 !k0 !s0 m0 = lookupCont_ h0 k0 s0 m0+ where+ lookupCont_ :: Eq k => Hash -> k -> Shift -> HashMap k v -> r+ lookupCont_ !_ !_ !_ Empty = absent (# #)+ lookupCont_ h k _ (Leaf hx (L kx x))+ | h == hx && k == kx = present x (-1)+ | otherwise = absent (# #)+ lookupCont_ h k s (BitmapIndexed b v)+ | b .&. m == 0 = absent (# #)+ | otherwise =+ case A.index# v (sparseIndex b m) of+ (# st #) -> lookupCont_ h k (nextShift s) st+ where m = mask h s+ lookupCont_ h k s (Full v) =+ case A.index# v (index h s) of+ (# st #) -> lookupCont_ h k (nextShift s) st+ lookupCont_ h k _ (Collision hx v)+ | h == hx = lookupInArrayCont absent present k v+ | otherwise = absent (# #)+{-# INLINE lookupCont #-}++-- | \(O(\log n)\) Return the value to which the specified key is mapped,+-- or 'Nothing' if this map contains no mapping for the key.+--+-- This is a flipped version of 'lookup'.+--+-- @since 0.2.11+(!?) :: Hashable k => HashMap k v -> k -> Maybe v+(!?) m k = lookup k m+{-# INLINE (!?) #-}+++-- | \(O(\log n)\) Return the value to which the specified key is mapped,+-- or the default value if this map contains no mapping for the key.+--+-- @since 0.2.11+findWithDefault :: Hashable k+ => v -- ^ Default value to return.+ -> k -> HashMap k v -> v+findWithDefault def k t = case lookup k t of+ Just v -> v+ _ -> def+{-# INLINABLE findWithDefault #-}+++-- | \(O(\log n)\) Return the value to which the specified key is mapped,+-- or the default value if this map contains no mapping for the key.+--+-- DEPRECATED: lookupDefault is deprecated as of version 0.2.11, replaced+-- by 'findWithDefault'.+lookupDefault :: Hashable k+ => v -- ^ Default value to return.+ -> k -> HashMap k v -> v+lookupDefault = findWithDefault+{-# INLINE lookupDefault #-}++-- | \(O(\log n)\) Return the value to which the specified key is mapped.+-- Calls 'error' if this map contains no mapping for the key.+(!) :: (Hashable k, HasCallStack) => HashMap k v -> k -> v+(!) m k = case lookup k m of+ Just v -> v+ Nothing -> error "Data.HashMap.Internal.(!): key not found"+{-# INLINABLE (!) #-}++infixl 9 !++-- | \(O(\log n)\) For a given key, return the equal key stored in the map,+-- if present, otherwise return 'Nothing'.+--+-- This function can be used for /interning/, i.e. to reduce memory usage.+--+-- @since 0.2.21+lookupKey :: Hashable k => k -> HashMap k v -> Maybe k+lookupKey k = \m -> fromMaybe# (lookupKeyInSubtree# 0 (hash k) k m)+ where+ fromMaybe# (# (##) | #) = Nothing+ fromMaybe# (# | a #) = Just a+{-# INLINE lookupKey #-}++lookupKeyInSubtree# :: Eq k => Shift -> Hash -> k -> HashMap k v -> (# (##) | k #)+lookupKeyInSubtree# !s !hx kx = \case+ Empty -> (# (##) | #)+ Leaf hy (L ky _)+ | hx == hy && kx == ky -> (# | ky #)+ | otherwise -> (# (##) | #)+ BitmapIndexed b ary+ | m .&. b == 0 -> (# (##) | #)+ | otherwise -> case A.index# ary i of+ (# st #) -> lookupKeyInSubtree# (nextShift s) hx kx st+ where+ m = mask hx s+ i = sparseIndex b m+ Full ary -> case A.index# ary (index hx s) of+ (# st #) -> lookupKeyInSubtree# (nextShift s) hx kx st+ Collision hy ary+ | hx == hy+ , Just i <- indexOf kx ary+ , (# L ky _ #) <- A.index# ary i+ -> (# | ky #)+ | otherwise -> (# (##) | #)+{-# INLINABLE lookupKeyInSubtree# #-}++-- | Create a 'Collision' value with two 'Leaf' values.+collision :: Hash -> Leaf k v -> Leaf k v -> HashMap k v+collision h !e1 !e2 =+ let v = A.run $ do mary <- A.new 2 e1+ A.write mary 1 e2+ return mary+ in Collision h v+{-# INLINE collision #-}++-- | Create a 'BitmapIndexed' or 'Full' node.+bitmapIndexedOrFull :: Bitmap -> A.Array (HashMap k v) -> HashMap k v+-- The strictness in @ary@ helps achieve a nice code size reduction in+-- @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 == fullBitmap = Full ary+ | otherwise = BitmapIndexed b ary+{-# INLINE bitmapIndexedOrFull #-}++-- | \(O(\log n)\) Associate the specified value with the specified+-- key in this map. If this map previously contained a mapping for+-- the key, the old value is replaced.+insert :: Hashable k => k -> v -> HashMap k v -> HashMap k v+insert k v m = insert' (hash k) k v m+{-# INLINABLE insert #-}++insert' :: Eq k => Hash -> k -> v -> HashMap k v -> HashMap k v+insert' h0 k0 v0 m0 = go h0 k0 v0 0 m0+ where+ go !h !k x !_ Empty = Leaf h (L k x)+ go h k x s t@(Leaf hy l@(L ky y))+ | hy == h = if ky == k+ then if x `ptrEq` y+ then t+ else Leaf h (L k x)+ else collision h l (L k x)+ | otherwise = runST (two s h k x hy t)+ go h k x s t@(BitmapIndexed b ary)+ | b .&. m == 0 =+ let !ary' = A.insert ary i $! Leaf h (L k x)+ in bitmapIndexedOrFull (b .|. m) ary'+ | otherwise =+ case A.index# ary i of+ (# !st #) ->+ let !st' = go h k x (nextShift s) st+ in if st' `ptrEq` st+ then t+ else BitmapIndexed b (A.update ary i st')+ where m = mask h s+ i = sparseIndex b m+ go h k x s t@(Full ary) =+ case A.index# ary i of+ (# !st #) ->+ let !st' = go h k x (nextShift s) st+ in if st' `ptrEq` st+ then t+ else Full (updateFullArray ary i st')+ where i = index h s+ go h k x s t@(Collision hy v)+ | h == hy = Collision h (updateOrSnocWith (\a _ -> (# a #)) k x v)+ | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)+{-# INLINABLE insert' #-}++-- | Insert optimized for the case when we know the key is not in the map.+--+-- It is only valid to call this when the key does not exist in the map.+--+-- We can skip:+-- - the key equality check on a Leaf+-- - check for its existence in the array for a hash collision+insertNewKey :: Hash -> k -> v -> HashMap k v -> HashMap k v+insertNewKey !h0 !k0 x0 m0 = go h0 k0 x0 0 m0+ where+ go !h !k x !_ Empty = Leaf h (L k x)+ go h k x s t@(Leaf hy l)+ | hy == h = collision h l (L k x)+ | otherwise = runST (two s h k x hy t)+ go 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 =+ case A.index# ary i of+ (# st #) ->+ let !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) =+ case A.index# ary i of+ (# st #) ->+ let !st' = go h k x (nextShift s) st+ in Full (updateFullArray ary i st')+ where i = index h s+ go h k x s t@(Collision hy v)+ | h == hy = Collision h (A.snoc v (L k x))+ | otherwise =+ go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)+{-# NOINLINE insertNewKey #-}+++-- | Insert optimized for the case when we know the key is in the map.+--+-- 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+-- (first argument).+insertKeyExists :: Int -> Hash -> k -> v -> HashMap k v -> HashMap k v+insertKeyExists !collPos0 !h0 !k0 x0 m0 = go collPos0 h0 k0 x0 m0+ where+ go !_collPos !_shiftedHash !k x (Leaf h _kx)+ = Leaf h (L k x)+ go collPos shiftedHash k x (BitmapIndexed b ary)+ = case A.index# ary i of+ (# st #) ->+ let !st' = go collPos (nextSH shiftedHash) k x st+ in BitmapIndexed b (A.update ary i st')+ where m = maskSH shiftedHash+ i = sparseIndex b m+ go collPos shiftedHash k x (Full ary)+ = case A.index# ary i of+ (# st #) ->+ let !st' = go collPos (nextSH shiftedHash) k x st+ in Full (updateFullArray ary i st')+ where i = indexSH 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"+{-# NOINLINE insertKeyExists #-}++-- | Replace the ith Leaf with Leaf k v.+--+-- This does not check that @i@ is within bounds of the array.+setAtPosition :: Int -> k -> v -> A.Array (Leaf k v) -> A.Array (Leaf k v)+setAtPosition i k x ary = A.update ary i (L k x)+{-# INLINE setAtPosition #-}+++-- | In-place update version of insert+unsafeInsert :: forall k v. Hashable k => k -> v -> HashMap k v -> HashMap k v+unsafeInsert k0 v0 m0 = runST (go h0 k0 v0 0 m0)+ where+ h0 = hash k0+ go :: forall s. Hash -> k -> v -> Shift -> HashMap k v -> ST s (HashMap k v)+ go !h !k x !_ Empty = return $! Leaf h (L k x)+ go h k x s t@(Leaf hy l@(L ky y))+ | hy == h = if ky == k+ then if x `ptrEq` y+ then return t+ else return $! Leaf h (L k x)+ else return $! collision h l (L k x)+ | otherwise = two s h k x hy t+ go h k x s t@(BitmapIndexed b ary)+ | b .&. m == 0 = do+ ary' <- A.insertM ary i $! Leaf h (L k x)+ return $! bitmapIndexedOrFull (b .|. m) ary'+ | otherwise = do+ st <- A.indexM ary i+ 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 (nextShift s) st+ A.unsafeUpdateM ary i st'+ return t+ where i = index h s+ go h k x s t@(Collision hy v)+ | h == hy = return $! Collision h (updateOrSnocWith (\a _ -> (# a #)) k x v)+ | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)+{-# INLINABLE unsafeInsert #-}++-- | Create a map from two key-value pairs which hashes don't collide. To+-- enhance sharing, the second key-value pair is represented by the hash of its+-- key and a singleton HashMap pairing its key with its value.+--+-- Note: to avoid silly thunks, this function must be strict in the+-- key. See issue #232. We don't need to force the HashMap argument+-- because it's already in WHNF (having just been matched) and we+-- just put it directly in an array.+two :: Shift -> Hash -> k -> v -> Hash -> HashMap k v -> ST s (HashMap k v)+two = go+ where+ go s h1 k1 v1 h2 t2+ | bp1 == bp2 = do+ st <- go (nextShift s) h1 k1 v1 h2 t2+ ary <- A.singletonM st+ return $ BitmapIndexed bp1 ary+ | otherwise = do+ mary <- A.new 2 $! Leaf h1 (L k1 v1)+ A.write mary idx2 t2+ ary <- A.unsafeFreeze mary+ return $ BitmapIndexed (bp1 .|. bp2) ary+ where+ bp1 = mask h1 s+ bp2 = mask h2 s+ !(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+-- this map previously contained a mapping for the key, the old value+-- is replaced by the result of applying the given function to the new+-- and old value. Example:+--+-- > insertWith f k v map+-- > where f new old = new + old+insertWith :: Hashable k => (v -> v -> v) -> k -> v -> HashMap k v+ -> HashMap k v+-- We're not going to worry about allocating a function closure+-- to pass to insertModifying. See comments at 'adjust'.+insertWith f k new m = insertModifying new (\old -> (# f new old #)) k m+{-# INLINE insertWith #-}++-- | @insertModifying@ is a lot like insertWith; we use it to implement alterF.+-- It takes a value to insert when the key is absent and a function+-- to apply to calculate a new value when the key is present. Thanks+-- to the unboxed unary tuple, we avoid introducing any unnecessary+-- thunks in the tree.+insertModifying :: Hashable k => v -> (v -> (# v #)) -> k -> HashMap k v+ -> HashMap k v+insertModifying x f k0 m0 = go h0 k0 0 m0+ where+ !h0 = hash k0+ go !h !k !_ Empty = Leaf h (L k x)+ go h k s t@(Leaf hy l@(L ky y))+ | hy == h = if ky == k+ then case f y of+ (# v' #) | ptrEq y v' -> t+ | otherwise -> Leaf h (L k v')+ else collision h l (L k x)+ | otherwise = runST (two s h k x hy t)+ go h k s t@(BitmapIndexed b ary)+ | b .&. m == 0 =+ let ary' = A.insert ary i $! Leaf h (L k x)+ in bitmapIndexedOrFull (b .|. m) ary'+ | otherwise =+ case A.index# ary i of+ (# !st #) ->+ let !st' = go h k (nextShift s) st+ ary' = A.update ary i st'+ in if ptrEq st st'+ then t+ else BitmapIndexed b ary'+ where m = mask h s+ i = sparseIndex b m+ go h k s t@(Full ary) =+ case A.index# ary i of+ (# !st #) ->+ let !st' = go h k (nextShift s) st+ ary' = updateFullArray ary i st'+ in if ptrEq st st'+ then t+ else Full ary'+ where i = index h s+ go h k s t@(Collision hy v)+ | h == hy =+ let !v' = insertModifyingArr x f k v+ in if A.unsafeSameArray v v'+ then t+ else Collision h v'+ | otherwise = go h k s $ BitmapIndexed (mask hy s) (A.singleton t)+{-# INLINABLE insertModifying #-}++-- | Like insertModifying for arrays; used to implement insertModifying+insertModifyingArr :: Eq k => v -> (v -> (# v #)) -> k -> A.Array (Leaf k v)+ -> A.Array (Leaf k v)+insertModifyingArr x f k0 ary0 = go k0 ary0 0 (A.length ary0)+ where+ go !k !ary !i !n+ -- Not found, append to the end.+ | i >= n = A.snoc ary $ L k x+ | otherwise = case A.index# ary i of+ (# L kx y #)+ | k == kx ->+ case f y of+ (# y' #) -> if ptrEq y y'+ then ary+ else A.update ary i (L k y')+ | otherwise -> go k ary (i+1) n+{-# INLINE insertModifyingArr #-}++-- | In-place update version of insertWith+unsafeInsertWith :: forall k v. Hashable k+ => (v -> v -> v) -> k -> v -> HashMap k v+ -> HashMap k v+unsafeInsertWith f k0 v0 m0 = unsafeInsertWithKey (\_ a b -> (# f a b #)) k0 v0 m0+{-# INLINABLE unsafeInsertWith #-}++unsafeInsertWithKey :: forall k v. Hashable k+ => (k -> v -> v -> (# v #)) -> k -> v -> HashMap k v+ -> HashMap k v+unsafeInsertWithKey f k0 v0 m0 = runST (go h0 k0 v0 0 m0)+ where+ h0 = hash k0+ go :: Hash -> k -> v -> Shift -> HashMap k v -> ST s (HashMap k v)+ go !h !k x !_ Empty = return $! Leaf h (L k x)+ go h k x s t@(Leaf hy l@(L ky y))+ | hy == h = if ky == k+ then case f k x y of+ (# v #) -> return $! Leaf h (L k v)+ else return $! collision h l (L k x)+ | otherwise = two s h k x hy t+ go h k x s t@(BitmapIndexed b ary)+ | b .&. m == 0 = do+ ary' <- A.insertM ary i $! Leaf h (L k x)+ return $! bitmapIndexedOrFull (b .|. m) ary'+ | otherwise = do+ st <- A.indexM ary i+ 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 (nextShift s) st+ A.unsafeUpdateM ary i st'+ return t+ where i = index h s+ go h k x s t@(Collision hy v)+ | h == hy = return $! Collision h (updateOrSnocWithKey f k x v)+ | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)+{-# INLINABLE unsafeInsertWithKey #-}++-- | \(O(\log n)\) Remove the mapping for the specified key from this map+-- if present.+delete :: Hashable k => k -> HashMap k v -> HashMap k v+delete k = delete' (hash k) k+{-# INLINE delete #-}++delete' :: Eq k => Hash -> k -> HashMap k v -> HashMap k v+delete' = deleteFromSubtree 0+{-# INLINE delete' #-}++-- | This version of 'delete' can be used on a subtree when the+-- corresponding 'Shift' argument is supplied.+deleteFromSubtree :: Eq k => Shift -> Hash -> k -> HashMap k v -> HashMap k v+deleteFromSubtree !s !h !k = \case+ Empty -> Empty+ t@(Leaf hy (L ky _))+ | hy == h && ky == k -> Empty+ | otherwise -> t+ t@(BitmapIndexed b ary)+ | b .&. m == 0 -> t+ | otherwise -> case A.index# ary i of+ (# !st #) ->+ case deleteFromSubtree (nextShift s) h k st of+ Empty | A.length ary == 2+ , (# l #) <- A.index# ary (otherOfOneOrZero i)+ , isLeafOrCollision l+ -> l+ | otherwise+ -> BitmapIndexed (b .&. complement m) (A.delete ary i)+ st' | st' `ptrEq` st -> t+ | isLeafOrCollision st' && A.length ary == 1 -> st'+ | otherwise -> BitmapIndexed b (A.update ary i st')+ where m = mask h s+ i = sparseIndex b m+ t@(Full ary) ->+ case A.index# ary i of+ (# !st #) ->+ case deleteFromSubtree (nextShift s) h k st of+ Empty ->+ let ary' = A.delete ary i+ bm = fullBitmap .&. complement (1 `unsafeShiftL` i)+ in BitmapIndexed bm ary'+ st' | st' `ptrEq` st -> t+ | otherwise -> Full (updateFullArray ary i st')+ where i = index h s+ t@(Collision hy ary)+ | h == hy+ , Just i <- indexOf k ary+ -> if A.length ary == 2+ then case A.index# ary (otherOfOneOrZero i) of+ (# l #) -> Leaf h l+ else Collision h (A.delete ary i)+ | otherwise -> t+{-# INLINABLE deleteFromSubtree #-}++-- | Delete optimized for the case when we know the key is in the map.+--+-- 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.+deleteKeyExists :: Int -> Hash -> k -> HashMap k v -> HashMap k v+deleteKeyExists !collPos0 !h0 !k0 m0 = go collPos0 h0 k0 m0+ where+ go :: Int -> ShiftedHash -> k -> HashMap k v -> HashMap k v+ go !_collPos !_shiftedHash !_k (Leaf _ _) = Empty+ go collPos shiftedHash k (BitmapIndexed b ary) =+ case A.index# ary i of+ (# st #) -> case go collPos (nextSH shiftedHash) k st of+ Empty | A.length ary == 2+ , (# l #) <- A.index# ary (otherOfOneOrZero i)+ , isLeafOrCollision l+ -> l+ | otherwise+ -> BitmapIndexed (b .&. complement m) (A.delete ary i)+ st' | isLeafOrCollision st' && A.length ary == 1 -> st'+ | otherwise -> BitmapIndexed b (A.update ary i st')+ where m = maskSH shiftedHash+ i = sparseIndex b m+ go collPos shiftedHash k (Full ary) =+ case A.index# ary i of+ (# st #) -> case go collPos (nextSH shiftedHash) k st of+ Empty ->+ let ary' = A.delete ary i+ bm = fullBitmap .&. complement (1 `unsafeShiftL` i)+ in BitmapIndexed bm ary'+ st' -> Full (updateFullArray ary i st')+ where i = indexSH shiftedHash+ go collPos _shiftedHash _k (Collision h v)+ | A.length v == 2+ = case A.index# v (otherOfOneOrZero collPos) of+ (# l #) -> Leaf h l+ | otherwise = Collision h (A.delete v collPos)+ go !_ !_ !_ Empty = Empty -- error "Internal error: deleteKeyExists empty"+{-# NOINLINE deleteKeyExists #-}++-- | \(O(\log n)\) Adjust the value tied to a given key in this map only+-- if it is present. Otherwise, leave the map alone.+adjust :: Hashable k => (v -> v) -> k -> HashMap k v -> HashMap k v+-- This operation really likes to leak memory, so using this+-- indirect implementation shouldn't hurt much. Furthermore, it allows+-- GHC to avoid a leak when the function is lazy. In particular,+--+-- adjust (const x) k m+-- ==> adjust# (\v -> (# const x v #)) k m+-- ==> adjust# (\_ -> (# x #)) k m+adjust f k m = adjust# (\v -> (# f v #)) k m+{-# INLINE adjust #-}++-- | Much like 'adjust', but not inherently leaky.+adjust# :: Hashable k => (v -> (# v #)) -> k -> HashMap k v -> HashMap k v+adjust# f k0 m0 = go h0 k0 0 m0+ where+ h0 = hash k0+ go !_ !_ !_ Empty = Empty+ go h k _ t@(Leaf hy (L ky y))+ | hy == h && ky == k = case f y of+ (# y' #) | ptrEq y y' -> t+ | otherwise -> Leaf h (L k y')+ | otherwise = t+ go h k s t@(BitmapIndexed b ary)+ | b .&. m == 0 = t+ | otherwise =+ case A.index# ary i of+ (# !st #) ->+ let !st' = go h k (nextShift s) st+ ary' = A.update ary i st'+ in if ptrEq st st'+ then t+ else BitmapIndexed b ary'+ where m = mask h s+ i = sparseIndex b m+ go h k s t@(Full ary) =+ case A.index# ary i of+ (# !st #) ->+ let !st' = go h k (nextShift s) st+ ary' = updateFullArray ary i st'+ in if ptrEq st st'+ then t+ else Full ary'+ where i = index h s+ go h k _ t@(Collision hy v)+ | h == hy = let !v' = updateWith# f k v+ in if A.unsafeSameArray v v'+ then t+ else Collision h v'+ | otherwise = t+{-# INLINABLE adjust# #-}++-- | \(O(\log n)\) The expression @('update' f k map)@ updates the value @x@ at @k@+-- (if it is in the map). If @(f x)@ is 'Nothing', the element is deleted.+-- If it is @('Just' y)@, the key @k@ is bound to the new value @y@.+update :: Hashable k => (a -> Maybe a) -> k -> HashMap k a -> HashMap k a+update f = alter (>>= f)+{-# INLINABLE update #-}+++-- | \(O(\log n)\) The expression @('alter' f k map)@ alters the value @x@ at @k@, or+-- absence thereof.+--+-- 'alter' can be used to insert, delete, or update a value in a map. In short:+--+-- @+-- 'lookup' k ('alter' f k m) = f ('lookup' k m)+-- @+alter :: Hashable k => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v+alter f k 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+-- @k@, or absence thereof.+--+-- 'alterF' can be used to insert, delete, or update a value in a map.+--+-- Note: 'alterF' is a flipped version of the 'at' combinator from+-- <https://hackage.haskell.org/package/lens/docs/Control-Lens-At.html#v:at Control.Lens.At>.+--+-- @since 0.2.10+alterF :: (Functor f, Hashable k)+ => (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)+-- We only calculate the hash once, but unless this is rewritten+-- by rules we may test for key equality multiple times.+-- We force the value of the map for consistency with the rewritten+-- version; otherwise someone could tell the difference using a lazy+-- @f@ and a functor that is similar to Const but not actually Const.+alterF f = \ !k !m ->+ let+ !h = hash k+ mv = lookup' h k m+ in (<$> f mv) $ \case+ Nothing -> maybe m (const (delete' h k m)) mv+ Just v' -> insert' h k v' m++-- We unconditionally rewrite alterF in RULES, but we expose an+-- unfolding just in case it's used in some way that prevents the+-- rule from firing.+{-# INLINABLE [0] alterF #-}++-- | This is just a bottom value. See the comment on the "alterFWeird"+-- rule.+test_bottom :: a+test_bottom = error "Data.HashMap.alterF internal error: hit test_bottom"++-- | We use this as an error result in RULES to ensure we don't get+-- any useless CallStack nonsense.+bogus# :: (# #) -> (# a #)+bogus# _ = error "Data.HashMap.alterF internal error: hit bogus#"++{-# RULES+-- We probe the behavior of @f@ by applying it to Nothing and to+-- Just test_bottom. Based on the results, and how they relate to+-- each other, we choose the best implementation.++"alterFWeird" forall f. alterF f =+ alterFWeird (f Nothing) (f (Just test_bottom)) f++-- This rule covers situations where alterF is used to simply insert or+-- delete in Identity (most likely via Control.Lens.At). We recognize here+-- (through the repeated @x@ on the LHS) that+--+-- @f Nothing = f (Just bottom)@,+--+-- which guarantees that @f@ doesn't care what its argument is, so+-- we don't have to either.+--+-- Why only Identity? A variant of this rule is actually valid regardless of+-- the functor, but for some functors (e.g., []), it can lead to the+-- same keys being compared multiple times, which is bad if they're+-- ugly things like strings. This is unfortunate, since the rule is likely+-- a good idea for almost all realistic uses, but I don't like nasty+-- edge cases.+"alterFconstant" forall (f :: Maybe a -> Identity (Maybe a)) x.+ alterFWeird x x f = \ !k !m ->+ Identity (case runIdentity x of {Nothing -> delete k m; Just a -> insert k a m})++-- This rule handles the case where 'alterF' is used to do 'insertWith'-like+-- things. Whenever possible, GHC will get rid of the Maybe nonsense for us.+-- We delay this rule to stage 1 so alterFconstant has a chance to fire.+"alterFinsertWith" [1] forall (f :: Maybe a -> Identity (Maybe a)) x y.+ alterFWeird (coerce (Just x)) (coerce (Just y)) f =+ coerce (insertModifying x (\mold -> case runIdentity (f (Just mold)) of+ Nothing -> bogus# (# #)+ Just new -> (# new #)))++-- Handle the case where someone uses 'alterF' instead of 'adjust'. This+-- rule is kind of picky; it will only work if the function doesn't+-- do anything between case matching on the Maybe and producing a result.+"alterFadjust" forall (f :: Maybe a -> Identity (Maybe a)) _y.+ alterFWeird (coerce Nothing) (coerce (Just _y)) f =+ coerce (adjust# (\x -> case runIdentity (f (Just x)) of+ Just x' -> (# x' #)+ Nothing -> bogus# (# #)))++-- The simple specialization to Const; in this case we can look up+-- the key without caring what position it's in. This is only a tiny+-- optimization.+"alterFlookup" forall _ign1 _ign2 (f :: Maybe a -> Const r (Maybe a)).+ alterFWeird _ign1 _ign2 f = \ !k !m -> Const (getConst (f (lookup k m)))+ #-}++-- | This is a very unsafe version of alterF used for RULES. When calling+-- alterFWeird x y f, the following *must* hold:+--+-- x = f Nothing+-- y = f (Just _|_)+--+-- Failure to abide by these laws will make demons come out of your nose.+alterFWeird+ :: (Functor f, Hashable k)+ => f (Maybe v)+ -> f (Maybe v)+ -> (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)+alterFWeird _ _ f = alterFEager f+{-# INLINE [0] alterFWeird #-}++-- | This is the default version of alterF that we use in most non-trivial+-- cases. It's called "eager" because it looks up the given key in the map+-- eagerly, whether or not the given function requires that information.+alterFEager :: (Functor f, Hashable k)+ => (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)+alterFEager f !k m = (<$> f mv) $ \case++ ------------------------------+ -- Delete the key from the map.+ Nothing -> case lookupRes of++ -- Key did not exist in the map to begin with, no-op+ Absent -> m++ -- Key did exist+ Present _ collPos -> deleteKeyExists collPos h k m++ ------------------------------+ -- Update value+ Just v' -> case lookupRes of++ -- Key did not exist before, insert v' under a new key+ Absent -> insertNewKey h k v' m++ -- Key existed before+ Present v collPos ->+ if v `ptrEq` v'+ -- If the value is identical, no-op+ then m+ -- If the value changed, update the value.+ else insertKeyExists collPos h k v' m++ where !h = hash k+ !lookupRes = lookupRecordCollision h k m+ !mv = lookupResToMaybe lookupRes+{-# INLINABLE alterFEager #-}++-- | \(O(n \log m)\) Inclusion of maps. A map is included in another map if the keys+-- are subsets and the corresponding values are equal:+--+-- > isSubmapOf m1 m2 = keys m1 `isSubsetOf` keys m2 &&+-- > and [ v1 == v2 | (k1,v1) <- toList m1; let v2 = m2 ! k1 ]+--+-- ==== __Examples__+--+-- >>> fromList [(1,'a')] `isSubmapOf` fromList [(1,'a'),(2,'b')]+-- True+--+-- >>> fromList [(1,'a'),(2,'b')] `isSubmapOf` fromList [(1,'a')]+-- False+--+-- @since 0.2.12+isSubmapOf :: (Hashable k, Eq v) => HashMap k v -> HashMap k v -> Bool+isSubmapOf = Exts.inline isSubmapOfBy (==)+{-# INLINABLE isSubmapOf #-}++-- | \(O(n \log m)\) Inclusion of maps with value comparison. A map is included in+-- another map if the keys are subsets and if the comparison function is true+-- for the corresponding values:+--+-- > isSubmapOfBy cmpV m1 m2 = keys m1 `isSubsetOf` keys m2 &&+-- > and [ v1 `cmpV` v2 | (k1,v1) <- toList m1; let v2 = m2 ! k1 ]+--+-- ==== __Examples__+--+-- >>> isSubmapOfBy (<=) (fromList [(1,'a')]) (fromList [(1,'b'),(2,'c')])+-- True+--+-- >>> isSubmapOfBy (<=) (fromList [(1,'b')]) (fromList [(1,'a'),(2,'c')])+-- False+--+-- @since 0.2.12+isSubmapOfBy :: Hashable k => (v1 -> v2 -> Bool) -> HashMap k v1 -> HashMap k v2 -> Bool+-- For maps without collisions the complexity is O(n*log m), where n is the size+-- of m1 and m the size of m2: the inclusion operation visits every leaf in m1 at least once.+-- For each leaf in m1, it looks up the key in m2.+--+-- The worst case complexity is O(n*m). The worst case is when both hashmaps m1+-- and m2 are collision nodes for the same hash. Since collision nodes are+-- unsorted arrays, it requires for every key in m1 a linear search to to find a+-- matching key in m2, hence O(n*m).+isSubmapOfBy comp !m1 !m2 = go 0 m1 m2+ where+ -- An empty map is always a submap of any other map.+ go _ Empty _ = True++ -- If the second map is empty and the first is not, it cannot be a submap.+ go _ _ Empty = False++ -- If the first map contains only one entry, lookup the key in the second map.+ go s (Leaf h1 (L k1 v1)) t2 = lookupCont (\_ -> False) (\v2 _ -> comp v1 v2) h1 k1 s t2++ -- In this case, we need to check that for each x in ls1, there is a y in+ -- ls2 such that x `comp` y. This is the worst case complexity-wise since it+ -- requires a O(m*n) check.+ go _ (Collision h1 ls1) (Collision h2 ls2) =+ h1 == h2 && subsetArray comp ls1 ls2++ -- In this case, we only need to check the entries in ls2 with the hash h1.+ go s t1@(Collision h1 _) (BitmapIndexed b ls2)+ | b .&. m == 0 = False+ | otherwise =+ case A.index# ls2 (sparseIndex b m) of+ (# st2 #) -> go (nextShift s) t1 st2+ 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) =+ case A.index# ls2 (index h1 s) of+ (# st2 #) -> go (nextShift s) t1 st2++ -- 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 (nextShift s)) b1 ls1 b2 ls2+ go s (BitmapIndexed b1 ls1) (Full ls2) =+ submapBitmapIndexed (go (nextShift s)) b1 ls1 fullBitmap ls2+ go s (Full ls1) (Full 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.+ go _ (Collision {}) (Leaf {}) = False+ go _ (BitmapIndexed {}) (Leaf {}) = False+ go _ (Full {}) (Leaf {}) = False+ go _ (BitmapIndexed {}) (Collision {}) = False+ go _ (Full {}) (Collision {}) = False+ go _ (Full {}) (BitmapIndexed {}) = False+{-# INLINABLE isSubmapOfBy #-}++-- | \(O(\min n m))\) Checks if a bitmap indexed node is a submap of another.+submapBitmapIndexed :: (HashMap k v1 -> HashMap k v2 -> Bool) -> Bitmap -> A.Array (HashMap k v1) -> Bitmap -> A.Array (HashMap k v2) -> Bool+submapBitmapIndexed comp !b1 !ary1 !b2 !ary2 = subsetBitmaps && go 0 0 (b1Orb2 .&. negate b1Orb2)+ where+ go :: Int -> Int -> Bitmap -> Bool+ go !i !j !m++ -- Note: m can overflow to 0 when maxChildren == WORD_SIZE_IN_BITS. See+ -- #491. In that case there needs to be a check '| m == 0 = True'+ | m > b1Orb2 = True++ -- In case a key is both in ary1 and ary2, check ary1[i] <= ary2[j] and+ -- increment the indices i and j.+ | b1Andb2 .&. m /= 0+ , (# st1 #) <- A.index# ary1 i+ , (# st2 #) <- A.index# ary2 j+ = comp st1 st2 && go (i+1) (j+1) (m `unsafeShiftL` 1)++ -- In case a key occurs in ary1, but not ary2, only increment index j.+ | b2 .&. m /= 0 = go i (j+1) (m `unsafeShiftL` 1)++ -- In case a key neither occurs in ary1 nor ary2, continue.+ | otherwise = go i j (m `unsafeShiftL` 1)++ b1Andb2 = b1 .&. b2+ b1Orb2 = b1 .|. b2+ subsetBitmaps = b1Orb2 == b2+{-# INLINABLE submapBitmapIndexed #-}++------------------------------------------------------------------------+-- * Combine++-- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, the+-- mapping from the first will be the mapping in the result.+--+-- ==== __Examples__+--+-- >>> union (fromList [(1,'a'),(2,'b')]) (fromList [(2,'c'),(3,'d')])+-- fromList [(1,'a'),(2,'b'),(3,'d')]+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 => (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 => (k -> v -> v -> v) -> HashMap k v -> HashMap k v+ -> HashMap k v+unionWithKey f = go 0+ where+ -- empty vs. anything+ go !_ t1 Empty = t1+ go _ Empty t2 = t2+ -- leaf vs. leaf+ go s t1@(Leaf h1 l1@(L k1 v1)) t2@(Leaf h2 l2@(L k2 v2))+ | h1 == h2 = if k1 == k2+ then Leaf h1 (L k1 (f k1 v1 v2))+ else collision h1 l1 l2+ | otherwise = goDifferentHash s h1 h2 t1 t2+ go s t1@(Leaf h1 (L k1 v1)) t2@(Collision h2 ls2)+ | h1 == h2 = Collision h1 (updateOrSnocWithKey (\k a b -> (# f k a b #)) k1 v1 ls2)+ | otherwise = goDifferentHash s h1 h2 t1 t2+ go s t1@(Collision h1 ls1) t2@(Leaf h2 (L k2 v2))+ | h1 == h2 = Collision h1 (updateOrSnocWithKey (\k a b -> (# f k b a #)) k2 v2 ls1)+ | otherwise = goDifferentHash s h1 h2 t1 t2+ go s t1@(Collision h1 ls1) t2@(Collision h2 ls2)+ | h1 == h2 = Collision h1 (updateOrConcatWithKey (\k a b -> (# f k a b #)) ls1 ls2)+ | otherwise = goDifferentHash s h1 h2 t1 t2+ -- branch vs. branch+ go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) =+ let b' = b1 .|. b2+ ary' = unionArrayBy (go (nextShift s)) b1 b2 ary1 ary2+ in bitmapIndexedOrFull b' ary'+ go s (BitmapIndexed b1 ary1) (Full 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 (nextShift s)) fullBitmap b2 ary1 ary2+ in Full ary'+ go s (Full ary1) (Full ary2) =+ let ary' = unionArrayBy (go (nextShift s)) fullBitmap fullBitmap+ ary1 ary2+ in Full ary'+ -- leaf vs. branch+ go s (BitmapIndexed b1 ary1) t2+ | b1 .&. m2 == 0 = let ary' = A.insert ary1 i t2+ b' = b1 .|. m2+ in bitmapIndexedOrFull b' ary'+ | otherwise = let ary' = A.updateWith' ary1 i $ \st1 ->+ go (nextShift s) st1 t2+ in BitmapIndexed b1 ary'+ where+ h2 = leafHashCode t2+ m2 = mask h2 s+ i = sparseIndex b1 m2+ go s t1 (BitmapIndexed b2 ary2)+ | b2 .&. m1 == 0 = let ary' = A.insert ary2 i $! t1+ b' = b2 .|. m1+ in bitmapIndexedOrFull b' ary'+ | otherwise = let ary' = A.updateWith' ary2 i $ \st2 ->+ go (nextShift s) t1 st2+ in BitmapIndexed b2 ary'+ where+ h1 = leafHashCode t1+ m1 = mask h1 s+ i = sparseIndex b2 m1+ go s (Full ary1) t2 =+ let h2 = leafHashCode t2+ i = index h2 s+ ary' = updateFullArrayWith' 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' = updateFullArrayWith' ary2 i $ \st2 -> go (nextShift s) t1 st2+ in Full ary'++ leafHashCode (Leaf h _) = h+ leafHashCode (Collision h _) = h+ leafHashCode _ = error "leafHashCode"++ goDifferentHash s 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+ m1 = mask h1 s+ m2 = mask h2 s+{-# INLINE unionWithKey #-}++-- | Strict in the result of @f@.+unionArrayBy :: (a -> a -> a) -> Bitmap -> Bitmap -> A.Array a -> A.Array a+ -> A.Array a+-- The manual forcing of @b1@, @b2@, @ary1@ and @ary2@ results in handsome+-- Core size reductions with GHC 9.2.2. See the Core diffs in+-- https://github.com/haskell-unordered-containers/unordered-containers/pull/376.+unionArrayBy f !b1 !b2 !ary1 !ary2 = A.run $ do+ let bCombined = b1 .|. b2+ mary <- A.new_ (popCount bCombined)+ -- iterate over nonzero bits of b1 .|. b2+ let go !i !i1 !i2 !b+ | b == 0 = return ()+ | testBit (b1 .&. b2) = do+ x1 <- A.indexM ary1 i1+ x2 <- A.indexM ary2 i2+ A.write mary i $! f x1 x2+ go (i+1) (i1+1) (i2+1) b'+ | testBit b1 = do+ A.write mary i =<< A.indexM ary1 i1+ go (i+1) (i1+1) i2 b'+ | otherwise = do+ A.write mary i =<< A.indexM ary2 i2+ go (i+1) i1 (i2+1) b'+ where+ m = 1 `unsafeShiftL` countTrailingZeros b+ testBit x = x .&. m /= 0+ b' = b .&. complement m+ go 0 0 0 bCombined+ return mary+ -- TODO: For the case where b1 .&. b2 == b1, i.e. when one is a+ -- subset of the other, we could use a slightly simpler algorithm,+ -- where we copy one array, and then update.+{-# INLINE unionArrayBy #-}++-- TODO: Figure out the time complexity of 'unions'.++-- | Construct a set containing all elements from a list of sets.+unions :: Eq k => [HashMap k v] -> HashMap k v+unions = List.foldl' union empty+{-# INLINE unions #-}+++------------------------------------------------------------------------+-- * Compose++-- | Given maps @bc@ and @ab@, relate the keys of @ab@ to the values of @bc@,+-- by using the values of @ab@ as keys for lookups in @bc@.+--+-- Complexity: \( O (n * \log(m)) \), where \(m\) is the size of the first argument+--+-- >>> compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')])+-- fromList [(1,"A"),(2,"B")]+--+-- @+-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')+-- @+--+-- @since 0.2.13.0+compose :: Hashable b => HashMap b c -> HashMap a b -> HashMap a c+compose bc !ab+ | null bc = empty+ | otherwise = mapMaybe (bc !?) ab++------------------------------------------------------------------------+-- * Transformations++-- | \(O(n)\) Transform this map by applying a function to every value.+mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2+mapWithKey f = go+ where+ go Empty = Empty+ go (Leaf h (L k v)) = Leaf h $ L k (f k v)+ go (BitmapIndexed b ary) = BitmapIndexed b $ A.map go ary+ go (Full ary) = Full $ A.map go ary+ -- Why map strictly over collision arrays? Because there's no+ -- point suspending the O(1) work this does for each leaf.+ go (Collision h ary) = Collision h $+ A.map' (\ (L k v) -> L k (f k v)) ary+{-# INLINE mapWithKey #-}++-- | \(O(n)\) Transform this map by applying a function to every value.+map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2+map f = mapWithKey (const f)+{-# INLINE map #-}++-- | \(O(n)\) Perform an 'Applicative' action for each key-value pair+-- in a 'HashMap' and produce a 'HashMap' of all the results.+--+-- Note: the order in which the actions occur is unspecified. In particular,+-- when the map contains hash collisions, the order in which the actions+-- associated with the keys involved will depend in an unspecified way on+-- their insertion order.+traverseWithKey+ :: Applicative f+ => (k -> v1 -> f v2)+ -> HashMap k v1 -> f (HashMap k v2)+traverseWithKey f = go+ where+ go Empty = pure Empty+ go (Leaf h (L k v)) = Leaf h . L k <$> f k v+ go (BitmapIndexed b ary) = BitmapIndexed b <$> A.traverse go ary+ go (Full ary) = Full <$> A.traverse go ary+ go (Collision h ary) =+ Collision h <$> A.traverse' (\ (L k v) -> L k <$> f k v) ary+{-# INLINE traverseWithKey #-}++-- | \(O(n)\).+-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case there is no guarantee which of the+-- associated values is chosen for the conflicting key.+--+-- >>> mapKeys (+ 1) (fromList [(5,"a"), (3,"b")])+-- fromList [(4,"b"),(6,"a")]+-- >>> mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")])+-- fromList [(1,"c")]+-- >>> mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")])+-- fromList [(3,"c")]+--+-- @since 0.2.14.0+mapKeys :: Hashable k2 => (k1 -> k2) -> HashMap k1 v -> HashMap k2 v+mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []++------------------------------------------------------------------------+-- * Difference and intersection++-- | \(O(n \log m)\) Difference of two maps. Return elements of the first map+-- not existing in the second.+difference :: Hashable k => HashMap k v -> HashMap k w -> HashMap k v+difference = go_difference 0+ where+ go_difference !_s Empty _ = Empty+ go_difference s t1@(Leaf h1 (L k1 _)) t2+ = lookupCont (\_ -> t1) (\_ _ -> Empty) h1 k1 s t2+ go_difference _ t1 Empty = t1+ go_difference s t1 (Leaf h2 (L k2 _)) = deleteFromSubtree s h2 k2 t1++ go_difference s t1@(BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2)+ = differenceArrays s b1 ary1 t1 b2 ary2+ go_difference s t1@(Full ary1) (BitmapIndexed b2 ary2)+ = differenceArrays s fullBitmap ary1 t1 b2 ary2+ go_difference s t1@(BitmapIndexed b1 ary1) (Full ary2)+ = differenceArrays s b1 ary1 t1 fullBitmap ary2+ go_difference s t1@(Full ary1) (Full ary2)+ = differenceArrays s fullBitmap ary1 t1 fullBitmap ary2++ go_difference s t1@(Collision h1 _) (BitmapIndexed b2 ary2)+ | b2 .&. m == 0 = t1+ | otherwise =+ case A.index# ary2 (sparseIndex b2 m) of+ (# st2 #) -> go_difference (nextShift s) t1 st2+ where m = mask h1 s+ go_difference s t1@(Collision h1 _) (Full ary2)+ = case A.index# ary2 (index h1 s) of+ (# st2 #) -> go_difference (nextShift s) t1 st2++ go_difference s t1@(BitmapIndexed b1 ary1) t2@(Collision h2 _)+ | b1 .&. m == 0 = t1+ | otherwise =+ case A.index# ary1 i1 of+ (# !st #) ->+ case go_difference (nextShift s) st t2 of+ Empty | A.length ary1 == 2+ , (# l #) <- A.index# ary1 (otherOfOneOrZero i1)+ , isLeafOrCollision l+ -> l+ | otherwise+ -> BitmapIndexed (b1 .&. complement m) (A.delete ary1 i1)+ st' | isLeafOrCollision st' && A.length ary1 == 1 -> st'+ | st `ptrEq` st' -> t1+ | otherwise -> BitmapIndexed b1 (A.update ary1 i1 st')+ where+ m = mask h2 s+ i1 = sparseIndex b1 m+ go_difference s t1@(Full ary1) t2@(Collision h2 _)+ = case A.index# ary1 i of+ (# !st #) -> case go_difference (nextShift s) st t2 of+ Empty ->+ let ary1' = A.delete ary1 i+ bm = fullBitmap .&. complement (1 `unsafeShiftL` i)+ in BitmapIndexed bm ary1'+ st' | st `ptrEq` st' -> t1+ | otherwise -> Full (updateFullArray ary1 i st')+ where i = index h2 s++ go_difference _ t1@(Collision h1 ary1) (Collision h2 ary2)+ = differenceCollisions h1 ary1 t1 h2 ary2++ -- TODO: If we keep 'Full' (#399), differenceArrays could be optimized for+ -- each combination of 'Full' and 'BitmapIndexed`.+ differenceArrays !s !b1 !ary1 t1 !b2 !ary2+ | b1 .&. b2 == 0 = t1+ | A.unsafeSameArray ary1 ary2 = Empty+ | otherwise = runST $ do+ mary <- A.new_ $ A.length ary1+ + -- TODO: i == popCount bResult. Not sure if that would be faster.+ -- Also i1 is in some relation with b1'+ let goDA !i !i1 !b1' !bResult !nChanges+ | b1' == 0 = pure (bResult, nChanges)+ | otherwise = do+ !st1 <- A.indexM ary1 i1+ case m .&. b2 of+ 0 -> do+ A.write mary i st1+ goDA (i + 1) (i1 + 1) nextB1' (bResult .|. m) nChanges+ _ -> do+ !st2 <- A.indexM ary2 (sparseIndex b2 m)+ case go_difference (nextShift s) st1 st2 of+ Empty -> goDA i (i1 + 1) nextB1' bResult (nChanges + 1)+ st -> do+ A.write mary i st+ let same = I# (Exts.reallyUnsafePtrEquality# st st1)+ let nChanges' = nChanges + (1 - same)+ goDA (i + 1) (i1 + 1) nextB1' (bResult .|. m) nChanges'+ where+ m = b1' .&. negate b1'+ nextB1' = b1' .&. complement m+ + (bResult, nChanges) <- goDA 0 0 b1 0 0+ if nChanges == 0+ then pure t1+ else case popCount bResult of+ 0 -> pure Empty+ 1 -> do+ l <- A.read mary 0+ if isLeafOrCollision l+ then pure l+ else BitmapIndexed bResult <$> (A.unsafeFreeze =<< A.shrink mary 1)+ n -> bitmapIndexedOrFull bResult <$> (A.unsafeFreeze =<< A.shrink mary n)+{-# INLINABLE difference #-}++-- TODO: This could be faster if we would keep track of which elements of ary2+-- we've already matched. Those could be skipped when we check the following+-- elements of ary1.+differenceCollisions :: Eq k => Hash -> A.Array (Leaf k v1) -> HashMap k v1 -> Hash -> A.Array (Leaf k v2) -> HashMap k v1+differenceCollisions !h1 !ary1 t1 !h2 !ary2+ | h1 == h2 =+ if A.unsafeSameArray ary1 ary2+ then Empty+ else let ary = A.filter (\(L k1 _) -> isNothing (indexOf k1 ary2)) ary1+ in case A.length ary of+ 0 -> Empty+ 1 -> case A.index# ary 0 of+ (# l #) -> Leaf h1 l+ n | A.length ary1 == n -> t1+ | otherwise -> Collision h1 ary+ | otherwise = t1+{-# INLINABLE differenceCollisions #-}++-- | \(O(n \log m)\) Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+differenceWith :: Hashable k => (v -> w -> Maybe v) -> HashMap k v -> HashMap k w -> HashMap k v+differenceWith f = differenceWithKey (const f)+{-# INLINE differenceWith #-}++-- | \(O(n \log m)\) Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- @since 0.2.21+differenceWithKey :: Eq k => (k -> v -> w -> Maybe v) -> HashMap k v -> HashMap k w -> HashMap k v+differenceWithKey f = go_differenceWithKey 0+ where+ go_differenceWithKey !_s Empty _tB = Empty+ go_differenceWithKey _s a Empty = a+ go_differenceWithKey s a@(Leaf hA (L kA vA)) b+ = lookupCont+ (\_ -> a)+ (\vB _ -> case f kA vA vB of+ Nothing -> Empty+ Just v | v `ptrEq` vA -> a+ | otherwise -> Leaf hA (L kA v))+ hA kA s b+ go_differenceWithKey _s a@(Collision hA aryA) (Leaf hB (L kB vB))+ | hA == hB = updateCollision (\vA -> f kB vA vB) hA kB aryA a+ | otherwise = a+ go_differenceWithKey s a@(BitmapIndexed bA aryA) b@(Leaf hB _)+ | bA .&. m == 0 = a+ | otherwise = case A.index# aryA i of+ (# !stA #) -> case go_differenceWithKey (nextShift s) stA b of+ Empty | A.length aryA == 2+ , (# l #) <- A.index# aryA (otherOfOneOrZero i)+ , isLeafOrCollision l+ -> l+ | otherwise+ -> BitmapIndexed (bA .&. complement m) (A.delete aryA i)+ stA' | isLeafOrCollision stA' && A.length aryA == 1 -> stA'+ | stA `ptrEq` stA' -> a+ | otherwise -> BitmapIndexed bA (A.update aryA i stA')+ where+ m = mask hB s+ i = sparseIndex bA m+ go_differenceWithKey s a@(BitmapIndexed bA aryA) b@(Collision hB _)+ | bA .&. m == 0 = a+ | otherwise =+ case A.index# aryA i of+ (# !st #) -> case go_differenceWithKey (nextShift s) st b of+ Empty | A.length aryA == 2+ , (# l #) <- A.index# aryA (otherOfOneOrZero i)+ , isLeafOrCollision l+ -> l+ | otherwise+ -> BitmapIndexed (bA .&. complement m) (A.delete aryA i)+ st' | isLeafOrCollision st' && A.length aryA == 1 -> st'+ | st `ptrEq` st' -> a+ | otherwise -> BitmapIndexed bA (A.update aryA i st')+ where+ m = mask hB s+ i = sparseIndex bA m+ go_differenceWithKey s a@(Full aryA) b@(Leaf hB _)+ = case A.index# aryA i of+ (# !stA #) -> case go_differenceWithKey (nextShift s) stA b of+ Empty ->+ let aryA' = A.delete aryA i+ bm = fullBitmap .&. complement (1 `unsafeShiftL` i)+ in BitmapIndexed bm aryA'+ stA' | stA `ptrEq` stA' -> a+ | otherwise -> Full (updateFullArray aryA i stA')+ where i = index hB s+ go_differenceWithKey s a@(Full aryA) b@(Collision hB _)+ = case A.index# aryA i of+ (# !stA #) -> case go_differenceWithKey (nextShift s) stA b of+ Empty ->+ let aryA' = A.delete aryA i+ bm = fullBitmap .&. complement (1 `unsafeShiftL` i)+ in BitmapIndexed bm aryA'+ stA' | stA `ptrEq` stA' -> a+ | otherwise -> Full (updateFullArray aryA i stA')+ where i = index hB s+ go_differenceWithKey s a@(Collision hA _) (BitmapIndexed bB aryB)+ | bB .&. m == 0 = a+ | otherwise =+ case A.index# aryB (sparseIndex bB m) of+ (# stB #) -> go_differenceWithKey (nextShift s) a stB+ where m = mask hA s+ go_differenceWithKey s a@(Collision hA _) (Full aryB)+ = case A.index# aryB (index hA s) of+ (# stB #) -> go_differenceWithKey (nextShift s) a stB+ go_differenceWithKey s a@(BitmapIndexed bA aryA) (BitmapIndexed bB aryB)+ = differenceWithKey_Arrays s bA aryA a bB aryB+ go_differenceWithKey s a@(Full aryA) (BitmapIndexed bB aryB)+ = differenceWithKey_Arrays s fullBitmap aryA a bB aryB+ go_differenceWithKey s a@(BitmapIndexed bA aryA) (Full aryB)+ = differenceWithKey_Arrays s bA aryA a fullBitmap aryB+ go_differenceWithKey s a@(Full aryA) (Full aryB)+ = differenceWithKey_Arrays s fullBitmap aryA a fullBitmap aryB+ go_differenceWithKey _s a@(Collision hA aryA) (Collision hB aryB)+ = differenceWithKey_Collisions f hA aryA a hB aryB++ differenceWithKey_Arrays !s !bA !aryA tA !bB !aryB+ | bA .&. bB == 0 = tA+ | otherwise = runST $ do+ mary <- A.new_ $ A.length aryA++ -- TODO: i == popCount bResult. Not sure if that would be faster.+ -- Also iA is in some relation with bA'+ let go_dWKA !i !iA !bA' !bResult !nChanges+ | bA' == 0 = pure (bResult, nChanges)+ | otherwise = do+ !stA <- A.indexM aryA iA+ case m .&. bB of+ 0 -> do+ A.write mary i stA+ go_dWKA (i + 1) (iA + 1) nextBA' (bResult .|. m) nChanges+ _ -> do+ !stB <- A.indexM aryB (sparseIndex bB m)+ case go_differenceWithKey (nextShift s) stA stB of+ Empty -> go_dWKA i (iA + 1) nextBA' bResult (nChanges + 1)+ st -> do+ A.write mary i st+ let same = I# (Exts.reallyUnsafePtrEquality# st stA)+ let nChanges' = nChanges + (1 - same)+ go_dWKA (i + 1) (iA + 1) nextBA' (bResult .|. m) nChanges'+ where+ m = bA' .&. negate bA'+ nextBA' = bA' .&. complement m++ (bResult, nChanges) <- go_dWKA 0 0 bA 0 0+ if nChanges == 0+ then pure tA+ else case popCount bResult of+ 0 -> pure Empty+ 1 -> do+ l <- A.read mary 0+ if isLeafOrCollision l+ then pure l+ else BitmapIndexed bResult <$> (A.unsafeFreeze =<< A.shrink mary 1)+ n -> bitmapIndexedOrFull bResult <$> (A.unsafeFreeze =<< A.shrink mary n)+{-# INLINE differenceWithKey #-}++-- | 'update', specialized to 'Collision' nodes.+updateCollision+ :: Eq k+ => (v -> Maybe v)+ -> Hash+ -> k+ -> A.Array (Leaf k v)+ -> HashMap k v+ -- ^ The original Collision node which will be re-used if the array is unchanged.+ -> HashMap k v+updateCollision f !h k !ary orig =+ lookupInArrayCont+ (\_ -> orig)+ (\v i -> case f v of+ Nothing | A.length ary == 2+ , (# l #) <- A.index# ary (otherOfOneOrZero i)+ -> Leaf h l+ | otherwise -> Collision h (A.delete ary i)+ Just v' | v' `ptrEq` v -> orig+ | otherwise -> Collision h (A.update ary i (L k v')))+ k ary+{-# INLINABLE updateCollision #-}++-- TODO: This could be faster if we would keep track of which elements of ary2+-- we've already matched. Those could be skipped when we check the following+-- elements of ary1.+-- TODO: Return tA when the array is unchanged.+differenceWithKey_Collisions :: Eq k => (k -> v -> w -> Maybe v) -> Word -> A.Array (Leaf k v) -> HashMap k v -> Word -> A.Array (Leaf k w) -> HashMap k v+differenceWithKey_Collisions f !hA !aryA !tA !hB !aryB+ | hA == hB =+ let f' l@(L kA vA) =+ lookupInArrayCont+ (\_ -> Just l)+ (\vB _ -> L kA <$> f kA vA vB)+ kA aryB+ ary = A.mapMaybe f' aryA+ in case A.length ary of+ 0 -> Empty+ 1 -> case A.index# ary 0 of+ (# l #) -> Leaf hA l+ _ -> Collision hA ary+ | otherwise = tA+{-# INLINABLE differenceWithKey_Collisions #-}++-- | \(O(n \log m)\) Intersection of two maps. Return elements of the first+-- map for keys existing in the second.+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 => (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 => (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 #-}++intersectionWithKey# :: Eq k => (k -> v1 -> v2 -> (# v3 #)) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3+intersectionWithKey# f = go 0+ where+ -- empty vs. anything+ go !_ _ Empty = Empty+ go _ Empty _ = Empty+ -- leaf vs. anything+ go s (Leaf h1 (L k1 v1)) t2 =+ lookupCont+ (\_ -> Empty)+ (\v _ -> case f k1 v1 v of (# v' #) -> Leaf h1 $ L k1 v')+ h1 k1 s t2+ go s t1 (Leaf h2 (L k2 v2)) =+ lookupCont+ (\_ -> Empty)+ (\v _ -> case f k2 v v2 of (# v' #) -> Leaf h2 $ L k2 v')+ h2 k2 s t1+ -- collision vs. collision+ 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 (nextShift s)) b1 b2 ary1 ary2+ go s (BitmapIndexed b1 ary1) (Full ary2) =+ intersectionArrayBy (go (nextShift s)) b1 fullBitmap ary1 ary2+ go s (Full ary1) (BitmapIndexed b2 ary2) =+ intersectionArrayBy (go (nextShift s)) fullBitmap b2 ary1 ary2+ go s (Full ary1) (Full 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 =+ case A.index# ary1 i of+ (# st1 #) -> go (nextShift s) st1 t2+ where+ m2 = mask h2 s+ i = sparseIndex b1 m2+ go s t1@(Collision h1 _ls1) (BitmapIndexed b2 ary2)+ | b2 .&. m1 == 0 = Empty+ | otherwise =+ case A.index# ary2 i of+ (# st2 #) -> go (nextShift s) t1 st2+ where+ m1 = mask h1 s+ i = sparseIndex b2 m1+ go s (Full ary1) t2@(Collision h2 _ls2) =+ case A.index# ary1 i of+ (# st1 #)-> go (nextShift s) st1 t2+ where+ i = index h2 s+ go s t1@(Collision h1 _ls1) (Full ary2) =+ case A.index# ary2 i of+ (# st2 #) -> go (nextShift s) t1 st2+ where+ i = index h1 s+{-# INLINE intersectionWithKey# #-}++intersectionArrayBy ::+ ( HashMap k v1 ->+ HashMap k v2 ->+ HashMap k v3+ ) ->+ Bitmap ->+ Bitmap ->+ A.Array (HashMap k v1) ->+ A.Array (HashMap k v2) ->+ HashMap k v3+intersectionArrayBy f !b1 !b2 !ary1 !ary2+ | b1 .&. b2 == 0 = Empty+ | otherwise = runST $ do+ mary <- A.new_ $ popCount bIntersect+ -- iterate over nonzero bits of b1 .|. b2+ let go !i !i1 !i2 !b !bFinal+ | b == 0 = pure (i, bFinal)+ | testBit $ b1 .&. b2 = do+ x1 <- A.indexM ary1 i1+ x2 <- A.indexM ary2 i2+ case f x1 x2 of+ Empty -> go i (i1 + 1) (i2 + 1) b' (bFinal .&. complement m)+ _ -> do+ A.write mary i $! f x1 x2+ go (i + 1) (i1 + 1) (i2 + 1) b' bFinal+ | testBit b1 = go i (i1 + 1) i2 b' bFinal+ | otherwise = go i i1 (i2 + 1) b' bFinal+ where+ m = 1 `unsafeShiftL` countTrailingZeros b+ testBit x = x .&. m /= 0+ b' = b .&. complement m+ (len, bFinal) <- go 0 0 0 bCombined bIntersect+ case len of+ 0 -> pure Empty+ 1 -> do+ l <- A.read mary 0+ if isLeafOrCollision l+ then pure l+ else BitmapIndexed bFinal <$> (A.unsafeFreeze =<< A.shrink mary 1)+ _ -> bitmapIndexedOrFull bFinal <$> (A.unsafeFreeze =<< A.shrink mary len)+ where+ bCombined = b1 .|. b2+ bIntersect = b1 .&. b2+{-# INLINE intersectionArrayBy #-}++intersectionCollisions :: Eq k => (k -> v1 -> v2 -> (# v3 #)) -> Hash -> Hash -> A.Array (Leaf k v1) -> A.Array (Leaf k v2) -> HashMap k v3+intersectionCollisions f h1 h2 ary1 ary2+ | h1 == h2 = runST $ do+ let !n2 = A.length ary2+ mary2 <- A.thaw ary2 0 n2+ mary <- A.new_ $ min (A.length ary1) n2+ let go i j+ | i >= A.length ary1 || j >= n2 = pure j+ | otherwise = do+ L k1 v1 <- A.indexM ary1 i+ searchSwap mary2 n2 k1 j >>= \case+ Just (L _k2 v2) -> do+ let !(# v3 #) = f k1 v1 v2+ A.write mary j $ L k1 v3+ go (i + 1) (j + 1)+ Nothing -> do+ go (i + 1) j+ len <- go 0 0+ case len of+ 0 -> pure Empty+ 1 -> Leaf h1 <$> A.read mary 0+ _ -> Collision h1 <$> (A.unsafeFreeze =<< A.shrink mary len)+ | otherwise = Empty+{-# INLINE intersectionCollisions #-}++-- | Say we have+-- @+-- 1 2 3 4+-- @+-- and we search for @3@. Then we can mutate the array to+-- @+-- undefined 2 1 4+-- @+-- We don't actually need to write undefined, we just have to make sure that the next search starts 1 after the current one.+searchSwap :: Eq k => A.MArray s (Leaf k v) -> Int -> k -> Int -> ST s (Maybe (Leaf k v))+searchSwap mary n toFind start = go start toFind start+ where+ go i0 k i+ | i >= n = pure Nothing+ | otherwise = do+ l@(L k' _v) <- A.read mary i+ if k == k'+ then do+ A.write mary i =<< A.read mary i0+ pure $ Just l+ else go i0 k (i + 1)+{-# INLINE searchSwap #-}++-- | \(O(n \log m)\) Check whether the key sets of two maps are disjoint+-- (i.e., their 'intersection' is empty).+--+-- @+-- xs ``disjoint`` ys = null (xs ``intersection`` ys)+-- @+--+-- @since 0.2.21+disjoint :: Eq k => HashMap k a -> HashMap k b -> Bool+disjoint = disjointSubtrees 0+{-# INLINE disjoint #-}++-- Note that as of GHC 9.12, SpecConstr creates a specialized worker for+-- handling the Collision vs. {BitmapIndexed,Full} and vice-versa cases,+-- but this worker fails to be properly specialized for different key+-- types. See https://gitlab.haskell.org/ghc/ghc/-/issues/26615.+disjointSubtrees :: Eq k => Shift -> HashMap k a -> HashMap k b -> Bool+disjointSubtrees !_s Empty _b = True+disjointSubtrees s (Leaf hA (L kA _)) b =+ lookupCont (\_ -> True) (\_ _ -> False) hA kA s b+disjointSubtrees s (BitmapIndexed bmA aryA) (BitmapIndexed bmB aryB) =+ -- We could do a pointer equality check here but it's probably not worth it+ -- since it would save only O(1) extra work:+ --+ -- not (aryA `A.unsafeSameArray` aryB) &&+ disjointArrays s bmA aryA bmB aryB+disjointSubtrees s (BitmapIndexed bmA aryA) (Full aryB) =+ disjointArrays s bmA aryA fullBitmap aryB+disjointSubtrees s (Full aryA) (BitmapIndexed bmB aryB) =+ disjointArrays s fullBitmap aryA bmB aryB+disjointSubtrees s (Full aryA) (Full aryB) =+ -- We could do a pointer equality check here but it's probably not worth it+ -- since it would save only O(1) extra work:+ --+ -- not (aryA `A.unsafeSameArray` aryB) &&+ go (maxChildren - 1)+ where+ go i+ | i < 0 = True+ | otherwise = case A.index# aryA i of+ (# stA #) -> case A.index# aryB i of+ (# stB #) ->+ disjointSubtrees (nextShift s) stA stB &&+ go (i - 1)+disjointSubtrees s a@(Collision hA _) (BitmapIndexed bmB aryB)+ | m .&. bmB == 0 = True+ | otherwise = case A.index# aryB i of+ (# stB #) -> disjointSubtrees (nextShift s) a stB+ where+ m = mask hA s+ i = sparseIndex bmB m+disjointSubtrees s a@(Collision hA _) (Full aryB) =+ case A.index# aryB (index hA s) of+ (# stB #) -> disjointSubtrees (nextShift s) a stB+disjointSubtrees _ (Collision hA aryA) (Collision hB aryB) =+ disjointCollisions hA aryA hB aryB+disjointSubtrees _s _a Empty = True+disjointSubtrees s a (Leaf hB (L kB _)) =+ lookupCont (\_ -> True) (\_ _ -> False) hB kB s a+disjointSubtrees s a b@Collision{} = disjointSubtrees s b a+{-# INLINABLE disjointSubtrees #-}++disjointArrays :: Eq k => Shift -> Bitmap -> A.Array (HashMap k a) -> Bitmap -> A.Array (HashMap k b) -> Bool+disjointArrays !s !bmA !aryA !bmB !aryB = go (bmA .&. bmB)+ where+ go 0 = True+ go bm = case A.index# aryA iA of+ (# stA #) -> case A.index# aryB iB of+ (# stB #) ->+ disjointSubtrees (nextShift s) stA stB &&+ go (bm .&. complement m)+ where+ m = bm .&. negate bm+ iA = sparseIndex bmA m+ iB = sparseIndex bmB m+{-# INLINE disjointArrays #-}++-- TODO: GHC 9.12.2 inlines disjointCollisions into `disjoint @Int`.+-- How do you prevent this while preserving specialization?+-- https://stackoverflow.com/questions/79838305/ensuring-specialization-while-preventing-inlining+disjointCollisions :: Eq k => Hash -> A.Array (Leaf k a) -> Hash -> A.Array (Leaf k b) -> Bool+disjointCollisions !hA !aryA !hB !aryB+ | hA == hB = A.all predicate aryA+ | otherwise = True+ where+ predicate (L kA _) = lookupInArrayCont (\_ -> True) (\_ _ -> False) kA aryB+{-# INLINABLE disjointCollisions #-}++------------------------------------------------------------------------+-- * Folds++-- | \(O(n)\) Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- left-identity of the operator). Each application of the operator+-- is evaluated before using the result in the next application.+-- This function is strict in the starting value.+foldl' :: (a -> v -> a) -> a -> HashMap k v -> a+foldl' f = foldlWithKey' (\ z _ v -> f z v)+{-# INLINE foldl' #-}++-- | \(O(n)\) Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- right-identity of the operator). Each application of the operator+-- is evaluated before using the result in the next application.+-- This function is strict in the starting value.+foldr' :: (v -> a -> a) -> a -> HashMap k v -> a+foldr' f = foldrWithKey' (\ _ v z -> f v z)+{-# INLINE foldr' #-}++-- | \(O(n)\) Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- left-identity of the operator). Each application of the operator+-- is evaluated before using the result in the next application.+-- This function is strict in the starting value.+foldlWithKey' :: (a -> k -> v -> a) -> a -> HashMap k v -> a+foldlWithKey' f = go+ where+ go !z Empty = z+ go z (Leaf _ (L k v)) = f z k v+ go z (BitmapIndexed _ ary) = A.foldl' go z ary+ go z (Full ary) = A.foldl' go z ary+ go z (Collision _ ary) = A.foldl' (\ z' (L k v) -> f z' k v) z ary+{-# INLINE foldlWithKey' #-}++-- | \(O(n)\) Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- right-identity of the operator). Each application of the operator+-- is evaluated before using the result in the next application.+-- This function is strict in the starting value.+foldrWithKey' :: (k -> v -> a -> a) -> a -> HashMap k v -> a+foldrWithKey' f = flip go+ where+ go Empty z = z+ go (Leaf _ (L k v)) !z = f k v z+ go (BitmapIndexed _ ary) !z = A.foldr' go z ary+ go (Full ary) !z = A.foldr' go z ary+ go (Collision _ ary) !z = A.foldr' (\ (L k v) z' -> f k v z') z ary+{-# INLINE foldrWithKey' #-}++-- | \(O(n)\) Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- right-identity of the operator).+foldr :: (v -> a -> a) -> a -> HashMap k v -> a+foldr f = foldrWithKey (const f)+{-# INLINE foldr #-}++-- | \(O(n)\) Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- left-identity of the operator).+foldl :: (a -> v -> a) -> a -> HashMap k v -> a+foldl f = foldlWithKey (\a _k v -> f a v)+{-# INLINE foldl #-}++-- | \(O(n)\) Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- right-identity of the operator).+foldrWithKey :: (k -> v -> a -> a) -> a -> HashMap k v -> a+foldrWithKey f = flip go+ where+ go Empty z = z+ go (Leaf _ (L k v)) z = f k v z+ go (BitmapIndexed _ ary) z = A.foldr go z ary+ go (Full ary) z = A.foldr go z ary+ go (Collision _ ary) z = A.foldr (\ (L k v) z' -> f k v z') z ary+{-# INLINE foldrWithKey #-}++-- | \(O(n)\) Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- left-identity of the operator).+foldlWithKey :: (a -> k -> v -> a) -> a -> HashMap k v -> a+foldlWithKey f = go+ where+ go z Empty = z+ go z (Leaf _ (L k v)) = f z k v+ go z (BitmapIndexed _ ary) = A.foldl go z ary+ go z (Full ary) = A.foldl go z ary+ go z (Collision _ ary) = A.foldl (\ z' (L k v) -> f z' k v) z ary+{-# INLINE foldlWithKey #-}++-- | \(O(n)\) Reduce the map by applying a function to each element+-- and combining the results with a monoid operation.+foldMapWithKey :: Monoid m => (k -> v -> m) -> HashMap k v -> m+foldMapWithKey f = go+ where+ go Empty = mempty+ go (Leaf _ (L k v)) = f k v+ go (BitmapIndexed _ ary) = A.foldMap go ary+ go (Full ary) = A.foldMap go ary+ go (Collision _ ary) = A.foldMap (\ (L k v) -> f k v) ary+{-# INLINE foldMapWithKey #-}++------------------------------------------------------------------------+-- * Filter++-- | \(O(n)\) Transform this map by applying a function to every value+-- and retaining only some of them.+mapMaybeWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2+mapMaybeWithKey f = filterMapAux onLeaf onColl+ where onLeaf (Leaf h (L k v)) | Just v' <- f k v = Just (Leaf h (L k v'))+ onLeaf _ = Nothing++ onColl (L k v) | Just v' <- f k v = Just (L k v')+ | otherwise = Nothing+{-# INLINE mapMaybeWithKey #-}++-- | \(O(n)\) Transform this map by applying a function to every value+-- and retaining only some of them.+mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2+mapMaybe f = mapMaybeWithKey (const f)+{-# INLINE mapMaybe #-}++-- | \(O(n)\) Filter this map by retaining only elements satisfying a+-- predicate.+filterWithKey :: forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v+filterWithKey pred = filterMapAux onLeaf onColl+ where onLeaf t@(Leaf _ (L k v)) | pred k v = Just t+ onLeaf _ = Nothing++ onColl el@(L k v) | pred k v = Just el+ onColl _ = Nothing+{-# INLINE filterWithKey #-}+++-- | Common implementation for 'filterWithKey' and 'mapMaybeWithKey',+-- allowing the former to former to reuse terms.+filterMapAux :: forall k v1 v2+ . (HashMap k v1 -> Maybe (HashMap k v2))+ -> (Leaf k v1 -> Maybe (Leaf k v2))+ -> HashMap k v1+ -> HashMap k v2+filterMapAux onLeaf onColl = go+ where+ go Empty = Empty+ go t@Leaf{}+ | Just t' <- onLeaf t = t'+ | otherwise = Empty+ go (BitmapIndexed b ary) = filterA ary b+ go (Full ary) = filterA ary fullBitmap+ go (Collision h ary) = filterC ary h++ filterA ary0 b0 =+ let !n = A.length ary0+ in runST $ do+ mary <- A.new_ n+ step ary0 mary b0 0 0 1 n+ where+ step :: A.Array (HashMap k v1) -> A.MArray s (HashMap k v2)+ -> Bitmap -> Int -> Int -> Bitmap -> Int+ -> ST s (HashMap k v2)+ step !ary !mary !b i !j !bi n+ | i >= n = case j of+ 0 -> return Empty+ 1 -> do+ ch <- A.read mary 0+ case ch of+ t | isLeafOrCollision t -> return t+ _ -> BitmapIndexed b <$> (A.unsafeFreeze =<< A.shrink mary 1)+ _ -> do+ ary2 <- A.unsafeFreeze =<< A.shrink mary j+ return $! if j == maxChildren+ then Full ary2+ else BitmapIndexed b ary2+ | bi .&. b == 0 = step ary mary b i j (bi `unsafeShiftL` 1) n+ | otherwise = do+ st <- A.indexM ary i+ case go st of+ Empty ->+ step ary mary (b .&. complement bi) (i+1) j (bi `unsafeShiftL` 1) n+ t -> do+ A.write mary j t+ step ary mary b (i+1) (j+1) (bi `unsafeShiftL` 1) n++ filterC ary0 h =+ let !n = A.length ary0+ in runST $ do+ mary <- A.new_ n+ step ary0 mary 0 0 n+ where+ step :: A.Array (Leaf k v1) -> A.MArray s (Leaf k v2)+ -> Int -> Int -> Int+ -> ST s (HashMap k v2)+ step !ary !mary i !j n+ | i >= n = case j of+ 0 -> return Empty+ 1 -> do l <- A.read mary 0+ return $! Leaf h l+ _ | i == j -> do ary2 <- A.unsafeFreeze mary+ return $! Collision h ary2+ | otherwise -> do ary2 <- A.unsafeFreeze =<< A.shrink mary j+ return $! Collision h ary2+ | (# l #) <- A.index# ary i+ , Just el <- onColl l+ = A.write mary j el >> step ary mary (i+1) (j+1) n+ | otherwise = step ary mary (i+1) j n+{-# INLINE filterMapAux #-}++-- | \(O(n)\) Filter this map by retaining only elements which values+-- satisfy a predicate.+filter :: (v -> Bool) -> HashMap k v -> HashMap k v+filter p = filterWithKey (\_ v -> p v)+{-# INLINE filter #-}++------------------------------------------------------------------------+-- * Conversions++-- TODO: Improve fusion rules by modelled them after the Prelude ones+-- on lists.++-- | \(O(n)\) Return a list of this map's keys. The list is produced+-- lazily.+keys :: HashMap k v -> [k]+keys = List.map fst . toList+{-# INLINE keys #-}++-- | \(O(n)\) Return a list of this map's values. The list is produced+-- lazily.+elems :: HashMap k v -> [v]+elems = List.map snd . toList+{-# INLINE elems #-}++------------------------------------------------------------------------+-- ** Lists++-- | \(O(n)\) Return a list of this map's elements. The list is+-- produced lazily. The order of its elements is unspecified, and it may+-- change from version to version of either this package or of @hashable@.+toList :: HashMap k v -> [(k, v)]+toList t = Exts.build (\ c z -> foldrWithKey (curry c) z t)+{-# INLINE toList #-}++-- | \(O(n \log n)\) Construct a map with the supplied mappings. If the list+-- contains duplicate mappings, the later mappings take precedence.+fromList :: Hashable k => [(k, v)] -> HashMap k v+fromList = List.foldl' (\ m (k, v) -> unsafeInsert k v m) empty+{-# INLINABLE fromList #-}++-- | \(O(n \log n)\) Construct a map from a list of elements. Uses+-- the provided function @f@ to merge duplicate entries with+-- @(f newVal oldVal)@.+--+-- === Examples+--+-- Given a list @xs@, create a map with the number of occurrences of each+-- element in @xs@:+--+-- > let xs = ['a', 'b', 'a']+-- > in fromListWith (+) [ (x, 1) | x <- xs ]+-- >+-- > = fromList [('a', 2), ('b', 1)]+--+-- Given a list of key-value pairs @xs :: [(k, v)]@, group all values by their+-- keys and return a @HashMap k [v]@.+--+-- > let xs = [('a', 1), ('b', 2), ('a', 3)]+-- > in fromListWith (++) [ (k, [v]) | (k, v) <- xs ]+-- >+-- > = fromList [('a', [3, 1]), ('b', [2])]+--+-- Note that the lists in the resulting map contain elements in reverse order+-- 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.+--+-- > fromListWith f [(k, a), (k, b), (k, c), (k, d)]+-- > = fromList [(k, f d (f c (f b a)))]+fromListWith :: Hashable k => (v -> v -> v) -> [(k, v)] -> HashMap k v+fromListWith f = List.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty+{-# INLINE fromListWith #-}++-- | \(O(n \log n)\) Construct a map from a list of elements. Uses+-- the provided function to merge duplicate entries.+--+-- === Examples+--+-- Given a list of key-value pairs where the keys are of different flavours, e.g:+--+-- > data Key = Div | Sub+--+-- and the values need to be combined differently when there are duplicates,+-- depending on the key:+--+-- > combine Div = div+-- > combine Sub = (-)+--+-- then @fromListWithKey@ can be used as follows:+--+-- > fromListWithKey combine [(Div, 2), (Div, 6), (Sub, 2), (Sub, 3)]+-- > = fromList [(Div, 3), (Sub, 1)]+--+-- More generally, duplicate entries are accumulated as follows;+--+-- > fromListWith f [(k, a), (k, b), (k, c), (k, d)]+-- > = fromList [(k, f k d (f k c (f k b a)))]+--+-- @since 0.2.11+fromListWithKey :: Hashable k => (k -> v -> v -> v) -> [(k, v)] -> HashMap k v+fromListWithKey f = List.foldl' (\ m (k, v) -> unsafeInsertWithKey (\k' a b -> (# f k' a b #)) k v m) empty+{-# INLINE fromListWithKey #-}++------------------------------------------------------------------------+-- Array operations++-- | \(O(n)\) Look up the value associated with the given key in an+-- array.+lookupInArrayCont ::+#if defined(__GLASGOW_HASKELL__)+ forall rep (r :: TYPE rep) k v.+#else+ forall r k v.+#endif+ Eq k => ((# #) -> r) -> (v -> Int -> r) -> k -> A.Array (Leaf k v) -> r+lookupInArrayCont absent present k0 ary0 =+ lookupInArrayCont_ k0 ary0 0 (A.length ary0)+ where+ lookupInArrayCont_ :: Eq k => k -> A.Array (Leaf k v) -> Int -> Int -> r+ lookupInArrayCont_ !k !ary !i !n+ | i >= n = absent (# #)+ | otherwise = case A.index# ary i of+ (# L kx v #)+ | k == kx -> present v i+ | otherwise -> lookupInArrayCont_ k ary (i+1) n+{-# INLINE lookupInArrayCont #-}++-- | \(O(n)\) Lookup the value associated with the given key in this+-- array. Returns 'Nothing' if the key wasn't found.+indexOf :: Eq k => k -> A.Array (Leaf k v) -> Maybe Int+indexOf k0 ary0 = go k0 ary0 0 (A.length ary0)+ where+ go !k !ary !i !n+ | i >= n = Nothing+ | otherwise = case A.index# ary i of+ (# L kx _ #)+ | k == kx -> Just i+ | otherwise -> go k ary (i+1) n+{-# INLINABLE indexOf #-}++updateWith# :: Eq k => (v -> (# v #)) -> k -> A.Array (Leaf k v) -> A.Array (Leaf k v)+updateWith# f k0 ary0 = go k0 ary0 0 (A.length ary0)+ where+ go !k !ary !i !n+ | i >= n = ary+ | otherwise = case A.index# ary i of+ (# L kx y #) | k == kx -> case f y of+ (# y' #)+ | ptrEq y y' -> ary+ | otherwise -> A.update ary i (L k y')+ | otherwise -> go k ary (i+1) n+{-# INLINABLE updateWith# #-}++updateOrSnocWith :: Eq k => (v -> v -> (# v #)) -> k -> v -> A.Array (Leaf k v)+ -> A.Array (Leaf k v)+updateOrSnocWith f = updateOrSnocWithKey (const f)+{-# INLINABLE updateOrSnocWith #-}++updateOrSnocWithKey :: Eq k => (k -> v -> v -> (# v #)) -> k -> v -> A.Array (Leaf k v)+ -> A.Array (Leaf k v)+updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0)+ where+ go !k v !ary !i !n+ -- Not found, append to the end.+ | i >= n = A.snoc ary $ L k v+ | otherwise+ = case A.index# ary i of+ (# L kx y #) | k == kx -> case f k v y of+ (# v2 #) -> A.update ary i (L k v2)+ | otherwise -> go k v ary (i+1) n+{-# INLINABLE updateOrSnocWithKey #-}++updateOrConcatWithKey :: Eq k => (k -> v -> v -> (# v #)) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -> A.Array (Leaf k v)+updateOrConcatWithKey f ary1 ary2 = A.run $ do+ -- TODO: instead of mapping and then folding, should we traverse?+ -- We'll have to be careful to avoid allocating pairs or similar.++ -- first: look up the position of each element of ary2 in ary1+ let indices = A.map' (\(L k _) -> indexOf k ary1) ary2+ -- that tells us how large the overlap is:+ -- count number of Nothing constructors+ let nOnly2 = A.foldl' (\n -> maybe (n+1) (const n)) 0 indices+ let n1 = A.length ary1+ let n2 = A.length ary2+ -- copy over all elements from ary1+ mary <- A.new_ (n1 + nOnly2)+ A.copy ary1 0 mary 0 n1+ -- append or update all elements from ary2+ let go !iEnd !i2+ | i2 >= n2 = return ()+ | (# Just i1 #) <- A.index# indices i2 = do+ -- key occurs in both arrays, store combination in position i1+ L k v1 <- A.indexM ary1 i1+ L _ v2 <- A.indexM ary2 i2+ case f k v1 v2 of (# v3 #) -> A.write mary i1 (L k v3)+ go iEnd (i2+1)+ | otherwise = do+ -- key is only in ary2, append to end+ A.write mary iEnd =<< A.indexM ary2 i2+ go (iEnd+1) (i2+1)+ go n1 0+ return mary+{-# INLINABLE updateOrConcatWithKey #-}++-- | \(O(n*m)\) Check if the first array is a subset of the second array.+subsetArray :: Eq k => (v1 -> v2 -> Bool) -> A.Array (Leaf k v1) -> A.Array (Leaf k v2) -> Bool+subsetArray cmpV ary1 ary2 = A.length ary1 <= A.length ary2 && A.all inAry2 ary1+ where+ inAry2 (L k1 v1) = lookupInArrayCont (\_ -> False) (\v2 _ -> cmpV v1 v2) k1 ary2+ {-# INLINE inAry2 #-}++------------------------------------------------------------------------+-- Manually unrolled loops++-- | \(O(n)\) Update the element at the given position in this array.+updateFullArray :: A.Array e -> Int -> e -> A.Array e+updateFullArray ary idx b = runST (updateFullArrayM ary idx b)+{-# INLINE updateFullArray #-}++-- | \(O(n)\) Update the element at the given position in this array.+updateFullArrayM :: A.Array e -> Int -> e -> ST s (A.Array e)+updateFullArrayM ary idx b = do+ mary <- clone ary+ A.write mary idx b+ A.unsafeFreeze mary+{-# INLINE updateFullArrayM #-}++-- | \(O(n)\) Update the element at the given position in this array, by applying a function to it.+updateFullArrayWith' :: A.Array e -> Int -> (e -> e) -> A.Array e+updateFullArrayWith' ary idx f =+ case A.index# ary idx of+ (# x #) -> updateFullArray ary idx $! f x+{-# INLINE updateFullArrayWith' #-}++-- | Unsafely clone an array of (2^bitsPerSubkey) elements. The length of the input+-- array is not checked.+clone :: A.Array e -> ST s (A.MArray s e)+clone ary =+ A.thaw ary 0 (2^bitsPerSubkey)++------------------------------------------------------------------------+-- Bit twiddling++-- TODO: Name this 'bitsPerLevel'?! What is a "subkey"?+-- https://github.com/haskell-unordered-containers/unordered-containers/issues/425++-- | Number of bits that are inspected at each level of the hash tree.+--+-- This constant is named /t/ in the original /Ideal Hash Trees/ paper.+--+-- Note that this constant is platform-dependent. On 32-bit platforms we use+-- '4', because bitmaps using '2^5' bits turned out to be prone to integer+-- overflow bugs. See #491 for instance.+bitsPerSubkey :: Int+#if WORD_SIZE_IN_BITS < 64+bitsPerSubkey = 4+#else+bitsPerSubkey = 5+#endif++-- | The size of a 'Full' node, i.e. @2 ^ 'bitsPerSubkey'@.+maxChildren :: Int+maxChildren = 1 `unsafeShiftL` bitsPerSubkey++-- | Bit mask with the lowest 'bitsPerSubkey' bits set, i.e. @0b11111@.+subkeyMask :: Word+subkeyMask = 1 `unsafeShiftL` bitsPerSubkey - 1++-- | Given a 'Hash' and a 'Shift' that indicates the level in the tree, compute+-- the index into a 'Full' node or into the bitmap of a `BitmapIndexed` node.+--+-- >>> index 0b0010_0010 0+-- 0b0000_0010+index :: Hash -> Shift -> Int+index w s = fromIntegral $ unsafeShiftR w s .&. subkeyMask+{-# INLINE index #-}++-- | Given a 'Hash' and a 'Shift' that indicates the level in the tree, compute+-- the bitmap that contains only the 'index' of the hash at this level.+--+-- The result can be used for constructing one-element 'BitmapIndexed' nodes or+-- to check whether a 'BitmapIndexed' node may possibly contain the given 'Hash'.+--+-- >>> mask 0b0010_0010 0+-- 0b0100+mask :: Hash -> Shift -> Bitmap+mask w s = 1 `unsafeShiftL` index w s+{-# INLINE mask #-}++-- | This array index is computed by counting the number of 1-bits below the+-- 'index' represented by the mask.+--+-- >>> sparseIndex 0b0110_0110 0b0010_0000+-- 2+sparseIndex+ :: Bitmap+ -- ^ Bitmap of a 'BitmapIndexed' node+ -> Bitmap+ -- ^ One-bit 'mask' corresponding to the 'index' of a hash+ -> Int+ -- ^ Index into the array of the 'BitmapIndexed' node+sparseIndex b m = popCount (b .&. (m - 1))+{-# INLINE sparseIndex #-}++-- | A bitmap with the 'maxChildren' least significant bits set, i.e.+-- @0xFF_FF_FF_FF@.+fullBitmap :: Bitmap+-- This needs to use 'shiftL' instead of 'unsafeShiftL', to avoid UB.+-- See issue #412.+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 #-}++------------------------------------------------------------------------+-- ShiftedHash++-- | Sometimes it's more efficient to right-shift the hashes directly instead+-- of keeping track of an additional 'Shift' value.+type ShiftedHash = Hash++{-+-- | Construct a 'ShiftedHash' from a 'Shift' and a 'Hash'.+shiftHash :: Shift -> Hash -> ShiftedHash+shiftHash s h = h `unsafeShiftR` s+{-# INLINE shiftHash #-}+-}++-- | Update a 'ShiftedHash' for the next level of the tree.+nextSH :: ShiftedHash -> ShiftedHash+nextSH sh = sh `unsafeShiftR` bitsPerSubkey+{-# INLINE nextSH #-}++-- | Version of 'index' for use with @'ShiftedHash'es@.+indexSH :: ShiftedHash -> Int+indexSH sh = fromIntegral $ sh .&. subkeyMask+{-# INLINE indexSH #-}++-- | Version of 'mask' for use with @'ShiftedHash'es@.+maskSH :: ShiftedHash -> Bitmap+maskSH sh = 1 `unsafeShiftL` indexSH sh+{-# INLINE maskSH #-}++------------------------------------------------------------------------+-- Pointer equality++-- | Check if two the two arguments are the same value. N.B. This+-- function might give false negatives (due to GC moving objects.)+ptrEq :: a -> a -> Bool+ptrEq x y = Exts.isTrue# (Exts.reallyUnsafePtrEquality# x y ==# 1#)+{-# INLINE ptrEq #-}++------------------------------------------------------------------------+-- Array index arithmetic++-- |+-- >>> otherOfOneOrZero 0+-- 1+-- >>> otherOfOneOrZero 1+-- 0+otherOfOneOrZero :: Int -> Int+otherOfOneOrZero i = 1 - i+{-# INLINE otherOfOneOrZero #-}++#if defined(__GLASGOW_HASKELL__)+------------------------------------------------------------------------+-- IsList instance+instance Hashable k => Exts.IsList (HashMap k v) where+ type Item (HashMap k v) = (k, v)+ fromList = fromList+ toList = toList+#endif
+ Data/HashMap/Internal/Array.hs view
@@ -0,0 +1,662 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | = 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+--+-- Zero based arrays.+--+-- Note that no bounds checking are performed.+module Data.HashMap.Internal.Array+ ( Array(..)+ , MArray(..)++ -- * Creation+ , new+ , new_+ , singleton+ , singletonM+ , snoc+ , pair++ -- * Basic interface+ , length+ , lengthM+ , read+ , write+ , indexM+ , index#+ , update+ , updateWith'+ , unsafeUpdateM+ , insert+ , insertM+ , delete+ , sameArray1++ , unsafeFreeze+ , unsafeThaw+ , unsafeSameArray+ , run+ , copy+ , copyM+ , cloneM++ -- * Folds+ , foldl+ , foldl'+ , foldr+ , foldr'+ , foldMap+ , all++ , thaw+ , map+ , map'+ , filter+ , mapMaybe+ , traverse+ , traverse'+ , toList+ , fromList+ , fromList'+ , shrink+ ) where++import Control.Applicative (Applicative (..))+import Control.DeepSeq (NFData (..), NFData1 (..))+import Control.Monad ((>=>))+import Control.Monad.ST (runST, stToIO)+import GHC.Exts (Int (..), SmallArray#, SmallMutableArray#,+ cloneSmallMutableArray#, copySmallArray#,+ copySmallMutableArray#, getSizeofSmallMutableArray#,+ indexSmallArray#, newSmallArray#, readSmallArray#,+ reallyUnsafePtrEquality#, sizeofSmallArray#,+ tagToEnum#, thawSmallArray#, unsafeCoerce#,+ unsafeFreezeSmallArray#, unsafeThawSmallArray#,+ writeSmallArray#)+import GHC.ST (ST (..))+import Prelude hiding (Applicative (..), Foldable (..), all, filter,+ map, read, traverse)++import qualified GHC.Exts as Exts+import qualified Language.Haskell.TH.Syntax as TH++#if defined(ASSERTS)+import GHC.Exts (sizeofSmallMutableArray#)++import qualified Prelude+#endif+++#if defined(ASSERTS)+-- This fugly hack is brought by GHC's apparent reluctance to deal+-- with MagicHash and UnboxedTuples when inferring types. Eek!+# define CHECK_BOUNDS(_func_,_len_,_k_) \+if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.HashMap.Internal.Array." ++ (_func_) ++ ": bounds error, offset " ++ show (_k_) ++ ", length " ++ show (_len_)) else+# define CHECK_OP(_func_,_op_,_lhs_,_rhs_) \+if not ((_lhs_) _op_ (_rhs_)) then error ("Data.HashMap.Internal.Array." ++ (_func_) ++ ": Check failed: _lhs_ _op_ _rhs_ (" ++ show (_lhs_) ++ " vs. " ++ show (_rhs_) ++ ")") else+# define CHECK_GE(_func_,_lhs_,_rhs_) CHECK_OP(_func_,>=,_lhs_,_rhs_)+# define CHECK_GT(_func_,_lhs_,_rhs_) CHECK_OP(_func_,>,_lhs_,_rhs_)+# define CHECK_LE(_func_,_lhs_,_rhs_) CHECK_OP(_func_,<=,_lhs_,_rhs_)+# define CHECK_EQ(_func_,_lhs_,_rhs_) CHECK_OP(_func_,==,_lhs_,_rhs_)+#else+# define CHECK_BOUNDS(_func_,_len_,_k_)+# define CHECK_OP(_func_,_op_,_lhs_,_rhs_)+# define CHECK_GE(_func_,_lhs_,_rhs_)+# define CHECK_GT(_func_,_lhs_,_rhs_)+# define CHECK_LE(_func_,_lhs_,_rhs_)+# define CHECK_EQ(_func_,_lhs_,_rhs_)+#endif++data Array a = Array {+ unArray :: !(SmallArray# a)+ }++instance Show a => Show (Array a) where+ show = show . toList++-- Determines whether two arrays have the same memory address.+-- This is more reliable than testing pointer equality on the+-- Array wrappers, but it's still slightly bogus.+unsafeSameArray :: Array a -> Array b -> Bool+unsafeSameArray (Array xs) (Array ys) =+ tagToEnum# (unsafeCoerce# reallyUnsafePtrEquality# xs ys)++sameArray1 :: (a -> b -> Bool) -> Array a -> Array b -> Bool+sameArray1 eq !xs0 !ys0+ | lenxs /= lenys = False+ | otherwise = go 0 xs0 ys0+ where+ go !k !xs !ys+ | k == lenxs = True+ | (# x #) <- index# xs k+ , (# y #) <- index# ys k+ = eq x y && go (k + 1) xs ys++ !lenxs = length xs0+ !lenys = length ys0++length :: Array a -> Int+length ary = I# (sizeofSmallArray# (unArray ary))+{-# INLINE length #-}++data MArray s a = MArray {+ unMArray :: !(SmallMutableArray# s a)+ }++lengthM :: MArray s a -> ST s Int+lengthM (MArray ary) = ST $ \s ->+ case getSizeofSmallMutableArray# ary s of+ (# s', n #) -> (# s', I# n #)+{-# INLINE lengthM #-}++#if defined(ASSERTS)+-- | Unsafe. Only for use in the @CHECK_*@ pragmas.+unsafeLengthM :: MArray s a -> Int+unsafeLengthM mary = I# (sizeofSmallMutableArray# (unMArray mary))+{-# INLINE unsafeLengthM #-}+#endif++------------------------------------------------------------------------++instance NFData a => NFData (Array a) where+ rnf = rnfArray++rnfArray :: NFData a => Array a -> ()+rnfArray ary0 = go ary0 n0 0+ where+ n0 = length ary0+ go !ary !n !i+ | i >= n = ()+ | (# x #) <- index# ary i+ = rnf x `seq` go ary n (i+1)+-- We use index# just in case GHC can't see that the+-- relevant rnf is strict, or in case it actually isn't.+{-# INLINE rnfArray #-}++-- | @since 0.2.14.0+instance NFData1 Array where+ liftRnf = liftRnfArray++liftRnfArray :: (a -> ()) -> Array a -> ()+liftRnfArray rnf0 ary0 = go ary0 n0 0+ where+ n0 = length ary0+ go !ary !n !i+ | i >= n = ()+ | (# x #) <- index# ary i+ = rnf0 x `seq` go ary n (i+1)+{-# INLINE liftRnfArray #-}++-- | Create a new mutable array of specified size, in the specified+-- state thread, with each element containing the specified initial+-- value.+new :: Int -> a -> ST s (MArray s a)+new _n@(I# n#) b =+ CHECK_GT("new",_n,(0 :: Int))+ ST $ \s ->+ case newSmallArray# n# b s of+ (# s', ary #) -> (# s', MArray ary #)+{-# INLINE new #-}++new_ :: Int -> ST s (MArray s a)+new_ n = new n undefinedElem++-- | The returned array is the same as the array given, as it is shrunk in place.+shrink :: MArray s a -> Int -> ST s (MArray s a)+shrink mary _n@(I# n#) =+ CHECK_GE("shrink", _n, (0 :: Int))+ CHECK_LE("shrink", _n, (unsafeLengthM mary))+ ST $ \s -> case Exts.shrinkSmallMutableArray# (unMArray mary) n# s of+ s' -> (# s', mary #)+{-# INLINE shrink #-}++singleton :: a -> Array a+singleton x = runST (singletonM x)+{-# INLINE singleton #-}++singletonM :: a -> ST s (Array a)+singletonM x = new 1 x >>= unsafeFreeze+{-# INLINE singletonM #-}++snoc :: Array a -> a -> Array a+snoc ary x = run $ do+ mary <- new (n + 1) x+ copy ary 0 mary 0 n+ pure mary+ where+ n = length ary+{-# INLINE snoc #-}++pair :: a -> a -> Array a+pair x y = run $ do+ ary <- new 2 x+ write ary 1 y+ return ary+{-# INLINE pair #-}++read :: MArray s a -> Int -> ST s a+read ary _i@(I# i#) = ST $ \ s ->+ CHECK_BOUNDS("read", unsafeLengthM ary, _i)+ readSmallArray# (unMArray ary) i# s+{-# INLINE read #-}++write :: MArray s a -> Int -> a -> ST s ()+write ary _i@(I# i#) b = ST $ \ s ->+ CHECK_BOUNDS("write", unsafeLengthM ary, _i)+ case writeSmallArray# (unMArray ary) i# b s of+ s' -> (# s' , () #)+{-# INLINE write #-}++-- | Note that we don't have an 'index' function with type+--+-- > Array a -> Int -> a+--+-- We used to have it, but it was prone to creating thunks. See #538.+index# :: Array a -> Int -> (# a #)+index# ary _i@(I# i#) =+ CHECK_BOUNDS("index#", length ary, _i)+ indexSmallArray# (unArray ary) i#+{-# INLINE index# #-}++indexM :: Array a -> Int -> ST s a+indexM ary _i@(I# i#) =+ CHECK_BOUNDS("indexM", length ary, _i)+ case indexSmallArray# (unArray ary) i# of (# b #) -> return b+{-# INLINE indexM #-}++unsafeFreeze :: MArray s a -> ST s (Array a)+unsafeFreeze mary+ = ST $ \s -> case unsafeFreezeSmallArray# (unMArray mary) s of+ (# s', ary #) -> (# s', Array ary #)+{-# INLINE unsafeFreeze #-}++unsafeThaw :: Array a -> ST s (MArray s a)+unsafeThaw ary+ = ST $ \s -> case unsafeThawSmallArray# (unArray ary) s of+ (# s', mary #) -> (# s', MArray mary #)+{-# INLINE unsafeThaw #-}++run :: (forall s . ST s (MArray s e)) -> Array e+run act = runST $ act >>= unsafeFreeze+{-# INLINE run #-}++-- | Unsafely copy the elements of an array. Array bounds are not checked.+copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s ()+copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) =+ CHECK_LE("copy", _sidx + _n, length src)+ CHECK_LE("copy", _didx + _n, unsafeLengthM dst)+ ST $ \ s# ->+ case copySmallArray# (unArray src) sidx# (unMArray dst) didx# n# s# of+ s2 -> (# s2, () #)++-- | Unsafely copy the elements of an array. Array bounds are not checked.+copyM :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()+copyM !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) =+ CHECK_BOUNDS("copyM: src", unsafeLengthM src, _sidx + _n - 1)+ CHECK_BOUNDS("copyM: dst", unsafeLengthM dst, _didx + _n - 1)+ ST $ \ s# ->+ case copySmallMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of+ s2 -> (# s2, () #)++cloneM :: MArray s a -> Int -> Int -> ST s (MArray s a)+cloneM _mary@(MArray mary#) _off@(I# off#) _len@(I# len#) =+ CHECK_BOUNDS("cloneM_off", unsafeLengthM _mary, _off)+ CHECK_BOUNDS("cloneM_end", unsafeLengthM _mary, _off + _len - 1)+ ST $ \ s ->+ case cloneSmallMutableArray# mary# off# len# s of+ (# s', mary'# #) -> (# s', MArray mary'# #)++-- | \(O(n)\) Insert an element at the given position in this array,+-- increasing its size by one.+insert :: Array e -> Int -> e -> Array e+insert ary idx b = runST (insertM ary idx b)+{-# INLINE insert #-}++-- | \(O(n)\) Insert an element at the given position in this array,+-- increasing its size by one.+insertM :: Array e -> Int -> e -> ST s (Array e)+insertM ary idx b =+ CHECK_BOUNDS("insertM", count + 1, idx)+ do mary <- new (count+1) b+ copy ary 0 mary 0 idx+ copy ary idx mary (idx+1) (count-idx)+ unsafeFreeze mary+ where !count = length ary+{-# INLINE insertM #-}++-- | \(O(n)\) Update the element at the given position in this array.+update :: Array e -> Int -> e -> Array e+update ary idx b = runST (updateM ary idx b)+{-# INLINE update #-}++-- | \(O(n)\) Update the element at the given position in this array.+updateM :: Array e -> Int -> e -> ST s (Array e)+updateM ary idx b =+ CHECK_BOUNDS("updateM", count, idx)+ do mary <- thaw ary 0 count+ write mary idx b+ unsafeFreeze mary+ where !count = length ary+{-# INLINE updateM #-}++-- | \(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+updateWith' ary idx f+ | (# x #) <- index# ary idx+ = update ary idx $! f x+{-# INLINE updateWith' #-}++-- | \(O(1)\) Update the element at the given position in this array,+-- without copying.+unsafeUpdateM :: Array e -> Int -> e -> ST s ()+unsafeUpdateM ary idx b =+ CHECK_BOUNDS("unsafeUpdateM", length ary, idx)+ do mary <- unsafeThaw ary+ write mary idx b+ _ <- unsafeFreeze mary+ return ()+{-# INLINE unsafeUpdateM #-}++foldl' :: (b -> a -> b) -> b -> Array a -> b+foldl' f = \ z0 ary0 -> foldl'_ ary0 (length ary0) 0 z0+ where+ foldl'_ !ary n i !z+ | i >= n = z+ | otherwise+ = case index# ary i of+ (# x #) -> foldl'_ ary n (i+1) (f z x)+{-# INLINE foldl' #-}++foldr' :: (a -> b -> b) -> b -> Array a -> b+foldr' f = \ z0 ary0 -> go ary0 (length ary0 - 1) z0+ where+ go !_ary (-1) z = z+ go !ary i !z+ | (# x #) <- index# ary i+ = go ary (i - 1) (f x z)+{-# INLINE foldr' #-}++foldr :: (a -> b -> b) -> b -> Array a -> b+foldr f = \ z0 ary0 -> foldr_ ary0 (length ary0) 0 z0+ where+ foldr_ !ary n i z+ | i >= n = z+ | otherwise+ = case index# ary i of+ (# x #) -> f x (foldr_ ary n (i+1) z)+{-# INLINE foldr #-}++foldl :: (b -> a -> b) -> b -> Array a -> b+foldl f = \ z0 ary0 -> go ary0 (length ary0 - 1) z0+ where+ go _ary (-1) z = z+ go ary i z+ | (# x #) <- index# ary i+ = f (go ary (i - 1) z) x+{-# INLINE foldl #-}++-- We go to a bit of trouble here to avoid appending an extra mempty.+-- The below implementation is by Mateusz Kowalczyk, who indicates that+-- benchmarks show it to be faster than one that avoids lifting out+-- lst.+foldMap :: Monoid m => (a -> m) -> Array a -> m+foldMap f = \ary0 -> case length ary0 of+ 0 -> mempty+ len ->+ let !lst = len - 1+ go i | (# x #) <- index# ary0 i, let fx = f x =+ if i == lst then fx else fx `mappend` go (i + 1)+ in go 0+{-# INLINE foldMap #-}++-- | Verifies that a predicate holds for all elements of an array.+all :: (a -> Bool) -> Array a -> Bool+all p = foldr (\a acc -> p a && acc) True+{-# INLINE all #-}++undefinedElem :: a+undefinedElem = error "Data.HashMap.Internal.Array: Undefined element"+{-# NOINLINE undefinedElem #-}++thaw :: Array e -> Int -> Int -> ST s (MArray s e)+thaw !ary !_o@(I# o#) _n@(I# n#) =+ CHECK_LE("thaw", _o + _n, length ary)+ ST $ \ s -> case thawSmallArray# (unArray ary) o# n# s of+ (# s2, mary# #) -> (# s2, MArray mary# #)+{-# INLINE thaw #-}++-- | \(O(n)\) Delete an element at the given position in this array,+-- decreasing its size by one.+delete :: Array e -> Int -> Array e+delete ary idx = runST (deleteM ary idx)+{-# INLINE delete #-}++-- | \(O(n)\) Delete an element at the given position in this array,+-- decreasing its size by one.+deleteM :: Array e -> Int -> ST s (Array e)+deleteM ary idx = do+ CHECK_BOUNDS("deleteM", count, idx)+ do mary <- new_ (count-1)+ copy ary 0 mary 0 idx+ copy ary (idx+1) mary idx (count-(idx+1))+ unsafeFreeze mary+ where !count = length ary+{-# INLINE deleteM #-}++map :: forall a b . (a -> b) -> Array a -> Array b+map f = \ ary ->+ let !n = length ary+ in run $ do+ mary <- new_ n+ go ary mary 0 n+ return mary+ where+ go :: forall s. Array a -> MArray s b -> Int -> Int -> ST s ()+ go ary mary i n+ | i >= n = return ()+ | otherwise = do+ x <- indexM ary i+ write mary i $ f x+ go ary mary (i+1) n+{-# INLINE map #-}++-- | Strict version of 'map'.+map' :: forall a b . (a -> b) -> Array a -> Array b+map' f = \ ary ->+ let !n = length ary+ in run $ do+ mary <- new_ n+ go ary mary 0 n+ return mary+ where+ go :: forall s . Array a -> MArray s b -> Int -> Int -> ST s ()+ go ary mary i n+ | i >= n = return ()+ | otherwise = do+ x <- indexM ary i+ write mary i $! f x+ go ary mary (i+1) n+{-# INLINE map' #-}++filter :: forall a . (a -> Bool) -> Array a -> Array a+filter f = \ ary ->+ let !n = length ary+ in run $ do+ mary <- new_ n+ len <- go_filter ary mary 0 0 n+ shrink mary len+ where+ -- Without the @!@ on @ary@ we end up reboxing the array when using+ -- 'differenceCollisions'. See+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/26525.+ go_filter :: forall s . Array a -> MArray s a -> Int -> Int -> Int -> ST s Int+ go_filter !ary !mary !iAry !iMary !n+ | iAry >= n = return iMary+ | otherwise = do+ x <- indexM ary iAry+ if f x+ then do+ write mary iMary x+ go_filter ary mary (iAry + 1) (iMary + 1) n+ else go_filter ary mary (iAry + 1) iMary n+{-# INLINE filter #-}++mapMaybe :: forall a b . (a -> Maybe b) -> Array a -> Array b+mapMaybe f = \ ary ->+ let !n = length ary+ in run $ do+ mary <- new_ n+ len <- go_mapMaybe ary mary 0 0 n+ shrink mary len+ where+ go_mapMaybe :: forall s . Array a -> MArray s b -> Int -> Int -> Int -> ST s Int+ go_mapMaybe !ary !mary !iAry !iMary !n+ | iAry >= n = return iMary+ | otherwise = do+ x <- indexM ary iAry+ case f x of+ Nothing -> go_mapMaybe ary mary (iAry + 1) iMary n+ Just y -> do+ write mary iMary y+ go_mapMaybe ary mary (iAry + 1) (iMary + 1) n+{-# INLINE mapMaybe #-}++fromList :: forall a . Int -> [a] -> Array a+fromList n xs0 =+ CHECK_EQ("fromList", n, Prelude.length xs0)+ run $ do+ mary <- new_ n+ go xs0 mary 0+ return mary+ where+ go :: forall s . [a] -> MArray s a -> Int -> ST s ()+ go [] !_ !_ = return ()+ go (x:xs) mary i = do write mary i x+ go xs mary (i+1)++fromList' :: forall a . Int -> [a] -> Array a+fromList' n xs0 =+ CHECK_EQ("fromList'", n, Prelude.length xs0)+ run $ do+ mary <- new_ n+ go xs0 mary 0+ return mary+ where+ go :: forall s . [a] -> MArray s a -> Int -> ST s ()+ go [] !_ !_ = return ()+ go (!x:xs) mary i = do write mary i x+ go xs mary (i+1)++#if defined(__GLASGOW_HASKELL__)+-- | @since 0.2.17.0+instance TH.Lift a => TH.Lift (Array a) where+ liftTyped ar = [|| fromList' arlen arlist ||]+ where+ arlen = length ar+ arlist = toList ar+#endif++toList :: Array a -> [a]+toList = foldr (:) []++newtype STA a = STA {_runSTA :: forall s. SmallMutableArray# s a -> ST s (Array a)}++runSTA :: Int -> STA a -> Array a+runSTA !n (STA m) = runST $ new_ n >>= \ (MArray ar) -> m ar++traverse :: Applicative f => (a -> f b) -> Array a -> f (Array b)+traverse f = \ !ary ->+ let+ !len = length ary+ go !i+ | i == len = pure $ STA $ \mary -> unsafeFreeze (MArray mary)+ | (# x #) <- index# ary i+ = liftA2 (\b (STA m) -> STA $ \mary ->+ write (MArray mary) i b >> m mary)+ (f x) (go (i + 1))+ in runSTA len <$> go 0+{-# INLINE [1] traverse #-}++-- TODO: Would it be better to just use a lazy traversal+-- and then force the elements of the result? My guess is+-- yes.+traverse' :: Applicative f => (a -> f b) -> Array a -> f (Array b)+traverse' f = \ !ary ->+ let+ !len = length ary+ go !i+ | i == len = pure $ STA $ \mary -> unsafeFreeze (MArray mary)+ | (# x #) <- index# ary i+ = liftA2 (\ !b (STA m) -> STA $ \mary ->+ write (MArray mary) i b >> m mary)+ (f x) (go (i + 1))+ in runSTA len <$> go 0+{-# INLINE [1] traverse' #-}++-- Traversing in ST, we don't need to get fancy; we+-- can just do it directly.+traverseST :: (a -> ST s b) -> Array a -> ST s (Array b)+traverseST f = \ ary0 ->+ let+ !len = length ary0+ go k !mary+ | k == len = return mary+ | otherwise = do+ x <- indexM ary0 k+ y <- f x+ write mary k y+ go (k + 1) mary+ in new_ len >>= (go 0 >=> unsafeFreeze)+{-# INLINE traverseST #-}++traverseIO :: (a -> IO b) -> Array a -> IO (Array b)+traverseIO f = \ ary0 ->+ let+ !len = length ary0+ go k !mary+ | k == len = return mary+ | otherwise = do+ x <- stToIO $ indexM ary0 k+ y <- f x+ stToIO $ write mary k y+ go (k + 1) mary+ in stToIO (new_ len) >>= (go 0 >=> stToIO . unsafeFreeze)+{-# INLINE traverseIO #-}+++-- Why don't we have similar RULES for traverse'? The efficient+-- way to traverse strictly in IO or ST is to force results as+-- they come in, which leads to different semantics. In particular,+-- we need to ensure that+--+-- traverse' (\x -> print x *> pure undefined) xs+--+-- will actually print all the values and then return undefined.+-- We could add a strict mapMWithIndex, operating in an arbitrary+-- Monad, that supported such rules, but we don't have that right now.+{-# RULES+"traverse/ST" forall f. traverse f = traverseST f+"traverse/IO" forall f. traverse f = traverseIO f+ #-}
+ Data/HashMap/Internal/Debug.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnboxedTuples #-}++-- | = 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++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+ , (# st #) <- A.index# ary 0+ , isLeafOrCollision st+ = Invalid INV5_BitmapIndexed_invalid_single_subtree p+ | otherwise = go b+ where+ go 0 = Valid+ go b' = case A.index# ary i of+ (# st #) -> validInternal (addSubHash p (fromIntegral c)) st <> go b''+ where+ c = countTrailingZeros b'+ m = 1 `unsafeShiftL` c+ i = sparseIndex b m+ b'' = b' .&. complement m++ validFull p ary = validArraySize <> validSubTrees p fullBitmap ary+ where+ n = A.length ary+ validArraySize | n == maxChildren = Valid+ | otherwise = Invalid (INV8_bad_Full_size n) p
+ Data/HashMap/Internal/List.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | = 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+--+-- Extra list functions+--+-- In separate module to aid testing.+module Data.HashMap.Internal.List+ ( isPermutationBy+ , deleteBy+ , unorderedCompare+ ) where++import Data.List (sortBy)+import Data.Maybe (fromMaybe)++-- Note: previous implementation isPermutation = null (as // bs)+-- was O(n^2) too.+--+-- This assumes lists are of equal length+isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool+isPermutationBy f = go+ where+ f' = flip f++ go [] [] = True+ go (x : xs) (y : ys)+ | f x y = go xs ys+ | otherwise = fromMaybe False $ do+ xs' <- deleteBy f' y xs+ ys' <- deleteBy f x ys+ return (go xs' ys')+ go [] (_ : _) = False+ go (_ : _) [] = False++-- The idea:+--+-- Homogenous version+--+-- uc :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering+-- uc c as bs = compare (sortBy c as) (sortBy c bs)+--+-- But as we have only (a -> b -> Ordering), we cannot directly compare+-- elements from the same list.+--+-- So when comparing elements from the list, we count how many elements are+-- "less and greater" in the other list, and use the count as a metric.+--+unorderedCompare :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering+unorderedCompare c as bs = go (sortBy cmpA as) (sortBy cmpB bs)+ where+ go [] [] = EQ+ go [] (_ : _) = LT+ go (_ : _) [] = GT+ go (x : xs) (y : ys) = c x y <> go xs ys++ cmpA a a' = compare (inB a) (inB a')+ cmpB b b' = compare (inA b) (inA b')++ inB a = (length $ filter (\b -> c a b == GT) bs, negate $ length $ filter (\b -> c a b == LT) bs)+ inA b = (length $ filter (\a -> c a b == LT) as, negate $ length $ filter (\a -> c a b == GT) as)++-- Returns Nothing is nothing deleted+deleteBy :: (a -> b -> Bool) -> a -> [b] -> Maybe [b]+deleteBy _ _ [] = Nothing+deleteBy eq x (y:ys) = if x `eq` y then Just ys else fmap (y :) (deleteBy eq x ys)
+ Data/HashMap/Internal/Strict.hs view
@@ -0,0 +1,782 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_HADDOCK not-home #-}++------------------------------------------------------------------------+-- |+-- Module : Data.HashMap.Strict+-- Copyright : 2010-2012 Johan Tibell+-- License : BSD-style+-- Maintainer : johan.tibell@gmail.com+-- Portability : portable+--+-- = 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+--+-- A map from /hashable/ keys to values. A map cannot contain+-- duplicate keys; each key can map to at most one value. A 'HashMap'+-- makes no guarantees as to the order of its elements.+--+-- The implementation is based on /hash array mapped tries/. A+-- 'HashMap' is often faster than other tree-based set types,+-- especially when key comparison is expensive, as in the case of+-- strings.+--+-- Many operations have a average-case complexity of \(O(\log n)\). The+-- implementation uses a large base (i.e. 16 or 32) so in practice these+-- operations are constant time.+module Data.HashMap.Internal.Strict+ (+ -- * Strictness properties+ -- $strictness++ HashMap++ -- * Construction+ , HM.empty+ , singleton++ -- * Basic interface+ , HM.null+ , HM.size+ , HM.member+ , HM.lookup+ , (HM.!?)+ , HM.findWithDefault+ , HM.lookupDefault+ , (HM.!)+ , HM.lookupKey+ , insert+ , insertWith+ , HM.delete+ , adjust+ , update+ , alter+ , alterF+ , HM.isSubmapOf+ , HM.isSubmapOfBy++ -- * Combine+ -- ** Union+ , HM.union+ , unionWith+ , unionWithKey+ , HM.unions++ -- ** Compose+ , HM.compose++ -- * Transformations+ , map+ , mapWithKey+ , traverseWithKey+ , HM.mapKeys++ -- * Difference and intersection+ , HM.difference+ , differenceWith+ , differenceWithKey+ , HM.intersection+ , intersectionWith+ , intersectionWithKey+ , HM.disjoint++ -- * Folds+ , HM.foldMapWithKey+ , HM.foldr'+ , HM.foldl'+ , HM.foldrWithKey'+ , HM.foldlWithKey'+ , HM.foldr+ , HM.foldl+ , HM.foldrWithKey+ , HM.foldlWithKey++ -- * Filter+ , HM.filter+ , HM.filterWithKey+ , mapMaybe+ , mapMaybeWithKey++ -- * Conversions+ , HM.keys+ , HM.elems++ -- ** Lists+ , HM.toList+ , fromList+ , fromListWith+ , fromListWithKey+ ) where++import Control.Applicative (Const (..))+import Control.Monad.ST (ST, runST)+import Data.Bits ((.&.), (.|.))+import Data.Coerce (coerce)+import Data.Functor.Identity (Identity (..))+-- See Note [Imports from Data.HashMap.Internal]+import Data.Hashable (Hashable)+import Data.HashMap.Internal (Hash, HashMap (..), Leaf (..), LookupRes (..),+ Shift, fullBitmap, hash, index, mask, nextShift,+ ptrEq, sparseIndex)+import Prelude hiding (lookup, map)++-- See Note [Imports from Data.HashMap.Internal]+import qualified Data.HashMap.Internal as HM+import qualified Data.HashMap.Internal.Array as A+import qualified Data.List as List+import qualified GHC.Exts as Exts++{-+Note [Imports from Data.HashMap.Internal]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is very important for code in this module not to make mistakes about+the strictness properties of any utilities. Mistakes can easily lead to space+leaks, see e.g. #383.++Therefore nearly all functions imported from Data.HashMap.Internal should be+imported qualified. Only functions that do not manipulate HashMaps or their+values are exempted.+-}++-- $strictness+--+-- This module satisfies the following strictness properties:+--+-- 1. Key arguments are evaluated to WHNF;+--+-- 2. Keys and values are evaluated to WHNF before they are stored in+-- the map.++------------------------------------------------------------------------+-- * Construction++-- | \(O(1)\) Construct a map with a single element.+singleton :: (Hashable k) => k -> v -> HashMap k v+singleton k !v = HM.singleton k v++------------------------------------------------------------------------+-- * Basic interface++-- | \(O(\log n)\) Associate the specified value with the specified+-- key in this map. If this map previously contained a mapping for+-- the key, the old value is replaced.+insert :: Hashable k => k -> v -> HashMap k v -> HashMap k v+insert k !v = HM.insert k v+{-# INLINABLE insert #-}++-- | \(O(\log n)\) Associate the value with the key in this map. If+-- this map previously contained a mapping for the key, the old value+-- is replaced by the result of applying the given function to the new+-- and old value. Example:+--+-- > insertWith f k v map+-- > where f new old = new + old+insertWith :: Hashable k => (v -> v -> v) -> k -> v -> HashMap k v+ -> HashMap k v+insertWith f k0 v0 m0 = go h0 k0 v0 0 m0+ where+ h0 = hash k0+ go !h !k x !_ Empty = leaf h k x+ go h k x s t@(Leaf hy l@(L ky y))+ | hy == h = if ky == k+ then leaf h k (f x y)+ else x `seq` HM.collision h l (L k x)+ | otherwise = x `seq` runST (HM.two s h k x hy t)+ go h k x s (BitmapIndexed b ary)+ | b .&. m == 0 =+ let ary' = A.insert ary i $! leaf h k x+ in HM.bitmapIndexedOrFull (b .|. m) ary'+ | otherwise =+ case A.index# ary i of+ (# st #) ->+ let !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) =+ case A.index# ary i of+ (# st #) ->+ let !st' = go h k x (nextShift s) st+ ary' = HM.updateFullArray ary i st'+ in Full ary'+ where i = index h s+ go h k x s t@(Collision hy v)+ | h == hy = Collision h (updateOrSnocWith f k x v)+ | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)+{-# INLINABLE insertWith #-}++-- | In-place update version of insertWith+unsafeInsertWith :: Hashable k => (v -> v -> v) -> k -> v -> HashMap k v+ -> HashMap k v+unsafeInsertWith f k0 v0 m0 = unsafeInsertWithKey (const f) k0 v0 m0+{-# INLINABLE unsafeInsertWith #-}++unsafeInsertWithKey :: forall k v. Hashable k => (k -> v -> v -> v) -> k -> v -> HashMap k v+ -> HashMap k v+unsafeInsertWithKey f k0 v0 m0 = runST (go h0 k0 v0 0 m0)+ where+ h0 = hash k0+ go :: forall s. Hash -> k -> v -> Shift -> HashMap k v -> ST s (HashMap k v)+ go !h !k x !_ Empty = return $! leaf h k x+ go h k x s t@(Leaf hy l@(L ky y))+ | hy == h = if ky == k+ then return $! leaf h k (f k x y)+ else do+ let l' = x `seq` L k x+ return $! HM.collision h l l'+ | otherwise = x `seq` HM.two s h k x hy t+ go h k x s t@(BitmapIndexed b ary)+ | b .&. m == 0 = do+ ary' <- A.insertM ary i $! leaf h k x+ return $! HM.bitmapIndexedOrFull (b .|. m) ary'+ | otherwise = do+ st <- A.indexM ary i+ 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 (nextShift s) st+ A.unsafeUpdateM ary i st'+ return t+ where i = index h s+ go h k x s t@(Collision hy v)+ | h == hy = return $! Collision h (updateOrSnocWithKey f k x v)+ | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)+{-# INLINABLE unsafeInsertWithKey #-}++-- | \(O(\log n)\) Adjust the value tied to a given key in this map only+-- if it is present. Otherwise, leave the map alone.+adjust :: Hashable k => (v -> v) -> k -> HashMap k v -> HashMap k v+adjust f k0 m0 = go h0 k0 0 m0+ where+ h0 = hash k0+ go !_ !_ !_ Empty = Empty+ go h k _ t@(Leaf hy (L ky y))+ | hy == h && ky == k = leaf h k (f y)+ | otherwise = t+ go h k s t@(BitmapIndexed b ary)+ | b .&. m == 0 = t+ | otherwise =+ case A.index# ary i of+ (# st #) ->+ let !st' = go h k (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 s (Full ary) =+ case A.index# ary i of+ (# st #) ->+ let !st' = go h k (nextShift s) st+ ary' = HM.updateFullArray ary i st'+ in Full ary'+ where i = index h s+ go h k _ t@(Collision hy v)+ | h == hy = Collision h (updateWith f k v)+ | otherwise = t+{-# INLINABLE adjust #-}++-- | \(O(\log n)\) The expression @('update' f k map)@ updates the value @x@ at @k@+-- (if it is in the map). If @(f x)@ is 'Nothing', the element is deleted.+-- If it is @('Just' y)@, the key @k@ is bound to the new value @y@.+update :: Hashable k => (a -> Maybe a) -> k -> HashMap k a -> HashMap k a+update f = alter (>>= f)+{-# INLINABLE update #-}++-- | \(O(\log n)\) The expression @('alter' f k map)@ alters the value @x@ at @k@, or+-- absence thereof.+--+-- 'alter' can be used to insert, delete, or update a value in a map. In short:+--+-- @+-- 'lookup' k ('alter' f k m) = f ('lookup' k m)+-- @+alter :: Hashable k => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v+alter f k 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+-- @k@, or absence thereof.+--+-- 'alterF' can be used to insert, delete, or update a value in a map.+--+-- Note: 'alterF' is a flipped version of the 'at' combinator from+-- <https://hackage.haskell.org/package/lens/docs/Control-Lens-At.html#v:at Control.Lens.At>.+--+-- @since 0.2.10+alterF :: (Functor f, Hashable k)+ => (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)+-- Special care is taken to only calculate the hash once. When we rewrite+-- with RULES, we also ensure that we only compare the key for equality+-- once. We force the value of the map for consistency with the rewritten+-- version; otherwise someone could tell the difference using a lazy+-- @f@ and a functor that is similar to Const but not actually Const.+alterF f = \ !k !m ->+ let !h = hash k+ mv = HM.lookup' h k m+ in (<$> f mv) $ \case+ Nothing -> maybe m (const (HM.delete' h k m)) mv+ Just !v' -> HM.insert' h k v' m++-- We rewrite this function unconditionally in RULES, but we expose+-- an unfolding just in case it's used in a context where the rules+-- don't fire.+{-# INLINABLE [0] alterF #-}++-- See notes in Data.HashMap.Internal+test_bottom :: a+test_bottom = error "Data.HashMap.alterF internal error: hit test_bottom"++bogus# :: (# #) -> (# a #)+bogus# _ = error "Data.HashMap.alterF internal error: hit bogus#"++impossibleAdjust :: a+impossibleAdjust = error "Data.HashMap.alterF internal error: impossible adjust"++{-# RULES++-- See detailed notes on alterF rules in Data.HashMap.Internal.++"alterFWeird" forall f. alterF f =+ alterFWeird (f Nothing) (f (Just test_bottom)) f++"alterFconstant" forall (f :: Maybe a -> Identity (Maybe a)) x.+ alterFWeird x x f = \ !k !m ->+ Identity (case runIdentity x of {Nothing -> HM.delete k m; Just a -> insert k a m})++"alterFinsertWith" [1] forall (f :: Maybe a -> Identity (Maybe a)) x y.+ alterFWeird (coerce (Just x)) (coerce (Just y)) f =+ coerce (HM.insertModifying x (\mold -> case runIdentity (f (Just mold)) of+ Nothing -> bogus# (# #)+ Just !new -> (# new #)))++-- This rule is written a bit differently than the one for lazy+-- maps because the adjust here is strict. We could write it the+-- same general way anyway, but this seems simpler.+"alterFadjust" forall (f :: Maybe a -> Identity (Maybe a)) x.+ alterFWeird (coerce Nothing) (coerce (Just x)) f =+ coerce (adjust (\a -> case runIdentity (f (Just a)) of+ Just a' -> a'+ Nothing -> impossibleAdjust))++"alterFlookup" forall _ign1 _ign2 (f :: Maybe a -> Const r (Maybe a)) .+ alterFWeird _ign1 _ign2 f = \ !k !m -> Const (getConst (f (HM.lookup k m)))+ #-}++-- This is a very unsafe version of alterF used for RULES. When calling+-- alterFWeird x y f, the following *must* hold:+--+-- x = f Nothing+-- y = f (Just _|_)+--+-- Failure to abide by these laws will make demons come out of your nose.+alterFWeird+ :: (Functor f, Hashable k)+ => f (Maybe v)+ -> f (Maybe v)+ -> (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)+alterFWeird _ _ f = alterFEager f+{-# INLINE [0] alterFWeird #-}++-- | This is the default version of alterF that we use in most non-trivial+-- cases. It's called "eager" because it looks up the given key in the map+-- eagerly, whether or not the given function requires that information.+alterFEager :: (Functor f, Hashable k)+ => (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)+alterFEager f !k !m = (<$> f mv) $ \fres ->+ case fres of++ ------------------------------+ -- Delete the key from the map.+ Nothing -> case lookupRes of++ -- Key did not exist in the map to begin with, no-op+ Absent -> m++ -- Key did exist, no collision+ Present _ collPos -> HM.deleteKeyExists collPos h k m++ ------------------------------+ -- Update value+ Just !v' -> case lookupRes of++ -- Key did not exist before, insert v' under a new key+ Absent -> HM.insertNewKey h k v' m++ -- Key existed before, no hash collision+ Present v collPos ->+ if v `ptrEq` v'+ -- If the value is identical, no-op+ then m+ -- If the value changed, update the value.+ else HM.insertKeyExists collPos h k v' m++ where !h = hash k+ !lookupRes = HM.lookupRecordCollision h k m+ !mv = HM.lookupResToMaybe lookupRes+{-# INLINABLE alterFEager #-}++------------------------------------------------------------------------+-- * Combine++-- | \(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 => (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 => (k -> v -> v -> v) -> HashMap k v -> HashMap k v+ -> HashMap k v+unionWithKey f = go 0+ where+ -- empty vs. anything+ go !_ t1 Empty = t1+ go _ Empty t2 = t2+ -- leaf vs. leaf+ go s t1@(Leaf h1 l1@(L k1 v1)) t2@(Leaf h2 l2@(L k2 v2))+ | h1 == h2 = if k1 == k2+ then leaf h1 k1 (f k1 v1 v2)+ else HM.collision h1 l1 l2+ | otherwise = goDifferentHash s h1 h2 t1 t2+ go s t1@(Leaf h1 (L k1 v1)) t2@(Collision h2 ls2)+ | h1 == h2 = Collision h1 (updateOrSnocWithKey f k1 v1 ls2)+ | otherwise = goDifferentHash s h1 h2 t1 t2+ go s t1@(Collision h1 ls1) t2@(Leaf h2 (L k2 v2))+ | h1 == h2 = Collision h1 (updateOrSnocWithKey (flip . f) k2 v2 ls1)+ | otherwise = goDifferentHash s h1 h2 t1 t2+ go s t1@(Collision h1 ls1) t2@(Collision h2 ls2)+ | h1 == h2 = Collision h1 (HM.updateOrConcatWithKey (\k a b -> let !v = f k a b in (# v #)) ls1 ls2)+ | otherwise = goDifferentHash s h1 h2 t1 t2+ -- branch vs. branch+ go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) =+ let b' = b1 .|. b2+ 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 (nextShift s)) b1 fullBitmap ary1 ary2+ in Full ary'+ go s (Full ary1) (BitmapIndexed b2 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 (nextShift s)) fullBitmap fullBitmap+ ary1 ary2+ in Full ary'+ -- leaf vs. branch+ go s (BitmapIndexed b1 ary1) t2+ | b1 .&. m2 == 0 = let ary' = A.insert ary1 i t2+ b' = b1 .|. m2+ in HM.bitmapIndexedOrFull b' ary'+ | otherwise = let ary' = A.updateWith' ary1 i $ \st1 ->+ go (nextShift s) st1 t2+ in BitmapIndexed b1 ary'+ where+ h2 = leafHashCode t2+ m2 = mask h2 s+ i = sparseIndex b1 m2+ go s t1 (BitmapIndexed b2 ary2)+ | b2 .&. m1 == 0 = let ary' = A.insert ary2 i $! t1+ b' = b2 .|. m1+ in HM.bitmapIndexedOrFull b' ary'+ | otherwise = let ary' = A.updateWith' ary2 i $ \st2 ->+ go (nextShift s) t1 st2+ in BitmapIndexed b2 ary'+ where+ h1 = leafHashCode t1+ m1 = mask h1 s+ i = sparseIndex b2 m1+ go s (Full ary1) t2 =+ let h2 = leafHashCode t2+ i = index h2 s+ ary' = HM.updateFullArrayWith' 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.updateFullArrayWith' ary2 i $ \st2 -> go (nextShift s) t1 st2+ in Full ary'++ leafHashCode (Leaf h _) = h+ leafHashCode (Collision h _) = h+ leafHashCode _ = error "leafHashCode"++ goDifferentHash s 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+ m1 = mask h1 s+ m2 = mask h2 s+{-# INLINE unionWithKey #-}++------------------------------------------------------------------------+-- * Transformations++-- | \(O(n)\) Transform this map by applying a function to every value.+mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2+mapWithKey f = go+ where+ go Empty = Empty+ go (Leaf h (L k v)) = leaf h k (f k v)+ go (BitmapIndexed b ary) = BitmapIndexed b $ A.map' go ary+ go (Full ary) = Full $ A.map' go ary+ go (Collision h ary) =+ Collision h $ A.map' (\ (L k v) -> let !v' = f k v in L k v') ary+{-# INLINE mapWithKey #-}++-- | \(O(n)\) Transform this map by applying a function to every value.+map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2+map f = mapWithKey (const f)+{-# INLINE map #-}+++------------------------------------------------------------------------+-- * Filter++-- | \(O(n)\) Transform this map by applying a function to every value+-- and retaining only some of them.+mapMaybeWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2+mapMaybeWithKey f = HM.filterMapAux onLeaf onColl+ where onLeaf (Leaf h (L k v)) | Just v' <- f k v = Just (leaf h k v')+ onLeaf _ = Nothing++ onColl (L k v) | Just !v' <- f k v = Just (L k v')+ | otherwise = Nothing+{-# INLINE mapMaybeWithKey #-}++-- | \(O(n)\) Transform this map by applying a function to every value+-- and retaining only some of them.+mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2+mapMaybe f = mapMaybeWithKey (const f)+{-# INLINE mapMaybe #-}++-- | \(O(n)\) Perform an 'Applicative' action for each key-value pair+-- in a 'HashMap' and produce a 'HashMap' of all the results. Each 'HashMap'+-- will be strict in all its values.+--+-- @+-- traverseWithKey f = fmap ('map' id) . "Data.HashMap.Lazy".'Data.HashMap.Lazy.traverseWithKey' f+-- @+--+-- Note: the order in which the actions occur is unspecified. In particular,+-- when the map contains hash collisions, the order in which the actions+-- associated with the keys involved will depend in an unspecified way on+-- their insertion order.+traverseWithKey+ :: Applicative f+ => (k -> v1 -> f v2)+ -> HashMap k v1 -> f (HashMap k v2)+traverseWithKey f = go+ where+ go Empty = pure Empty+ go (Leaf h (L k v)) = leaf h k <$> f k v+ go (BitmapIndexed b ary) = BitmapIndexed b <$> A.traverse' go ary+ go (Full ary) = Full <$> A.traverse' go ary+ go (Collision h ary) =+ Collision h <$> A.traverse' (\ (L k v) -> (L k $!) <$> f k v) ary+{-# INLINE traverseWithKey #-}++------------------------------------------------------------------------+-- * Difference and intersection++-- | \(O(n \log m)\) Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+differenceWith :: Hashable k => (v -> w -> Maybe v) -> HashMap k v -> HashMap k w -> HashMap k v+differenceWith f = HM.differenceWithKey $+ \_k vA vB -> case f vA vB of+ Nothing -> Nothing+ x@(Just v) -> v `seq` x+{-# INLINE differenceWith #-}++-- | \(O(n \log m)\) Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- @since 0.2.21+differenceWithKey :: Eq k => (k -> v -> w -> Maybe v) -> HashMap k v -> HashMap k w -> HashMap k v+differenceWithKey f = HM.differenceWithKey $+ \k vA vB -> case f k vA vB of+ Nothing -> Nothing+ x@(Just v) -> v `seq` x+{-# INLINE differenceWithKey #-}++-- | \(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 => (v1 -> v2 -> v3) -> HashMap k v1+ -> HashMap k v2 -> HashMap k v3+intersectionWith f = Exts.inline intersectionWithKey $ const f+{-# INLINABLE intersectionWith #-}++-- | \(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 => (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 #-}++------------------------------------------------------------------------+-- ** Lists++-- | \(O(n \log n)\) Construct a map with the supplied mappings. If the+-- list contains duplicate mappings, the later mappings take+-- precedence.+fromList :: Hashable k => [(k, v)] -> HashMap k v+fromList = List.foldl' (\ m (k, !v) -> HM.unsafeInsert k v m) HM.empty+{-# INLINABLE fromList #-}++-- | \(O(n \log n)\) Construct a map from a list of elements. Uses+-- the provided function @f@ to merge duplicate entries with+-- @(f newVal oldVal)@.+--+-- === Examples+--+-- Given a list @xs@, create a map with the number of occurrences of each+-- element in @xs@:+--+-- > let xs = ['a', 'b', 'a']+-- > in fromListWith (+) [ (x, 1) | x <- xs ]+-- >+-- > = fromList [('a', 2), ('b', 1)]+--+-- Given a list of key-value pairs @xs :: [(k, v)]@, group all values by their+-- keys and return a @HashMap k [v]@.+--+-- > let xs = ('a', 1), ('b', 2), ('a', 3)]+-- > in fromListWith (++) [ (k, [v]) | (k, v) <- xs ]+-- >+-- > = fromList [('a', [3, 1]), ('b', [2])]+--+-- Note that the lists in the resulting map contain elements in reverse order+-- 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.+--+-- > fromListWith f [(k, a), (k, b), (k, c), (k, d)]+-- > = fromList [(k, f d (f c (f b a)))]+fromListWith :: Hashable k => (v -> v -> v) -> [(k, v)] -> HashMap k v+fromListWith f = List.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) HM.empty+{-# INLINE fromListWith #-}++-- | \(O(n \log n)\) Construct a map from a list of elements. Uses+-- the provided function to merge duplicate entries.+--+-- === Examples+--+-- Given a list of key-value pairs where the keys are of different flavours, e.g:+--+-- > data Key = Div | Sub+--+-- and the values need to be combined differently when there are duplicates,+-- depending on the key:+--+-- > combine Div = div+-- > combine Sub = (-)+--+-- then @fromListWithKey@ can be used as follows:+--+-- > fromListWithKey combine [(Div, 2), (Div, 6), (Sub, 2), (Sub, 3)]+-- > = fromList [(Div, 3), (Sub, 1)]+--+-- More generally, duplicate entries are accumulated as follows;+--+-- > fromListWith f [(k, a), (k, b), (k, c), (k, d)]+-- > = fromList [(k, f k d (f k c (f k b a)))]+--+-- @since 0.2.11+fromListWithKey :: Hashable k => (k -> v -> v -> v) -> [(k, v)] -> HashMap k v+fromListWithKey f = List.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) HM.empty+{-# INLINE fromListWithKey #-}++------------------------------------------------------------------------+-- Array operations++updateWith :: Eq k => (v -> v) -> k -> A.Array (Leaf k v) -> A.Array (Leaf k v)+updateWith f k0 ary0 = go k0 ary0 0 (A.length ary0)+ where+ go !k !ary !i !n+ | i >= n = ary+ | otherwise = case A.index# ary i of+ (# L kx y #) | k == kx -> let !v' = f y in A.update ary i (L k v')+ | otherwise -> go k ary (i+1) n+{-# INLINABLE updateWith #-}++-- | Append the given key and value to the array. If the key is+-- already present, instead update the value of the key by applying+-- the given function to the new and old value (in that order). The+-- value is always evaluated to WHNF before being inserted into the+-- array.+updateOrSnocWith :: Eq k => (v -> v -> v) -> k -> v -> A.Array (Leaf k v)+ -> A.Array (Leaf k v)+updateOrSnocWith f = updateOrSnocWithKey (const f)+{-# INLINABLE updateOrSnocWith #-}++-- | Append the given key and value to the array. If the key is+-- already present, instead update the value of the key by applying+-- the given function to the new and old value (in that order). The+-- value is always evaluated to WHNF before being inserted into the+-- array.+updateOrSnocWithKey :: Eq k => (k -> v -> v -> v) -> k -> v -> A.Array (Leaf k v)+ -> A.Array (Leaf k v)+updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0)+ where+ go !k v !ary !i !n+ -- Not found, append to the end.+ | i >= n = A.snoc ary $! L k $! v+ | otherwise = case A.index# ary i of+ (# L kx y #) | k == kx -> let !v' = f k v y in A.update ary i (L k v')+ | otherwise -> go k v ary (i+1) n+{-# INLINABLE updateOrSnocWithKey #-}++------------------------------------------------------------------------+-- Smart constructors+--+-- These constructors make sure the value is in WHNF before it's+-- inserted into the constructor.++leaf :: Hash -> k -> v -> HashMap k v+leaf h k = \ !v -> Leaf h (L k v)+{-# INLINE leaf #-}
Data/HashMap/Lazy.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE BangPatterns, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-} ------------------------------------------------------------------------ -- | -- Module : Data.HashMap.Lazy--- Copyright : 2010-2011 Johan Tibell+-- Copyright : 2010-2012 Johan Tibell -- License : BSD-style -- Maintainer : johan.tibell@gmail.com -- Stability : provisional@@ -13,22 +14,19 @@ -- duplicate keys; each key can map to at most one value. A 'HashMap' -- makes no guarantees as to the order of its elements. ----- This map is strict in the keys and lazy in the values; keys are--- evaluated to /weak head normal form/ before they are added to the--- map.------ The implementation is based on /big-endian patricia trees/, keyed--- by a hash of the original key. A 'HashMap' is often faster than--- other tree-based maps, especially when key comparison is expensive,--- as in the case of strings.+-- The implementation is based on /hash array mapped tries/. A+-- 'HashMap' is often faster than other tree-based set types,+-- especially when key comparison is expensive, as in the case of+-- strings. ----- Many operations have a worst-case complexity of /O(min(n,W))/.--- This means that the operation can become linear in the number of--- elements with a maximum of /W/ -- the number of bits in an 'Int'--- (32 or 64).-+-- Many operations have a average-case complexity of \(O(\log n)\). The+-- implementation uses a large base (i.e. 16 or 32) so in practice these+-- operations are constant time. module Data.HashMap.Lazy (+ -- * Strictness properties+ -- $strictness+ HashMap -- * Construction@@ -38,323 +36,86 @@ -- * Basic interface , null , size+ , member , lookup+ , (!?)+ , findWithDefault , lookupDefault+ , (!)+ , lookupKey , insert- , delete , insertWith+ , delete , adjust+ , update+ , alter+ , alterF+ , isSubmapOf+ , isSubmapOfBy -- * Combine -- ** Union , union , unionWith+ , unionWithKey+ , unions + -- ** Compose+ , compose+ -- * Transformations , map+ , mapWithKey , traverseWithKey+ , mapKeys -- * Difference and intersection , difference+ , differenceWith+ , differenceWithKey , intersection+ , intersectionWith+ , intersectionWithKey+ , disjoint -- * Folds+ , foldMapWithKey+ , foldr+ , foldl+ , foldr' , foldl'+ , foldrWithKey' , foldlWithKey'- , foldr , foldrWithKey+ , foldlWithKey -- * Filter , filter , filterWithKey+ , mapMaybe+ , mapMaybeWithKey -- * Conversions- , elems , keys+ , elems -- ** Lists , toList , fromList , fromListWith- ) where--import qualified Data.FullList.Lazy as FL-import Data.Hashable (Hashable(hash))-import qualified Data.List as List-import Prelude hiding (filter, foldr, lookup, map, null, pred)--import Data.HashMap.Common----------------------------------------------------------------------------- * Basic interface---- | /O(1)/ Return 'True' if this map is empty, 'False' otherwise.-null :: HashMap k v -> Bool-null Nil = True-null _ = False---- | /O(n)/ Return the number of key-value mappings in this map.-size :: HashMap k v -> Int-size t = go t 0- where- go (Bin _ l r) !sz = go r (go l sz)- go (Tip _ l) !sz = sz + FL.size l- go Nil !sz = sz---- | /O(min(n,W))/ Return the value to which the specified key is--- mapped, or 'Nothing' if this map contains no mapping for the key.-lookup :: (Eq k, Hashable k) => k -> HashMap k v -> Maybe v-lookup k0 t = go h0 k0 t- where- h0 = hash k0- go !h !k (Bin sm l r)- | zero h sm = go h k l- | otherwise = go h k r- go h k (Tip h' l)- | h == h' = FL.lookup k l- | otherwise = Nothing- go _ _ Nil = Nothing-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE lookup #-}-#endif---- | /O(min(n,W))/ Return the value to which the specified key is--- mapped, or the default value if this map contains no mapping for--- the key.-lookupDefault :: (Eq k, Hashable k)- => v -- ^ Default value to return.- -> k -> HashMap k v -> v-lookupDefault def k t = case lookup k t of- Just v -> v- _ -> def-{-# INLINABLE lookupDefault #-}+ , fromListWithKey --- | /O(1)/ Construct a map with a single element.-singleton :: Hashable k => k -> v -> HashMap k v-singleton k v = Tip h $ FL.singleton k v- where h = hash k-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE singleton #-}-#endif+ -- ** HashSets+ , HS.keysSet+ ) where --- | /O(min(n,W))/ Associate the specified value with the specified--- key in this map. If this map previously contained a mapping for--- the key, the old value is replaced.-insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v-insert k0 v0 t0 = go h0 k0 v0 t0- where- h0 = hash k0- go !h !k v t@(Bin sm l r)- | nomatch h sm = join h (Tip h $ FL.singleton k v) sm t- | zero h sm = Bin sm (go h k v l) r- | otherwise = Bin sm l (go h k v r)- go h k v t@(Tip h' l)- | h == h' = Tip h $ FL.insert k v l- | otherwise = join h (Tip h $ FL.singleton k v) h' t- go h k v Nil = Tip h $ FL.singleton k v-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insert #-}-#endif+import Data.HashMap.Internal+import Prelude () --- | /O(min(n,W))/ Remove the mapping for the specified key from this--- map if present.-delete :: (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v-delete k0 = go h0 k0- where- h0 = hash k0- go !h !k t@(Bin sm l r)- | nomatch h sm = t- | zero h sm = bin sm (go h k l) r- | otherwise = bin sm l (go h k r)- go h k t@(Tip h' l)- | h == h' = case FL.delete k l of- Nothing -> Nil- Just l' -> Tip h' l'- | otherwise = t- go _ _ Nil = Nil-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE delete #-}-#endif+import qualified Data.HashSet.Internal as HS --- | /O(min(n,W))/ Associate the value with the key in this map. If--- this map previously contained a mapping for the key, the old value--- is replaced by the result of applying the given function to the new--- and old value. Example:+-- $strictness ----- > insertWith f k v map--- > where f new old = new + old-insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v- -> HashMap k v-insertWith f k0 v0 t0 = go h0 k0 v0 t0- where- h0 = hash k0- go !h !k v t@(Bin sm l r)- | nomatch h sm = join h (Tip h $ FL.singleton k v) sm t- | zero h sm = Bin sm (go h k v l) r- | otherwise = Bin sm l (go h k v r)- go h k v t@(Tip h' l)- | h == h' = Tip h $ FL.insertWith f k v l- | otherwise = join h (Tip h $ FL.singleton k v) h' t- go h k v Nil = Tip h $ FL.singleton k v-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertWith #-}-#endif---- | /O(min(n,W)/ Adjust the value tied to a given key in this map--- only if it is present. Otherwise, leave the map alone.-adjust :: (Eq k, Hashable k) => (v -> v) -> k -> HashMap k v -> HashMap k v-adjust f k0 t0 = go h0 k0 t0- where- h0 = hash k0- go !h !k t@(Bin sm l r)- | nomatch h sm = t- | zero h sm = Bin sm (go h k l) r- | otherwise = Bin sm l (go h k r)- go h k t@(Tip h' l)- | h == h' = Tip h $ FL.adjust f k l- | otherwise = t- go _ _ Nil = Nil-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE adjust #-}-#endif----------------------------------------------------------------------------- * Transformations---- | /O(n)/ Transform this map by applying a function to every value.-map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2-map f = go- where- go (Bin sm l r) = Bin sm (go l) (go r)- go (Tip h l) = Tip h (FL.map f' l)- go Nil = Nil- f' k v = (k, f v)-{-# INLINE map #-}---- | /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 => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v-unionWith f t1@(Bin sm1 l1 r1) t2@(Bin sm2 l2 r2)- | sm1 == sm2 = Bin sm1 (unionWith f l1 l2) (unionWith f r1 r2)- | shorter sm1 sm2 = union1- | shorter sm2 sm1 = union2- | otherwise = join sm1 t1 sm2 t2- where- union1 | nomatch sm2 sm1 = join sm1 t1 sm2 t2- | zero sm2 sm1 = Bin sm1 (unionWith f l1 t2) r1- | otherwise = Bin sm1 l1 (unionWith f r1 t2)-- union2 | nomatch sm1 sm2 = join sm1 t1 sm2 t2- | zero sm1 sm2 = Bin sm2 (unionWith f t1 l2) r2- | otherwise = Bin sm2 l2 (unionWith f t1 r2)-unionWith f (Tip h l) t = insertCollidingWith (FL.unionWith f) h l t-unionWith f t (Tip h l) = insertCollidingWith (flip (FL.unionWith f)) h l t -- right bias-unionWith _ Nil t = t-unionWith _ t Nil = t-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE unionWith #-}-#endif---- | /O(n)/ Difference of two maps. Return elements of the first map--- not existing in the second.-difference :: (Eq k, Hashable k) => HashMap k v -> HashMap k w -> HashMap k v-difference a b = foldlWithKey' go empty a- where- go m k v = case lookup k b of- Nothing -> insert k v m- _ -> m-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE difference #-}-#endif---- | /O(n)/ 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 a b = foldlWithKey' go empty a- where- go m k v = case lookup k b of- Just _ -> insert k v m- _ -> m-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE intersection #-}-#endif----------------------------------------------------------------------------- * Folds---- | /O(n)/ Reduce this map by applying a binary operator to all--- elements, using the given starting value (typically the--- right-identity of the operator).-foldr :: (v -> a -> a) -> a -> HashMap k v -> a-foldr f = foldrWithKey (const f)-{-# INLINE foldr #-}---- | /O(n)/ Reduce this map by applying a binary operator to all--- elements, using the given starting value (typically the--- left-identity of the operator). Each application of the operator--- is evaluated before before using the result in the next--- application. This function is strict in the starting value.-foldl' :: (a -> v -> a) -> a -> HashMap k v -> a-foldl' f = foldlWithKey' (\ z _ v -> f z v)-{-# INLINE foldl' #-}---- | /O(n)/ Reduce this map by applying a binary operator to all--- elements, using the given starting value (typically the--- left-identity of the operator). Each application of the operator--- is evaluated before before using the result in the next--- application. This function is strict in the starting value.-foldlWithKey' :: (a -> k -> v -> a) -> a -> HashMap k v -> a-foldlWithKey' f = go- where- go !z (Bin _ l r) = let z' = go z l- in z' `seq` go z' r- go z (Tip _ l) = FL.foldlWithKey' f z l- go z Nil = z-{-# INLINE foldlWithKey' #-}----------------------------------------------------------------------------- * Filter---- | /O(n)/ Filter this map by retaining only elements satisfying a--- predicate.-filterWithKey :: (k -> v -> Bool) -> HashMap k v -> HashMap k v-filterWithKey pred = go- where- go (Bin sm l r) = bin sm (go l) (go r)- go (Tip h l) = case FL.filterWithKey pred l of- Just l' -> Tip h l'- Nothing -> Nil- go Nil = Nil-{-# INLINE filterWithKey #-}---- | /O(n)/ Filter this map by retaining only elements which values--- satisfy a predicate.-filter :: (v -> Bool) -> HashMap k v -> HashMap k v-filter p = filterWithKey (\_ v -> p v)-{-# INLINE filter #-}----------------------------------------------------------------------------- Conversions---- | /O(n*min(W, n))/ Construct a map from a list of elements.-fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v-fromList = List.foldl' (\ m (k, v) -> insert k v m) empty-{-# INLINE fromList #-}---- | /O(n*min(W, n))/ Construct a map from a list of elements. Uses--- the provided function to merge duplicate entries.-fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v-fromListWith f = List.foldl' (\ m (k, v) -> insertWith f k v m) empty-{-# INLINE fromListWith #-}---- | /O(n)/ Return a list of this map's keys. The list is produced--- lazily.-keys :: HashMap k v -> [k]-keys = List.map fst . toList-{-# INLINE keys #-}---- | /O(n)/ Return a list of this map's values. The list is produced--- lazily.-elems :: HashMap k v -> [v]-elems = List.map snd . toList-{-# INLINE elems #-}+-- This module satisfies the following strictness property:+--+-- * Key arguments are evaluated to WHNF.
− Data/HashMap/Lazy/Internal.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE BangPatterns #-}----------------------------------------------------------------------------- |--- Module : Data.HashMap.Lazy.Internal--- Copyright : 2010-2011 Johan Tibell--- License : BSD-style--- Maintainer : johan.tibell@gmail.com--- Stability : provisional--- Portability : portable------ Semi-public internals.--module Data.HashMap.Lazy.Internal- ( collisions- , collisionHistogram- ) where--import Prelude hiding (lookup)--import qualified Data.FullList.Lazy as FL-import Data.HashMap.Common (HashMap(..))-import Data.HashMap.Lazy (insert, lookup)------------------------------------------------------------------------ Metadata about map behavior---- | /O(n)/ Return the number of hash collisions in this map.-collisions :: HashMap k v -> Int-collisions t = go t 0- where- go (Bin _ l r) !sz = go r (go l sz)- go (Tip _ l) !sz- | fl_sz <= 1 = sz- | otherwise = sz + fl_sz- where fl_sz = FL.size l- go Nil !sz = sz---- | /O(n)/ Return histogram of hash collisions in this map.--- Keys are number of entries in bucket, values are number of buckets--- of that size.-collisionHistogram :: HashMap k v -> HashMap Int Int-collisionHistogram t = go t Nil- where- go (Bin _ l r) h = go r (go l h)- go (Tip _ l) h = (insert sz $! maybe 1 (1+) (lookup sz h)) h- where sz = FL.size l- go Nil h = h
Data/HashMap/Strict.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE BangPatterns, CPP #-}+{-# LANGUAGE Safe #-} ------------------------------------------------------------------------ -- | -- Module : Data.HashMap.Strict--- Copyright : 2010-2011 Johan Tibell+-- Copyright : 2010-2012 Johan Tibell -- License : BSD-style -- Maintainer : johan.tibell@gmail.com -- Stability : provisional@@ -13,23 +13,19 @@ -- duplicate keys; each key can map to at most one value. A 'HashMap' -- makes no guarantees as to the order of its elements. ----- This map is strict in both the keys and the values; keys and values--- are evaluated to /weak head normal form/ before they are added to--- the map. Exception: the provided instances are the same as for the--- lazy version of this module.------ The implementation is based on /big-endian patricia trees/, keyed--- by a hash of the original key. A 'HashMap' is often faster than--- other tree-based maps, especially when key comparison is expensive,--- as in the case of strings.+-- The implementation is based on /hash array mapped tries/. A+-- 'HashMap' is often faster than other tree-based set types,+-- especially when key comparison is expensive, as in the case of+-- strings. ----- Many operations have a worst-case complexity of /O(min(n,W))/.--- This means that the operation can become linear in the number of--- elements with a maximum of /W/ -- the number of bits in an 'Int'--- (32 or 64).-+-- Many operations have a average-case complexity of \(O(\log n)\). The+-- implementation uses a large base (i.e. 16 or 32) so in practice these+-- operations are constant time. module Data.HashMap.Strict (+ -- * Strictness properties+ -- $strictness+ HashMap -- * Construction@@ -39,173 +35,89 @@ -- * Basic interface , null , size+ , member , lookup+ , (!?)+ , findWithDefault , lookupDefault+ , (!)+ , lookupKey , insert- , delete , insertWith+ , delete , adjust+ , update+ , alter+ , alterF+ , isSubmapOf+ , isSubmapOfBy -- * Combine -- ** Union , union , unionWith+ , unionWithKey+ , unions + -- ** Compose+ , compose+ -- * Transformations , map+ , mapWithKey , traverseWithKey+ , mapKeys -- * Difference and intersection , difference+ , differenceWith+ , differenceWithKey , intersection+ , intersectionWith+ , intersectionWithKey+ , disjoint -- * Folds+ , foldMapWithKey+ , foldr+ , foldl+ , foldr' , foldl'+ , foldrWithKey' , foldlWithKey'- , foldr , foldrWithKey+ , foldlWithKey -- * Filter , filter , filterWithKey+ , mapMaybe+ , mapMaybeWithKey -- * Conversions- , elems , keys+ , elems -- ** Lists , toList , fromList , fromListWith- ) where--import Data.Hashable (Hashable(hash))-import Prelude hiding (filter, foldr, lookup, map, null)--import qualified Data.FullList.Strict as FL-import Data.HashMap.Common-import Data.HashMap.Lazy hiding (fromList, fromListWith, insert, insertWith,- adjust, map, singleton, unionWith)-import qualified Data.HashMap.Lazy as L-import qualified Data.List as List+ , fromListWithKey ---------------------------------------------------------------------------- * Basic interface+ -- ** HashSets+ , HS.keysSet+ ) where --- | /O(1)/ Construct a map with a single element.-singleton :: Hashable k => k -> v -> HashMap k v-singleton k !v = L.singleton k v-{-# INLINE singleton #-}+import Data.HashMap.Internal.Strict+import Prelude () --- | /O(min(n,W))/ Associate the specified value with the specified--- key in this map. If this map previously contained a mapping for--- the key, the old value is replaced.-insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v-insert k0 !v0 t0 = go h0 k0 v0 t0- where- h0 = hash k0- go !h !k v t@(Bin sm l r)- | nomatch h sm = join h (Tip h $ FL.singleton k v) sm t- | zero h sm = Bin sm (go h k v l) r- | otherwise = Bin sm l (go h k v r)- go h k v t@(Tip h' l)- | h == h' = Tip h $ FL.insert k v l- | otherwise = join h (Tip h $ FL.singleton k v) h' t- go h k v Nil = Tip h $ FL.singleton k v-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insert #-}-#endif+import qualified Data.HashSet.Internal as HS --- | /O(min(n,W))/ Associate the value with the key in this map. If--- this map previously contained a mapping for the key, the old value--- is replaced by the result of applying the given function to the new--- and old value. Example:+-- $strictness ----- > insertWith f k v map--- > where f new old = new + old-insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v- -> HashMap k v-insertWith f k0 !v0 t0 = go h0 k0 v0 t0- where- h0 = hash k0- go !h !k v t@(Bin sm l r)- | nomatch h sm = join h (Tip h $ FL.singleton k v) sm t- | zero h sm = Bin sm (go h k v l) r- | otherwise = Bin sm l (go h k v r)- go h k v t@(Tip h' l)- | h == h' = Tip h $ FL.insertWith f k v l- | otherwise = join h (Tip h $ FL.singleton k v) h' t- go h k v Nil = Tip h $ FL.singleton k v-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertWith #-}-#endif---- | /O(min(n,W)/ Adjust the value tied to a given key in this map--- only if it is present. Otherwise, leave the map alone.-adjust :: (Eq k, Hashable k) => (v -> v) -> k -> HashMap k v -> HashMap k v-adjust f k0 t0 = go h0 k0 t0- where- h0 = hash k0- go !h !k t@(Bin sm l r)- | nomatch h sm = t- | zero h sm = Bin sm (go h k l) r- | otherwise = Bin sm l (go h k r)- go h k t@(Tip h' l)- | h == h' = Tip h $ FL.adjust f k l- | otherwise = t- go _ _ Nil = Nil-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE adjust #-}-#endif------------------------------------------------------------------------------ * Transformations---- | /O(n)/ Transform this map by applying a function to every value.-map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2-map f = go- where- go (Bin sm l r) = Bin sm (go l) (go r)- go (Tip h l) = Tip h (FL.map f' l)- go Nil = Nil- f' k v = (k, f v)-{-# INLINE map #-}---- | /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 => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v-unionWith f t1@(Bin sm1 l1 r1) t2@(Bin sm2 l2 r2)- | sm1 == sm2 = Bin sm1 (unionWith f l1 l2) (unionWith f r1 r2)- | shorter sm1 sm2 = union1- | shorter sm2 sm1 = union2- | otherwise = join sm1 t1 sm2 t2- where- union1 | nomatch sm2 sm1 = join sm1 t1 sm2 t2- | zero sm2 sm1 = Bin sm1 (unionWith f l1 t2) r1- | otherwise = Bin sm1 l1 (unionWith f r1 t2)-- union2 | nomatch sm1 sm2 = join sm1 t1 sm2 t2- | zero sm1 sm2 = Bin sm2 (unionWith f t1 l2) r2- | otherwise = Bin sm2 l2 (unionWith f t1 r2)-unionWith f (Tip h l) t = insertCollidingWith (FL.unionWith f) h l t-unionWith f t (Tip h l) = insertCollidingWith (flip (FL.unionWith f)) h l t -- right bias-unionWith _ Nil t = t-unionWith _ t Nil = t-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE unionWith #-}-#endif----------------------------------------------------------------------------- Conversions---- | /O(n*min(W, n))/ Construct a map from a list of elements.-fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v-fromList = List.foldl' (\ m (k, v) -> insert k v m) empty-{-# INLINE fromList #-}---- | /O(n*min(W, n))/ Construct a map from a list of elements. Uses--- the provided function to merge duplicate entries.-fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v-fromListWith f = List.foldl' (\ m (k, v) -> insertWith f k v m) empty-{-# INLINE fromListWith #-}+-- This module satisfies the following strictness properties:+--+-- 1. Key arguments are evaluated to WHNF;+--+-- 2. Keys and values are evaluated to WHNF before they are stored in+-- the map.
− Data/HashMap/Strict/Internal.hs
@@ -1,19 +0,0 @@-{-# LANGUAGE BangPatterns #-}----------------------------------------------------------------------------- |--- Module : Data.HashMap.Strict.Internal--- Copyright : 2010-2011 Johan Tibell--- License : BSD-style--- Maintainer : johan.tibell@gmail.com--- Stability : provisional--- Portability : portable------ Semi-public internals.--module Data.HashMap.Strict.Internal- ( collisions- , collisionHistogram- ) where--import Data.HashMap.Lazy.Internal
Data/HashSet.hs view
@@ -1,27 +1,96 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE Safe #-} --------------------------------------------------------------------------- |--- Module : Data.HashSet--- Copyright : 2011 Bryan O'Sullivan--- License : BSD-style--- Maintainer : johan.tibell@gmail.com--- Stability : provisional--- Portability : portable------ A set of /hashable/ values. A set cannot contain duplicate items.--- A 'HashSet' makes no guarantees as to the order of its elements.------ The implementation is based on /big-endian patricia trees/, indexed--- by a hash of the original value. A 'HashSet' is often faster than--- other tree-based set types, especially when value comparison is--- expensive, as in the case of strings.------ Many operations have a worst-case complexity of /O(min(n,W))/.--- This means that the operation can become linear in the number of--- elements with a maximum of /W/ -- the number of bits in an 'Int'--- (32 or 64).+{-|+Module : Data.HashSet+Copyright : 2011 Bryan O'Sullivan+License : BSD-style+Maintainer : johan.tibell@gmail.com+Stability : provisional+Portability : portable += Introduction++'HashSet' allows you to store /unique/ elements, providing efficient insertion,+lookups, and deletion. A 'HashSet' makes no guarantees as to the order of its+elements.++If you are storing sets of "Data.Int"s consider using "Data.IntSet" from the+<https://hackage.haskell.org/package/containers containers> package.+++== Examples++All the examples below assume @HashSet@ is imported qualified, and uses the following @dataStructures@ set.++>>> import qualified Data.HashSet as HashSet+>>> let dataStructures = HashSet.fromList ["Set", "Map", "Graph", "Sequence"]++=== Basic Operations++Check membership in a set:++>>> -- Check if "Map" and "Trie" are in the set of data structures.+>>> HashSet.member "Map" dataStructures+True+>>> HashSet.member "Trie" dataStructures+False++Add a new entry to the set:++>>> let moreDataStructures = HashSet.insert "Trie" dataStructures+>>> HashSet.member "Trie" moreDataStructures+> True++Remove the @\"Graph\"@ entry from the set of data structures.++>>> let fewerDataStructures = HashSet.delete "Graph" dataStructures+>>> HashSet.toList fewerDataStructures+["Map","Set","Sequence"]+++Create a new set and combine it with our original set.++>>> let unorderedDataStructures = HashSet.fromList ["HashSet", "HashMap"]+>>> HashSet.union dataStructures unorderedDataStructures+fromList ["Map","HashSet","Graph","HashMap","Set","Sequence"]++=== Using custom data with HashSet++To create a @HashSet@ of your custom type, the type must have instances for+'Data.Eq.Eq' and 'Data.Hashable.Hashable'. The @Hashable@ typeclass is defined in the+<https://hackage.haskell.org/package/hashable hashable> package, see the+documentation for information on how to make your type an instance of+@Hashable@.++We'll start by setting up our custom data type:++>>> :set -XDeriveGeneric+>>> import GHC.Generics (Generic)+>>> import Data.Hashable+>>> data Person = Person { name :: String, likesDogs :: Bool } deriving (Show, Eq, Generic)+>>> instance Hashable Person++And now we'll use it!++>>> let people = HashSet.fromList [Person "Lana" True, Person "Joe" False, Person "Simon" True]+>>> HashSet.filter likesDogs people+fromList [Person {name = "Simon", likesDogs = True},Person {name = "Lana", likesDogs = True}]+++== Performance++The implementation is based on /hash array mapped tries/. A+'HashSet' is often faster than other 'Data.Ord.Ord'-based set types,+especially when value comparisons are expensive, as in the case of+strings.++Many operations have a average-case complexity of \(O(\log n)\). The+implementation uses a large base (i.e. 16 or 32) so in practice these+operations are constant time.+-}+ module Data.HashSet ( HashSet@@ -32,13 +101,16 @@ -- * Combine , union+ , unions -- * Basic interface , null , size , member+ , lookupElement , insert , delete+ , isSubsetOf -- * Transformations , map@@ -46,6 +118,7 @@ -- * Difference and intersection , difference , intersection+ , disjoint -- * Folds , foldl'@@ -54,165 +127,16 @@ -- * Filter , filter + -- * Conversions+ -- ** Lists , toList , fromList- ) where -import Control.DeepSeq (NFData(..))-import Data.HashMap.Common (HashMap, foldrWithKey)-import Data.Hashable (Hashable)-import Data.Monoid (Monoid(..))-import Prelude hiding (filter, foldr, map, null)-import qualified Data.Foldable as Foldable-import qualified Data.HashMap.Lazy as H-import qualified Data.List as List--#if defined(__GLASGOW_HASKELL__)-import GHC.Exts (build)-#endif---- | A set of values. A set cannot contain duplicate values.-newtype HashSet a = HashSet {- asMap :: HashMap a ()- }--instance (NFData a) => NFData (HashSet a) where- rnf = rnf . asMap- {-# INLINE rnf #-}--instance (Hashable a, Eq a) => Eq (HashSet a) where- -- This performs two passes over the tree.- a == b = foldr f True b && size a == size b- where f i = (&& i `member` a)- {-# INLINE (==) #-}--instance Foldable.Foldable HashSet where- foldr = Data.HashSet.foldr- {-# INLINE foldr #-}--instance (Hashable a, Eq a) => Monoid (HashSet a) where- mempty = empty- {-# INLINE mempty #-}- mappend = union- {-# INLINE mappend #-}--instance (Show a) => Show (HashSet a) where- showsPrec d m = showParen (d > 10) $- showString "fromList " . shows (toList m)---- | /O(1)/ Construct an empty set.-empty :: HashSet a-empty = HashSet H.empty---- | /O(1)/ Construct a set with a single element.-singleton :: Hashable a => a -> HashSet a-singleton a = HashSet (H.singleton a ())-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE singleton #-}-#endif---- | /O(n)/ Construct a set containing all elements from both sets.------ To obtain good performance, the smaller set must be presented as--- the first argument.-union :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a-union s1 s2 = HashSet $ H.union (asMap s1) (asMap s2)-{-# INLINE union #-}---- | /O(1)/ Return 'True' if this set is empty, 'False' otherwise.-null :: HashSet a -> Bool-null = H.null . asMap-{-# INLINE null #-}---- | /O(n)/ Return the number of elements in this set.-size :: HashSet a -> Int-size = H.size . asMap-{-# INLINE size #-}---- | /O(min(n,W))/ Return 'True' if the given value is present in this--- set, 'False' otherwise.-member :: (Eq a, Hashable a) => a -> HashSet a -> Bool-member a s = case H.lookup a (asMap s) of- Just _ -> True- _ -> False-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE member #-}-#endif---- | /O(min(n,W))/ Add the specified value to this set.-insert :: (Eq a, Hashable a) => a -> HashSet a -> HashSet a-insert a = HashSet . H.insert a () . asMap-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insert #-}-#endif---- | /O(min(n,W))/ Remove the specified value from this set if--- present.-delete :: (Eq a, Hashable a) => a -> HashSet a -> HashSet a-delete a = HashSet . H.delete a . asMap-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE delete #-}-#endif---- | /O(n)/ Transform this set by applying a function to every value.--- The resulting set may be smaller than the source.-map :: (Hashable b, Eq b) => (a -> b) -> HashSet a -> HashSet b-map f = fromList . List.map f . toList-{-# INLINE map #-}---- | /O(n)/ Difference of two sets. Return elements of the first set--- not existing in the second.-difference :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a-difference (HashSet a) (HashSet b) = HashSet (H.difference a b)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE difference #-}-#endif---- | /O(n)/ Intersection of two sets. Return elements present in both--- the first set and the second.-intersection :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a-intersection (HashSet a) (HashSet b) = HashSet (H.intersection a b)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE intersection #-}-#endif---- | /O(n)/ Reduce this set by applying a binary operator to all--- elements, using the given starting value (typically the--- left-identity of the operator). Each application of the operator--- is evaluated before before using the result in the next--- application. This function is strict in the starting value.-foldl' :: (a -> b -> a) -> a -> HashSet b -> a-foldl' f z0 = H.foldlWithKey' g z0 . asMap- where g z k _ = f z k-{-# INLINE foldl' #-}---- | /O(n)/ Reduce this set by applying a binary operator to all--- elements, using the given starting value (typically the--- right-identity of the operator).-foldr :: (b -> a -> a) -> a -> HashSet b -> a-foldr f z0 = foldrWithKey g z0 . asMap- where g k _ z = f k z-{-# INLINE foldr #-}---- | /O(n)/ Filter this set by retaining only elements satisfying a--- predicate.-filter :: (a -> Bool) -> HashSet a -> HashSet a-filter p = HashSet . H.filterWithKey q . asMap- where q k _ = p k-{-# INLINE filter #-}---- | /O(n)/ Return a list of this set's elements. The list is--- produced lazily.-toList :: HashSet a -> [a]-#if defined(__GLASGOW_HASKELL__)-toList t = build (\ c z -> foldrWithKey ((const .) c) z (asMap t))-#else-toList = foldrWithKey (\ k _ xs -> k : xs) [] . asMap-#endif-{-# INLINE toList #-}+ -- * HashMaps+ , toMap+ , fromMap+ ) where --- | /O(n*min(W, n))/ Construct a set from a list of elements.-fromList :: (Eq a, Hashable a) => [a] -> HashSet a-fromList = HashSet . List.foldl' (\ m k -> H.insert k () m) H.empty-{-# INLINE fromList #-}+import Data.HashSet.Internal+import Prelude ()
+ Data/HashSet/Internal.hs view
@@ -0,0 +1,482 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK not-home #-}++------------------------------------------------------------------------+-- |+-- Module : Data.HashSet.Internal+-- Copyright : 2011 Bryan O'Sullivan+-- License : BSD-style+-- Maintainer : johan.tibell@gmail.com+-- Portability : portable+--+-- = 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+--+-- A set of /hashable/ values. A set cannot contain duplicate items.+-- A 'HashSet' makes no guarantees as to the order of its elements.+--+-- The implementation is based on /hash array mapped tries/. A+-- 'HashSet' is often faster than other tree-based set types,+-- especially when value comparison is expensive, as in the case of+-- strings.+--+-- Many operations have a average-case complexity of \(O(\log n)\). The+-- implementation uses a large base (i.e. 16 or 32) so in practice these+-- operations are constant time.++module Data.HashSet.Internal+ (+ HashSet(..)++ -- * Construction+ , empty+ , singleton++ -- * Basic interface+ , null+ , size+ , member+ , lookupElement+ , insert+ , delete+ , isSubsetOf++ -- * Transformations+ , map++ -- * Combine+ , union+ , unions++ -- * Difference and intersection+ , difference+ , intersection+ , disjoint++ -- * Folds+ , foldr+ , foldr'+ , foldl+ , foldl'++ -- * Filter+ , filter++ -- * Conversions++ -- ** Lists+ , toList+ , fromList++ -- * HashMaps+ , toMap+ , fromMap++ -- Exported from Data.HashMap.{Strict, Lazy}+ , keysSet+ ) where++import Control.DeepSeq (NFData (..), NFData1 (..), liftRnf2)+import Data.Data (Constr, Data (..), DataType)+import Data.Functor.Classes+import Data.Hashable (Hashable (hashWithSalt))+import Data.Hashable.Lifted (Hashable1 (..), Hashable2 (..))+import Data.HashMap.Internal (HashMap, equalKeys, equalKeys1, foldMapWithKey,+ foldlWithKey, foldrWithKey)+import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid)+import Prelude hiding (Foldable(..), filter, map)+import Text.Read++import qualified Data.Data as Data+import qualified Data.Foldable as Foldable+import qualified Data.HashMap.Internal as H+import qualified Data.List as List+import qualified GHC.Exts as Exts+import qualified Language.Haskell.TH.Syntax as TH++-- | A set of values. A set cannot contain duplicate values.+newtype HashSet a = HashSet {+ asMap :: HashMap a ()+ }++type role HashSet nominal++-- | @since 0.2.17.0+deriving instance TH.Lift a => TH.Lift (HashSet a)++instance (NFData a) => NFData (HashSet a) where+ rnf = rnf . asMap+ {-# INLINE rnf #-}++-- | @since 0.2.14.0+instance NFData1 HashSet where+ liftRnf rnf1 = liftRnf2 rnf1 rnf . asMap++-- | Note that, in the presence of hash collisions, equal @HashSet@s may+-- behave differently, i.e. extensionality may be violated:+--+-- >>> data D = A | B deriving (Eq, Show)+-- >>> instance Hashable D where hashWithSalt salt _d = salt+--+-- >>> x = fromList [A, B]+-- >>> y = fromList [B, A]+--+-- >>> x == y+-- True+-- >>> toList x+-- [A,B]+-- >>> toList y+-- [B,A]+--+-- 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+ {-# INLINE (==) #-}++instance Eq1 HashSet where+ liftEq eq (HashSet a) (HashSet b) = equalKeys1 eq a b++instance (Ord a) => Ord (HashSet a) where+ compare (HashSet a) (HashSet b) = compare a b+ {-# INLINE compare #-}++instance Ord1 HashSet where+ liftCompare c (HashSet a) (HashSet b) = liftCompare2 c compare a b++instance Foldable.Foldable HashSet where+ foldMap f = foldMapWithKey (\a _ -> f a) . asMap+ foldr = foldr+ {-# INLINE foldr #-}+ foldl = foldl+ {-# INLINE foldl #-}+ foldl' = foldl'+ {-# INLINE foldl' #-}+ foldr' = foldr'+ {-# INLINE foldr' #-}+ toList = toList+ {-# INLINE toList #-}+ null = null+ {-# INLINE null #-}+ length = size+ {-# INLINE length #-}++-- | '<>' = 'union'+--+-- \(O(n+m)\)+--+-- To obtain good performance, the smaller set must be presented as+-- the first argument.+--+-- ==== __Examples__+--+-- >>> fromList [1,2] <> fromList [2,3]+-- fromList [1,2,3]+instance Hashable a => Semigroup (HashSet a) where+ (<>) = union+ {-# INLINE (<>) #-}+ stimes = stimesIdempotentMonoid+ {-# INLINE stimes #-}++-- | 'mempty' = 'empty'+--+-- 'mappend' = 'union'+--+-- \(O(n+m)\)+--+-- To obtain good performance, the smaller set must be presented as+-- the first argument.+--+-- ==== __Examples__+--+-- >>> mappend (fromList [1,2]) (fromList [2,3])+-- fromList [1,2,3]+instance Hashable a => Monoid (HashSet a) where+ mempty = empty+ {-# INLINE mempty #-}+ mappend = (<>)+ {-# INLINE mappend #-}++instance (Hashable a, Read a) => Read (HashSet a) where+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ fromList <$> readPrec++ readListPrec = readListPrecDefault++instance Show1 HashSet where+ liftShowsPrec sp sl d m =+ showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)++instance (Show a) => Show (HashSet a) where+ showsPrec d m = showParen (d > 10) $+ showString "fromList " . shows (toList m)++instance (Data a, Hashable a) => Data (HashSet a) where+ gfoldl f z m = z fromList `f` toList m+ toConstr _ = fromListConstr+ gunfold k z c = case Data.constrIndex c of+ 1 -> k (z fromList)+ _ -> error "gunfold"+ dataTypeOf _ = hashSetDataType+ dataCast1 f = Data.gcast1 f++instance Hashable1 HashSet where+ liftHashWithSalt h s = liftHashWithSalt2 h hashWithSalt s . asMap++instance (Hashable a) => Hashable (HashSet a) where+ hashWithSalt salt = hashWithSalt salt . asMap++fromListConstr :: Constr+fromListConstr = Data.mkConstr hashSetDataType "fromList" [] Data.Prefix++hashSetDataType :: DataType+hashSetDataType = Data.mkDataType "Data.HashSet.Internal.HashSet" [fromListConstr]++-- | \(O(1)\) Construct an empty set.+--+-- >>> HashSet.empty+-- fromList []+empty :: HashSet a+empty = HashSet H.empty++-- | \(O(1)\) Construct a set with a single element.+--+-- >>> HashSet.singleton 1+-- fromList [1]+singleton :: Hashable a => a -> HashSet a+singleton a = HashSet (H.singleton a ())+{-# INLINABLE singleton #-}++-- | \(O(1)\) Convert to set to the equivalent 'HashMap' with @()@ values.+--+-- >>> HashSet.toMap (HashSet.singleton 1)+-- fromList [(1,())]+toMap :: HashSet a -> HashMap a ()+toMap = asMap++-- | \(O(1)\) Convert from the equivalent 'HashMap' with @()@ values.+--+-- >>> HashSet.fromMap (HashMap.singleton 1 ())+-- fromList [1]+fromMap :: HashMap a () -> HashSet a+fromMap = HashSet++-- | \(O(n)\) Produce a 'HashSet' of all the keys in the given 'HashMap'.+--+-- >>> HashSet.keysSet (HashMap.fromList [(1, "a"), (2, "b")]+-- fromList [1,2]+--+-- @since 0.2.10.0+keysSet :: HashMap k a -> HashSet k+keysSet m = fromMap (() <$ m)++-- | \(O(n \log m)\) Inclusion of sets.+--+-- ==== __Examples__+--+-- >>> fromList [1,3] `isSubsetOf` fromList [1,2,3]+-- True+--+-- >>> fromList [1,2] `isSubsetOf` fromList [1,3]+-- False+--+-- @since 0.2.12+isSubsetOf :: Hashable a => HashSet a -> HashSet a -> Bool+isSubsetOf s1 s2 = H.isSubmapOfBy (\_ _ -> True) (asMap s1) (asMap s2)++-- | \(O(n+m)\) Construct a set containing all elements from both sets.+--+-- To obtain good performance, the smaller set must be presented as+-- the first argument.+--+-- >>> union (fromList [1,2]) (fromList [2,3])+-- fromList [1,2,3]+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 => [HashSet a] -> HashSet a+unions = List.foldl' union empty+{-# INLINE unions #-}++-- | \(O(1)\) Return 'True' if this set is empty, 'False' otherwise.+--+-- >>> HashSet.null HashSet.empty+-- True+-- >>> HashSet.null (HashSet.singleton 1)+-- False+null :: HashSet a -> Bool+null = H.null . asMap+{-# INLINE null #-}++-- | \(O(n)\) Return the number of elements in this set.+--+-- >>> HashSet.size HashSet.empty+-- 0+-- >>> HashSet.size (HashSet.fromList [1,2,3])+-- 3+size :: HashSet a -> Int+size = H.size . asMap+{-# INLINE size #-}++-- | \(O(\log n)\) Return 'True' if the given value is present in this+-- set, 'False' otherwise.+--+-- >>> HashSet.member 1 (Hashset.fromList [1,2,3])+-- True+-- >>> HashSet.member 1 (Hashset.fromList [4,5,6])+-- False+member :: Hashable a => a -> HashSet a -> Bool+member a s = case H.lookup a (asMap s) of+ Just _ -> True+ _ -> False+{-# INLINABLE member #-}++-- | \(O(\log n)\) For a given value, return the equal element in the set if+-- present, otherwise return 'Nothing'.+--+-- This is useful for /interning/, i.e. to reduce memory usage.+--+-- @since 0.2.21+lookupElement :: Hashable a => a -> HashSet a -> Maybe a+lookupElement a = H.lookupKey a . asMap+{-# INLINE lookupElement #-}++-- | \(O(\log n)\) Add the specified value to this set.+--+-- >>> HashSet.insert 1 HashSet.empty+-- fromList [1]+insert :: Hashable a => a -> HashSet a -> HashSet a+insert a = HashSet . H.insert a () . asMap+{-# INLINABLE insert #-}++-- | \(O(\log n)\) Remove the specified value from this set if present.+--+-- >>> HashSet.delete 1 (HashSet.fromList [1,2,3])+-- fromList [2,3]+-- >>> HashSet.delete 1 (HashSet.fromList [4,5,6])+-- fromList [4,5,6]+delete :: Hashable a => a -> HashSet a -> HashSet a+delete a = HashSet . H.delete a . asMap+{-# INLINABLE delete #-}++-- | \(O(n \log n)\) Transform this set by applying a function to every value.+-- The resulting set may be smaller than the source.+--+-- >>> HashSet.map show (HashSet.fromList [1,2,3])+-- HashSet.fromList ["1","2","3"]+map :: Hashable b => (a -> b) -> HashSet a -> HashSet b+map f = fromList . List.map f . toList+{-# INLINE map #-}++-- | \(O(n \log m)\) Difference of two sets. Return elements of the first set+-- not existing in the second.+--+-- >>> HashSet.difference (HashSet.fromList [1,2,3]) (HashSet.fromList [2,3,4])+-- fromList [1]+difference :: Hashable a => HashSet a -> HashSet a -> HashSet a+difference (HashSet a) (HashSet b) = HashSet (H.difference a b)+{-# INLINABLE difference #-}++-- | \(O(n \log m)\) Intersection of two sets. Return elements present in both+-- the first set and the second.+--+-- >>> HashSet.intersection (HashSet.fromList [1,2,3]) (HashSet.fromList [2,3,4])+-- fromList [2,3]+intersection :: Eq a => HashSet a -> HashSet a -> HashSet a+intersection (HashSet a) (HashSet b) = HashSet (H.intersection a b)+{-# INLINABLE intersection #-}++-- | \(O(n \log m)\) Check whether two sets are disjoint (i.e., their+-- intersection is empty).+--+-- @+-- xs ``disjoint`` ys = null (xs ``intersection`` ys)+-- @+--+-- @since 0.2.21+disjoint :: Eq k => HashSet k -> HashSet k -> Bool+disjoint (HashSet a) (HashSet b) = H.disjoint a b+{-# INLINE disjoint #-}++-- | \(O(n)\) Reduce this set by applying a binary operator to all+-- elements, using the given starting value (typically the+-- left-identity of the operator). Each application of the operator+-- is evaluated before before using the result in the next+-- application. This function is strict in the starting value.+foldl' :: (a -> b -> a) -> a -> HashSet b -> a+foldl' f z0 = H.foldlWithKey' g z0 . asMap+ where g z k _ = f z k+{-# INLINE foldl' #-}++-- | \(O(n)\) Reduce this set by applying a binary operator to all+-- elements, using the given starting value (typically the+-- right-identity of the operator). Each application of the operator+-- is evaluated before before using the result in the next+-- application. This function is strict in the starting value.+foldr' :: (b -> a -> a) -> a -> HashSet b -> a+foldr' f z0 = H.foldrWithKey' g z0 . asMap+ where g k _ z = f k z+{-# INLINE foldr' #-}++-- | \(O(n)\) Reduce this set by applying a binary operator to all+-- elements, using the given starting value (typically the+-- right-identity of the operator).+foldr :: (b -> a -> a) -> a -> HashSet b -> a+foldr f z0 = foldrWithKey g z0 . asMap+ where g k _ z = f k z+{-# INLINE foldr #-}++-- | \(O(n)\) Reduce this set by applying a binary operator to all+-- elements, using the given starting value (typically the+-- left-identity of the operator).+foldl :: (a -> b -> a) -> a -> HashSet b -> a+foldl f z0 = foldlWithKey g z0 . asMap+ where g z k _ = f z k+{-# INLINE foldl #-}++-- | \(O(n)\) Filter this set by retaining only elements satisfying a+-- predicate.+filter :: (a -> Bool) -> HashSet a -> HashSet a+filter p = HashSet . H.filterWithKey q . asMap+ where q k _ = p k+{-# INLINE filter #-}++-- | \(O(n)\) Return a list of this set's elements. The list is+-- produced lazily. The order of its elements is unspecified, and it may+-- change from version to version of either this package or of @hashable@.+toList :: HashSet a -> [a]+toList t = Exts.build (\ c z -> foldrWithKey (const . c) z (asMap t))+{-# INLINE toList #-}++-- | \(O(n \log n)\) Construct a set from a list of elements.+fromList :: Hashable a => [a] -> HashSet a+fromList = HashSet . List.foldl' (\ m k -> H.unsafeInsert k () m) H.empty+{-# INLINE fromList #-}++#if defined(__GLASGOW_HASKELL__)+instance Hashable a => Exts.IsList (HashSet a) where+ type Item (HashSet a) = a+ fromList = fromList+ toList = toList+#endif
benchmarks/Benchmarks.hs view
@@ -1,27 +1,30 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RecordWildCards #-} module Main where -import Control.DeepSeq-import Control.Exception (evaluate)-import Control.Monad.Trans (liftIO)-import Criterion.Config-import Criterion.Main-import Data.Bits ((.&.))-import Data.Hashable (Hashable)-import qualified Data.ByteString as BS-import qualified Data.HashMap.Strict as HM-import qualified Data.IntMap as IM-import qualified Data.Map as M-import Data.List (foldl')-import Data.Maybe (fromMaybe)-import Prelude hiding (lookup)--import qualified Util.ByteString as UBS-import qualified Util.Int as UI-import qualified Util.String as US+import Control.DeepSeq (NFData (..))+import Data.Bits ((.&.))+import Data.Foldable (Foldable (..))+import Data.Functor.Identity (Identity (..))+import Data.Hashable (Hashable, hash)+import Data.Maybe (fromMaybe)+import GHC.Generics (Generic)+import Prelude hiding (Foldable (..), lookup)+import Test.Tasty.Bench (bench, bgroup, defaultMain, env, nf, whnf) -instance NFData BS.ByteString+import qualified Data.ByteString as BS+import qualified "hashmap" Data.HashMap as IHM+import qualified Data.HashMap.Strict as HM+import qualified Data.IntMap as IM+import qualified Data.Map as M+import qualified Util.ByteString as UBS+import qualified Util.Int as UI+import qualified Util.String as US data B where B :: NFData a => a -> B@@ -29,18 +32,102 @@ instance NFData B where rnf (B b) = rnf b +-- TODO: This a stopgap measure to keep the benchmark work with+-- Criterion 1.0.+data Env = Env {+ n :: !Int,++ elems :: ![(String, Int)],+ keys :: ![String],+ elemsBS :: ![(BS.ByteString, Int)],+ keysBS :: ![BS.ByteString],+ elemsI :: ![(Int, Int)],+ keysI :: ![Int],+ elemsI2 :: ![(Int, Int)], -- for union++ keys' :: ![String],+ keysBS' :: ![BS.ByteString],+ keysI' :: ![Int],++ keysDup :: ![String],+ keysDupBS :: ![BS.ByteString],+ keysDupI :: ![Int],+ elemsDup :: ![(String, Int)],+ elemsDupBS :: ![(BS.ByteString, Int)],+ elemsDupI :: ![(Int, Int)],++ hm :: !(HM.HashMap String Int),+ hmSubset :: !(HM.HashMap String Int),+ hmbs :: !(HM.HashMap BS.ByteString Int),+ hmbsSubset :: !(HM.HashMap BS.ByteString Int),+ hmi :: !(HM.HashMap Int Int),+ hmiSubset :: !(HM.HashMap Int Int),+ hmi2 :: !(HM.HashMap Int Int),+ m :: !(M.Map String Int),+ mSubset :: !(M.Map String Int),+ mbs :: !(M.Map BS.ByteString Int),+ mbsSubset :: !(M.Map BS.ByteString Int),+ im :: !(IM.IntMap Int),+ imSubset :: !(IM.IntMap Int),+ ihm :: !(IHM.Map String Int),+ ihmSubset :: !(IHM.Map String Int),+ ihmbs :: !(IHM.Map BS.ByteString Int),+ ihmbsSubset :: !(IHM.Map BS.ByteString Int)+ } deriving (Generic, NFData)++setupEnv :: IO Env+setupEnv = do+ let n = 2^(12 :: Int)++ elems = zip keys [1..n]+ keys = US.rnd 8 n+ elemsBS = zip keysBS [1..n]+ keysBS = UBS.rnd 8 n+ elemsI = zip keysI [1..n]+ keysI = UI.rnd (n+n) n+ elemsI2 = zip [n `div` 2..n + (n `div` 2)] [1..n] -- for union++ keys' = US.rnd' 8 n+ keysBS' = UBS.rnd' 8 n+ keysI' = UI.rnd' (n+n) n++ keysDup = US.rnd 2 n+ keysDupBS = UBS.rnd 2 n+ keysDupI = UI.rnd (n`div`4) n+ elemsDup = zip keysDup [1..n]+ elemsDupBS = zip keysDupBS [1..n]+ elemsDupI = zip keysDupI [1..n]++ hm = HM.fromList elems+ hmSubset = HM.fromList (takeSubset n elems)+ hmbs = HM.fromList elemsBS+ hmbsSubset = HM.fromList (takeSubset n elemsBS)+ hmi = HM.fromList elemsI+ hmiSubset = HM.fromList (takeSubset n elemsI)+ hmi2 = HM.fromList elemsI2+ m = M.fromList elems+ mSubset = M.fromList (takeSubset n elems)+ mbs = M.fromList elemsBS+ mbsSubset = M.fromList (takeSubset n elemsBS)+ im = IM.fromList elemsI+ imSubset = IM.fromList (takeSubset n elemsI)+ ihm = IHM.fromList elems+ ihmSubset = IHM.fromList (takeSubset n elems)+ ihmbs = IHM.fromList elemsBS+ ihmbsSubset = IHM.fromList (takeSubset n elemsBS)+ return Env{..}+ where+ takeSubset n elements =+ -- use 50% of the elements for a subset check.+ let subsetSize = round (fromIntegral n * 0.5 :: Double) :: Int+ in take subsetSize elements+ main :: IO () main = do- let hm = HM.fromList elems :: HM.HashMap String Int- hmbs = HM.fromList elemsBS :: HM.HashMap BS.ByteString Int- hmi = HM.fromList elemsI :: HM.HashMap Int Int- hmi2 = HM.fromList elemsI2 :: HM.HashMap Int Int- m = M.fromList elems :: M.Map String Int- mbs = M.fromList elemsBS :: M.Map BS.ByteString Int- im = IM.fromList elemsI :: IM.IntMap Int- defaultMainWith defaultConfig- (liftIO . evaluate $ rnf [B m, B mbs, B hm, B hmbs, B hmi, B im])+ defaultMain [+#ifdef BENCH_containers_Map+ env setupEnv $ \ ~(Env{..}) -> -- * Comparison to other data structures -- ** Map bgroup "Map"@@ -76,10 +163,60 @@ [ bench "String" $ whnf M.fromList elems , bench "ByteString" $ whnf M.fromList elemsBS ]- ]+ , bgroup "isSubmapOf"+ [ bench "String" $ whnf (M.isSubmapOf mSubset) m+ , bench "ByteString" $ whnf (M.isSubmapOf mbsSubset) mbs+ ]+ ],+#endif +#ifdef BENCH_hashmap_Map+ -- ** Map from the hashmap package+ env setupEnv $ \ ~(Env{..}) ->+ bgroup "hashmap/Map"+ [ bgroup "lookup"+ [ bench "String" $ whnf (lookupIHM keys) ihm+ , bench "ByteString" $ whnf (lookupIHM keysBS) ihmbs+ ]+ , bgroup "lookup-miss"+ [ bench "String" $ whnf (lookupIHM keys') ihm+ , bench "ByteString" $ whnf (lookupIHM keysBS') ihmbs+ ]+ , bgroup "insert"+ [ bench "String" $ whnf (insertIHM elems) IHM.empty+ , bench "ByteStringString" $ whnf (insertIHM elemsBS) IHM.empty+ ]+ , bgroup "insert-dup"+ [ bench "String" $ whnf (insertIHM elems) ihm+ , bench "ByteStringString" $ whnf (insertIHM elemsBS) ihmbs+ ]+ , bgroup "delete"+ [ bench "String" $ whnf (deleteIHM keys) ihm+ , bench "ByteString" $ whnf (deleteIHM keysBS) ihmbs+ ]+ , bgroup "delete-miss"+ [ bench "String" $ whnf (deleteIHM keys') ihm+ , bench "ByteString" $ whnf (deleteIHM keysBS') ihmbs+ ]+ , bgroup "size"+ [ bench "String" $ whnf IHM.size ihm+ , bench "ByteString" $ whnf IHM.size ihmbs+ ]+ , bgroup "fromList"+ [ bench "String" $ whnf IHM.fromList elems+ , bench "ByteString" $ whnf IHM.fromList elemsBS+ ]+ , bgroup "isSubmapOf"+ [ bench "String" $ whnf (IHM.isSubmapOf ihmSubset) ihm+ , bench "ByteString" $ whnf (IHM.isSubmapOf ihmbsSubset) ihmbs+ ]+ ],+#endif++#ifdef BENCH_containers_IntMap -- ** IntMap- , bgroup "IntMap"+ env setupEnv $ \ ~(Env{..}) ->+ bgroup "IntMap" [ bench "lookup" $ whnf (lookupIM keysI) im , bench "lookup-miss" $ whnf (lookupIM keysI') im , bench "insert" $ whnf (insertIM elemsI) IM.empty@@ -88,99 +225,171 @@ , bench "delete-miss" $ whnf (deleteIM keysI') im , bench "size" $ whnf IM.size im , bench "fromList" $ whnf IM.fromList elemsI- ]+ , bench "isSubmapOf" $ whnf (IM.isSubmapOf imSubset) im+ ],+#endif - -- * Basic interface- , bgroup "lookup"- [ bench "String" $ whnf (lookup keys) hm- , bench "ByteString" $ whnf (lookup keysBS) hmbs- , bench "Int" $ whnf (lookup keysI) hmi- ]- , bgroup "lookup-miss"- [ bench "String" $ whnf (lookup keys') hm- , bench "ByteString" $ whnf (lookup keysBS') hmbs- , bench "Int" $ whnf (lookup keysI') hmi- ]- , bgroup "insert"- [ bench "String" $ whnf (insert elems) HM.empty- , bench "ByteString" $ whnf (insert elemsBS) HM.empty- , bench "Int" $ whnf (insert elemsI) HM.empty- ]- , bgroup "insert-dup"- [ bench "String" $ whnf (insert elems) hm- , bench "ByteString" $ whnf (insert elemsBS) hmbs- , bench "Int" $ whnf (insert elemsI) hmi- ]- , bgroup "delete"- [ bench "String" $ whnf (delete keys) hm- , bench "ByteString" $ whnf (delete keysBS) hmbs- , bench "Int" $ whnf (delete keysI) hmi- ]- , bgroup "delete-miss"- [ bench "String" $ whnf (delete keys') hm- , bench "ByteString" $ whnf (delete keysBS') hmbs- , bench "Int" $ whnf (delete keysI') hmi- ]+ env setupEnv $ \ ~(Env{..}) ->+ bgroup "HashMap"+ [ -- * Basic interface+ bgroup "lookup"+ [ bench "String" $ whnf (lookup keys) hm+ , bench "ByteString" $ whnf (lookup keysBS) hmbs+ , bench "Int" $ whnf (lookup keysI) hmi+ ]+ , bgroup "lookup-miss"+ [ bench "String" $ whnf (lookup keys') hm+ , bench "ByteString" $ whnf (lookup keysBS') hmbs+ , bench "Int" $ whnf (lookup keysI') hmi+ ]+ , bgroup "insert"+ [ bench "String" $ whnf (insert elems) HM.empty+ , bench "ByteString" $ whnf (insert elemsBS) HM.empty+ , bench "Int" $ whnf (insert elemsI) HM.empty+ ]+ , bgroup "insert-dup"+ [ bench "String" $ whnf (insert elems) hm+ , bench "ByteString" $ whnf (insert elemsBS) hmbs+ , bench "Int" $ whnf (insert elemsI) hmi+ ]+ , bgroup "delete"+ [ bench "String" $ whnf (delete keys) hm+ , bench "ByteString" $ whnf (delete keysBS) hmbs+ , bench "Int" $ whnf (delete keysI) hmi+ ]+ , bgroup "delete-miss"+ [ bench "String" $ whnf (delete keys') hm+ , bench "ByteString" $ whnf (delete keysBS') hmbs+ , bench "Int" $ whnf (delete keysI') hmi+ ]+ , bgroup "alterInsert"+ [ bench "String" $ whnf (alterInsert elems) HM.empty+ , bench "ByteString" $ whnf (alterInsert elemsBS) HM.empty+ , bench "Int" $ whnf (alterInsert elemsI) HM.empty+ ]+ , bgroup "alterFInsert"+ [ bench "String" $ whnf (alterFInsert elems) HM.empty+ , bench "ByteString" $ whnf (alterFInsert elemsBS) HM.empty+ , bench "Int" $ whnf (alterFInsert elemsI) HM.empty+ ]+ , bgroup "alterInsert-dup"+ [ bench "String" $ whnf (alterInsert elems) hm+ , bench "ByteString" $ whnf (alterInsert elemsBS) hmbs+ , bench "Int" $ whnf (alterInsert elemsI) hmi+ ]+ , bgroup "alterFInsert-dup"+ [ bench "String" $ whnf (alterFInsert elems) hm+ , bench "ByteString" $ whnf (alterFInsert elemsBS) hmbs+ , bench "Int" $ whnf (alterFInsert elemsI) hmi+ ]+ , bgroup "alterDelete"+ [ bench "String" $ whnf (alterDelete keys) hm+ , bench "ByteString" $ whnf (alterDelete keysBS) hmbs+ , bench "Int" $ whnf (alterDelete keysI) hmi+ ]+ , bgroup "alterFDelete"+ [ bench "String" $ whnf (alterFDelete keys) hm+ , bench "ByteString" $ whnf (alterFDelete keysBS) hmbs+ , bench "Int" $ whnf (alterFDelete keysI) hmi+ ]+ , bgroup "alterDelete-miss"+ [ bench "String" $ whnf (alterDelete keys') hm+ , bench "ByteString" $ whnf (alterDelete keysBS') hmbs+ , bench "Int" $ whnf (alterDelete keysI') hmi+ ]+ , bgroup "alterFDelete-miss"+ [ bench "String" $ whnf (alterFDelete keys') hm+ , bench "ByteString" $ whnf (alterFDelete keysBS') hmbs+ , bench "Int" $ whnf (alterFDelete keysI') hmi+ ]+ , bgroup "isSubmapOf"+ [ bench "String" $ whnf (HM.isSubmapOf hmSubset) hm+ , bench "ByteString" $ whnf (HM.isSubmapOf hmbsSubset) hmbs+ , bench "Int" $ whnf (HM.isSubmapOf hmiSubset) hmi+ ]+ , bgroup "isSubmapOfNaive"+ [ bench "String" $ whnf (isSubmapOfNaive hmSubset) hm+ , bench "ByteString" $ whnf (isSubmapOfNaive hmbsSubset) hmbs+ , bench "Int" $ whnf (isSubmapOfNaive hmiSubset) hmi+ ] - -- Combine- , bench "union" $ whnf (HM.union hmi) hmi2+ -- Combine+ , bgroup "union" + [ bench "Int" $ whnf (HM.union hmi) hmi2+ , bench "ByteString" $ whnf (HM.union hmbs) hmbsSubset+ ]+ + , bgroup "intersection"+ [ bench "Int" $ whnf (HM.intersection hmi) hmi2+ , bench "ByteString" $ whnf (HM.intersection hmbs) hmbsSubset+ ] - -- Transformations- , bench "map" $ whnf (HM.map (\ v -> v + 1)) hmi+ -- Transformations+ , bench "map" $ whnf (HM.map (\ v -> v + 1)) hmi - -- * Difference and intersection- , bench "difference" $ whnf (HM.difference hmi) hmi2- , bench "intersection" $ whnf (HM.intersection hmi) hmi2+ -- * Difference and intersection+ , bench "difference" $ whnf (HM.difference hmi) hmi2 - -- Folds- , bench "foldl'" $ whnf (HM.foldl' (+) 0) hmi- , bench "foldr" $ whnf (HM.foldr (:) []) hmi+ -- Folds+ , bench "foldl'" $ whnf (HM.foldl' (+) 0) hmi+ , bench "foldr" $ nf (HM.foldr (:) []) hmi - -- Filter- , bench "filter" $ whnf (HM.filter (\ v -> v .&. 1 == 0)) hmi- , bench "filterWithKey" $ whnf (HM.filterWithKey (\ k _ -> k .&. 1 == 0)) hmi+ -- Filter+ , bench "filter" $ whnf (HM.filter (\ v -> v .&. 1 == 0)) hmi+ , bench "filterWithKey" $ whnf (HM.filterWithKey (\ k _ -> k .&. 1 == 0)) hmi - -- Size- , bgroup "size"- [ bench "String" $ whnf HM.size hm- , bench "ByteString" $ whnf HM.size hmbs- , bench "Int" $ whnf HM.size hmi- ]+ -- Size+ , bgroup "size"+ [ bench "String" $ whnf HM.size hm+ , bench "ByteString" $ whnf HM.size hmbs+ , bench "Int" $ whnf HM.size hmi+ ] - -- fromList- , bgroup "fromList"- [ bench "String" $ whnf HM.fromList elems- , bench "ByteString" $ whnf HM.fromList elemsBS- , bench "Int" $ whnf HM.fromList elemsI+ -- fromList+ , bgroup "fromList"+ [ bgroup "long"+ [ bench "String" $ whnf HM.fromList elems+ , bench "ByteString" $ whnf HM.fromList elemsBS+ , bench "Int" $ whnf HM.fromList elemsI+ ]+ , bgroup "short"+ [ bench "String" $ whnf HM.fromList elemsDup+ , bench "ByteString" $ whnf HM.fromList elemsDupBS+ , bench "Int" $ whnf HM.fromList elemsDupI+ ]+ ]+ -- fromListWith+ , bgroup "fromListWith"+ [ bgroup "long"+ [ bench "String" $ whnf (HM.fromListWith (+)) elems+ , bench "ByteString" $ whnf (HM.fromListWith (+)) elemsBS+ , bench "Int" $ whnf (HM.fromListWith (+)) elemsI+ ]+ , bgroup "short"+ [ bench "String" $ whnf (HM.fromListWith (+)) elemsDup+ , bench "ByteString" $ whnf (HM.fromListWith (+)) elemsDupBS+ , bench "Int" $ whnf (HM.fromListWith (+)) elemsDupI+ ]+ ]+ -- Hashable instance+ , bgroup "hash"+ [ bench "String" $ whnf hash hm+ , bench "ByteString" $ whnf hash hmbs+ ] ] ]- where- n :: Int- n = 2^(12 :: Int) - elems = zip keys [1..n]- keys = US.rnd 8 n- elemsBS = zip keysBS [1..n]- keysBS = UBS.rnd 8 n- elemsI = zip keysI [1..n]- keysI = UI.rnd (n+n) n- elemsI2 = zip [n `div` 2..n + (n `div` 2)] [1..n] -- for union-- keys' = US.rnd' 8 n- keysBS' = UBS.rnd' 8 n- keysI' = UI.rnd' (n+n) n- ------------------------------------------------------------------------ -- * HashMap -lookup :: (Eq k, Hashable k) => [k] -> HM.HashMap k Int -> Int+lookup :: Hashable k => [k] -> HM.HashMap k Int -> Int lookup xs m = foldl' (\z k -> fromMaybe z (HM.lookup k m)) 0 xs {-# SPECIALIZE lookup :: [Int] -> HM.HashMap Int Int -> Int #-} {-# SPECIALIZE lookup :: [String] -> HM.HashMap String Int -> Int #-} {-# SPECIALIZE lookup :: [BS.ByteString] -> HM.HashMap BS.ByteString Int -> Int #-} -insert :: (Eq k, Hashable k) => [(k, Int)] -> HM.HashMap k Int+insert :: Hashable k => [(k, Int)] -> HM.HashMap k Int -> HM.HashMap k Int insert xs m0 = foldl' (\m (k, v) -> HM.insert k v m) m0 xs {-# SPECIALIZE insert :: [(Int, Int)] -> HM.HashMap Int Int@@ -190,7 +399,7 @@ {-# SPECIALIZE insert :: [(BS.ByteString, Int)] -> HM.HashMap BS.ByteString Int -> HM.HashMap BS.ByteString Int #-} -delete :: (Eq k, Hashable k) => [k] -> HM.HashMap k Int -> HM.HashMap k Int+delete :: Hashable k => [k] -> HM.HashMap k Int -> HM.HashMap k Int delete xs m0 = foldl' (\m k -> HM.delete k m) m0 xs {-# SPECIALIZE delete :: [Int] -> HM.HashMap Int Int -> HM.HashMap Int Int #-} {-# SPECIALIZE delete :: [String] -> HM.HashMap String Int@@ -198,6 +407,57 @@ {-# SPECIALIZE delete :: [BS.ByteString] -> HM.HashMap BS.ByteString Int -> HM.HashMap BS.ByteString Int #-} +alterInsert :: Hashable k => [(k, Int)] -> HM.HashMap k Int+ -> HM.HashMap k Int+alterInsert xs m0 =+ foldl' (\m (k, v) -> HM.alter (const . Just $ v) k m) m0 xs+{-# SPECIALIZE alterInsert :: [(Int, Int)] -> HM.HashMap Int Int+ -> HM.HashMap Int Int #-}+{-# SPECIALIZE alterInsert :: [(String, Int)] -> HM.HashMap String Int+ -> HM.HashMap String Int #-}+{-# SPECIALIZE alterInsert :: [(BS.ByteString, Int)] -> HM.HashMap BS.ByteString Int+ -> HM.HashMap BS.ByteString Int #-}++alterDelete :: Hashable k => [k] -> HM.HashMap k Int+ -> HM.HashMap k Int+alterDelete xs m0 =+ foldl' (\m k -> HM.alter (const Nothing) k m) m0 xs+{-# SPECIALIZE alterDelete :: [Int] -> HM.HashMap Int Int+ -> HM.HashMap Int Int #-}+{-# SPECIALIZE alterDelete :: [String] -> HM.HashMap String Int+ -> HM.HashMap String Int #-}+{-# SPECIALIZE alterDelete :: [BS.ByteString] -> HM.HashMap BS.ByteString Int+ -> HM.HashMap BS.ByteString Int #-}++alterFInsert :: Hashable k => [(k, Int)] -> HM.HashMap k Int+ -> HM.HashMap k Int+alterFInsert xs m0 =+ foldl' (\m (k, v) -> runIdentity $ HM.alterF (const . Identity . Just $ v) k m) m0 xs+{-# SPECIALIZE alterFInsert :: [(Int, Int)] -> HM.HashMap Int Int+ -> HM.HashMap Int Int #-}+{-# SPECIALIZE alterFInsert :: [(String, Int)] -> HM.HashMap String Int+ -> HM.HashMap String Int #-}+{-# SPECIALIZE alterFInsert :: [(BS.ByteString, Int)] -> HM.HashMap BS.ByteString Int+ -> HM.HashMap BS.ByteString Int #-}++alterFDelete :: Hashable k => [k] -> HM.HashMap k Int+ -> HM.HashMap k Int+alterFDelete xs m0 =+ foldl' (\m k -> runIdentity $ HM.alterF (const . Identity $ Nothing) k m) m0 xs+{-# SPECIALIZE alterFDelete :: [Int] -> HM.HashMap Int Int+ -> HM.HashMap Int Int #-}+{-# SPECIALIZE alterFDelete :: [String] -> HM.HashMap String Int+ -> HM.HashMap String Int #-}+{-# SPECIALIZE alterFDelete :: [BS.ByteString] -> HM.HashMap BS.ByteString Int+ -> HM.HashMap BS.ByteString Int #-}++isSubmapOfNaive :: Hashable k => HM.HashMap k Int -> HM.HashMap k Int -> Bool+isSubmapOfNaive m1 m2 = and [ Just v1 == HM.lookup k1 m2 | (k1,v1) <- HM.toList m1 ]+{-# SPECIALIZE isSubmapOfNaive :: HM.HashMap Int Int -> HM.HashMap Int Int -> Bool #-}+{-# SPECIALIZE isSubmapOfNaive :: HM.HashMap String Int -> HM.HashMap String Int -> Bool #-}+{-# SPECIALIZE isSubmapOfNaive :: HM.HashMap BS.ByteString Int -> HM.HashMap BS.ByteString Int -> Bool #-}++#ifdef BENCH_containers_Map ------------------------------------------------------------------------ -- * Map @@ -218,8 +478,36 @@ {-# SPECIALIZE deleteM :: [String] -> M.Map String Int -> M.Map String Int #-} {-# SPECIALIZE deleteM :: [BS.ByteString] -> M.Map BS.ByteString Int -> M.Map BS.ByteString Int #-}+#endif +#ifdef BENCH_hashmap_Map ------------------------------------------------------------------------+-- * Map from the hashmap package++lookupIHM :: (Hashable k, Ord k) => [k] -> IHM.Map k Int -> Int+lookupIHM xs m = foldl' (\z k -> fromMaybe z (IHM.lookup k m)) 0 xs+{-# SPECIALIZE lookupIHM :: [String] -> IHM.Map String Int -> Int #-}+{-# SPECIALIZE lookupIHM :: [BS.ByteString] -> IHM.Map BS.ByteString Int+ -> Int #-}++insertIHM :: (Hashable k, Ord k) => [(k, Int)] -> IHM.Map k Int+ -> IHM.Map k Int+insertIHM xs m0 = foldl' (\m (k, v) -> IHM.insert k v m) m0 xs+{-# SPECIALIZE insertIHM :: [(String, Int)] -> IHM.Map String Int+ -> IHM.Map String Int #-}+{-# SPECIALIZE insertIHM :: [(BS.ByteString, Int)] -> IHM.Map BS.ByteString Int+ -> IHM.Map BS.ByteString Int #-}++deleteIHM :: (Hashable k, Ord k) => [k] -> IHM.Map k Int -> IHM.Map k Int+deleteIHM xs m0 = foldl' (\m k -> IHM.delete k m) m0 xs+{-# SPECIALIZE deleteIHM :: [String] -> IHM.Map String Int+ -> IHM.Map String Int #-}+{-# SPECIALIZE deleteIHM :: [BS.ByteString] -> IHM.Map BS.ByteString Int+ -> IHM.Map BS.ByteString Int #-}+#endif++#ifdef BENCH_containers_IntMap+------------------------------------------------------------------------ -- * IntMap lookupIM :: [Int] -> IM.IntMap Int -> Int@@ -230,3 +518,4 @@ deleteIM :: [Int] -> IM.IntMap Int -> IM.IntMap Int deleteIM xs m0 = foldl' (\m k -> IM.delete k m) m0 xs+#endif
+ benchmarks/FineGrained.hs view
@@ -0,0 +1,608 @@+-- This file is formatted with https://hackage.haskell.org/package/ormolu+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import Control.DeepSeq (NFData)+import Control.Monad (replicateM)+import Data.Bifunctor (second)+import Data.Bits (testBit)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet+import Data.Hashable+import Data.List+import Key.Bytes+import System.Random.Stateful+import Test.Tasty.Bench+import Prelude hiding (Foldable (..), lookup)++main :: IO ()+main =+ defaultMain+ [ bgroup+ "HashMap.Strict"+ [ bFromList,+ bLookup,+ bInsert,+ bUpdate,+ bAlter,+ bDelete,+ bUnion,+ bUnions,+ bIntersection,+ bDifference,+ bDifferenceWith+ ],+ bgroup "HashSet" [bSetFromList]+ ]++defaultSizes :: [Int]+defaultSizes = [0, 1, 10, 100, 1000, 10_000, 100_000]++-- | Length of a 'Bytes' key in bytes.+--+-- For comparison: A SHA256 hash is 32 bytes long.+bytesLength :: Int+bytesLength = 32++-- | Pseudo-random generator for keys etc.+--+-- Change the seed to generate different random elements.+defaultGen :: StdGen+defaultGen = mkStdGen 42++bFromList :: Benchmark+bFromList =+ bgroup+ "fromList"+ [ bgroup' "Bytes" setupBytes b,+ bgroup' "Int" genInts b+ ]+ where+ setupBytes s gen = genNBytes s bytesLength gen+ b s = bench (show s) . whnf (HM.fromList . map (,()))++-- 1000 lookups each, so we get more precise timings+bLookup :: Benchmark+bLookup =+ bgroup+ "lookup (1000x)"+ [ bgroup "presentKey" bLookupPresentKey,+ bgroup "absentKey" bLookupAbsentKey+ ]++bLookupPresentKey :: [Benchmark]+bLookupPresentKey =+ [ bgroup'WithSizes sizes "Bytes" setupBytes b,+ bgroup'WithSizes sizes "Int" setupInts b+ ]+ where+ sizes = filter (/= 0) defaultSizes+ b s =+ bench (show s)+ . whnf (\(m, ks) -> foldl' (\() k -> HM.lookup k m `seq` ()) () ks)+ toKs = take 1000 . Data.List.cycle . HM.keys+ setupBytes size gen = do+ m <- genBytesMap size gen+ return (m, toKs m)+ setupInts size gen = do+ m <- genIntMap size gen+ return (m, toKs m)++bLookupAbsentKey :: [Benchmark]+bLookupAbsentKey =+ [ bgroup' "Bytes" setupBytes b,+ bgroup' "Int" setupInts b+ ]+ where+ b s =+ bench (show s)+ . whnf (\(m, ks) -> foldl' (\() k -> HM.lookup k m `seq` ()) () ks)+ setupBytes size gen = do+ m <- genBytesMap size gen+ ks0 <- genNBytes 2000 bytesLength gen+ let ks1 = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks0+ return (m, ks1)+ setupInts size gen = do+ m <- genIntMap size gen+ ks0 <- genInts 2000 gen+ let ks1 = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks0+ return (m, ks1)++-- 1000 insertions each, so we get more precise timings+bInsert :: Benchmark+bInsert =+ bgroup+ "insert (1000x)"+ [ bgroup+ "presentKey"+ [ bgroup "sameValue" bInsertPresentKeySameValue,+ bgroup "differentValue" bInsertPresentKeyDifferentValue+ ],+ bgroup "absentKey" bInsertAbsentKey+ ]++bInsertPresentKeySameValue :: [Benchmark]+bInsertPresentKeySameValue =+ [ bgroup'WithSizes sizes "Bytes" setupBytes b,+ bgroup'WithSizes sizes "Int" setupInts b+ ]+ where+ sizes = filter (/= 0) defaultSizes+ b s =+ bench (show s)+ . whnf (\(m, kvs) -> foldl' (\() (k, v) -> HM.insert k v m `seq` ()) () kvs)+ toKVs = take 1000 . Data.List.cycle . HM.toList+ setupBytes size gen = do+ m <- genBytesMap size gen+ return (m, toKVs m)+ setupInts size gen = do+ m <- genIntMap size gen+ return (m, toKVs m)++bInsertPresentKeyDifferentValue :: [Benchmark]+bInsertPresentKeyDifferentValue =+ [ bgroup'WithSizes sizes "Bytes" setupBytes b,+ bgroup'WithSizes sizes "Int" setupInts b+ ]+ where+ sizes = filter (/= 0) defaultSizes+ b s =+ bench (show s)+ . whnf (\(m, kvs) -> foldl' (\() (k, v) -> HM.insert k v m `seq` ()) () kvs)+ toKVs = take 1000 . Data.List.cycle . map (second (+ 1)) . HM.toList+ setupBytes size gen = do+ m <- genBytesMap size gen+ return (m, toKVs m)+ setupInts size gen = do+ m <- genIntMap size gen+ return (m, toKVs m)++bInsertAbsentKey :: [Benchmark]+bInsertAbsentKey =+ [ bgroup' "Bytes" setupBytes b,+ bgroup' "Int" setupInts b+ ]+ where+ b s =+ bench (show s)+ . whnf (\(m, kvs) -> foldl' (\() (k, v) -> HM.insert k v m `seq` ()) () kvs)+ setupBytes size gen = do+ m <- genBytesMap size gen+ ks <- genNBytes 2000 bytesLength gen+ let kvs = take 1000 $ Data.List.cycle $ map (,1) $ filter (not . flip HM.member m) ks+ return (m, kvs)+ setupInts size gen = do+ m <- genIntMap size gen+ ks <- genInts 2000 gen+ let kvs = take 1000 $ Data.List.cycle $ map (,1) $ filter (not . flip HM.member m) ks+ return (m, kvs)++bUpdate :: Benchmark+bUpdate =+ bgroup+ "update (1000x)"+ [ bgroup "presentKey" bUpdatePresentKey,+ bgroup "absentKey" bUpdateAbsentKey+ ]++updateF :: Int -> Maybe Int+updateF x+ | intPredicate x = Nothing+ | x `mod` 3 == 0 = Just (x + 1)+ | otherwise = Just x++bUpdateAbsentKey :: [Benchmark]+bUpdateAbsentKey =+ [ bgroup' "Bytes" setupBytes b,+ bgroup' "Int" setupInts b+ ]+ where+ b s =+ bench (show s)+ . whnf (\(m, ks) -> foldl' (\() k -> HM.update updateF k m `seq` ()) () ks)+ setupBytes size gen = do+ m <- genBytesMap size gen+ ks <- genNBytes 2000 bytesLength gen+ let ks' = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks+ return (m, ks')+ setupInts size gen = do+ m <- genIntMap size gen+ ks <- genInts 2000 gen+ let ks' = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks+ return (m, ks')++bUpdatePresentKey :: [Benchmark]+bUpdatePresentKey =+ [ bgroup'WithSizes sizes "Bytes" setupBytes b,+ bgroup'WithSizes sizes "Int" setupInts b+ ]+ where+ sizes = filter (/= 0) defaultSizes+ b s =+ bench (show s)+ . whnf (\(m, ks) -> foldl' (\() k -> HM.update updateF k m `seq` ()) () ks)+ toKs = take 1000 . Data.List.cycle . HM.keys+ setupBytes size gen = do+ m <- genBytesMap size gen+ return (m, toKs m)+ setupInts size gen = do+ m <- genIntMap size gen+ return (m, toKs m)++bAlter :: Benchmark+bAlter =+ bgroup+ "alter (1000x)"+ [ bgroup "presentKey" bAlterPresentKey,+ bgroup "absentKey" bAlterAbsentKey+ ]++alterF' :: (Hashable k) => k -> Maybe Int -> Maybe Int+alterF' k Nothing+ | intPredicate (hash k) = Nothing+ | otherwise = Just (hash k)+alterF' k (Just v)+ | odd n = Nothing+ | intPredicate n = Just (n + 1)+ | otherwise = Just v+ where+ n = hash k + v++bAlterAbsentKey :: [Benchmark]+bAlterAbsentKey =+ [ bgroup' "Bytes" setupBytes b,+ bgroup' "Int" setupInts b+ ]+ where+ b s =+ bench (show s)+ . whnf (\(m, ks) -> foldl' (\() k -> HM.alter (alterF' k) k m `seq` ()) () ks)+ setupBytes size gen = do+ m <- genBytesMap size gen+ ks <- genNBytes 2000 bytesLength gen+ let ks' = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks+ return (m, ks')+ setupInts size gen = do+ m <- genIntMap size gen+ ks <- genInts 2000 gen+ let ks' = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks+ return (m, ks')++bAlterPresentKey :: [Benchmark]+bAlterPresentKey =+ [ bgroup'WithSizes sizes "Bytes" setupBytes b,+ bgroup'WithSizes sizes "Int" setupInts b+ ]+ where+ sizes = filter (/= 0) defaultSizes+ b s =+ bench (show s)+ . whnf (\(m, ks) -> foldl' (\() k -> HM.alter (alterF' k) k m `seq` ()) () ks)+ toKs = take 1000 . Data.List.cycle . HM.keys+ setupBytes size gen = do+ m <- genBytesMap size gen+ return (m, toKs m)+ setupInts size gen = do+ m <- genIntMap size gen+ return (m, toKs m)++-- 1000 deletions each, so we get more precise timings+bDelete :: Benchmark+bDelete =+ bgroup+ "delete (1000x)"+ [ bgroup "presentKey" bDeletePresentKey,+ bgroup "absentKey" bDeleteAbsentKey+ ]++bDeletePresentKey :: [Benchmark]+bDeletePresentKey =+ [ bgroup'WithSizes sizes "Bytes" setupBytes b,+ bgroup'WithSizes sizes "Int" setupInts b+ ]+ where+ sizes = filter (/= 0) defaultSizes+ b s =+ bench (show s)+ . whnf (\(m, ks) -> foldl' (\() k -> HM.delete k m `seq` ()) () ks)+ toKs = take 1000 . Data.List.cycle . HM.keys+ setupBytes size gen = do+ m <- genBytesMap size gen+ return (m, toKs m)+ setupInts size gen = do+ m <- genIntMap size gen+ return (m, toKs m)++bDeleteAbsentKey :: [Benchmark]+bDeleteAbsentKey =+ [ bgroup' "Bytes" setupBytes b,+ bgroup' "Int" setupInts b+ ]+ where+ b s =+ bench (show s)+ . whnf (\(m, ks) -> foldl' (\() k -> HM.delete k m `seq` ()) () ks)+ setupBytes size gen = do+ m <- genBytesMap size gen+ ks0 <- genNBytes 2000 bytesLength gen+ let ks1 = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks0+ return (m, ks1)+ setupInts size gen = do+ m <- genIntMap size gen+ ks0 <- genInts 2000 gen+ let ks1 = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks0+ return (m, ks1)++-- TODO: For the "overlap" and "equal" cases, it would be interesting to+-- have separate benchmarks both with and without shared subtrees,+-- so we can make use of pointer equality.+bUnion :: Benchmark+bUnion =+ bgroup+ "union"+ [ bgroup "disjoint" bUnionDisjoint,+ bgroup "overlap" bUnionOverlap,+ bgroup "equal" bUnionEqual+ ]++bUnionDisjoint :: [Benchmark]+bUnionDisjoint =+ [ bgroup' "Bytes" genBytesMapsDisjoint b,+ bgroup' "Int" genIntMapsDisjoint b+ ]+ where+ b s = bench (show s) . whnf (\(as, bs) -> HM.union as bs)++bUnionOverlap :: [Benchmark]+bUnionOverlap =+ [ bgroup' "Bytes" genBytesMapsOverlap b,+ bgroup' "Int" genIntMapsOverlap b+ ]+ where+ b s = bench (show s) . whnf (\(as, bs) -> HM.union as bs)++bUnionEqual :: [Benchmark]+bUnionEqual =+ [ bgroup' "Bytes" genBytesMap b,+ bgroup' "Int" genIntMap b+ ]+ where+ b size = bench (show size) . whnf (\m -> HM.union m m)++bUnions :: Benchmark+bUnions =+ bgroup+ "unions"+ [ bgroup'WithSizes sizes "Bytes" setupBytes b,+ bgroup'WithSizes sizes "Int" setupInts b+ ]+ where+ sizes = filter (>= 10) defaultSizes+ b size = bench (show size) . whnf (\ms -> HM.unions ms)+ setupBytes s gen = replicateM 10 (genBytesMap (s `div` 10) gen)+ setupInts s gen = replicateM 10 (genBytesMap (s `div` 10) gen)++-- TODO: For the "overlap" and "equal" cases, it would be interesting to+-- have separate benchmarks both with and without shared subtrees,+-- so we can make use of pointer equality.+bIntersection :: Benchmark+bIntersection =+ bgroup+ "intersection"+ [ bgroup "disjoint" bIntersectionDisjoint,+ bgroup "overlap" bIntersectionOverlap,+ bgroup "equal" bIntersectionEqual+ ]++bIntersectionDisjoint :: [Benchmark]+bIntersectionDisjoint =+ [ bgroup' "Bytes" genBytesMapsDisjoint b,+ bgroup' "Int" genIntMapsDisjoint b+ ]+ where+ b size = bench (show size) . whnf (\(xs, ys) -> HM.intersection xs ys)++bIntersectionOverlap :: [Benchmark]+bIntersectionOverlap =+ [ bgroup' "Bytes" genBytesMapsOverlap b,+ bgroup' "Int" genIntMapsOverlap b+ ]+ where+ b size = bench (show size) . whnf (\(xs, ys) -> HM.intersection xs ys)++bIntersectionEqual :: [Benchmark]+bIntersectionEqual =+ [ bgroup' "Bytes" genBytesMap b,+ bgroup' "Int" genIntMap b+ ]+ where+ b size = bench (show size) . whnf (\m -> HM.intersection m m)++-- TODO: For the "overlap" and "equal" cases, it would be interesting to+-- have separate benchmarks both with and without shared subtrees,+-- so we can make use of pointer equality.+bDifference :: Benchmark+bDifference =+ bgroup+ "difference"+ [ bgroup "disjoint" bDifferenceDisjoint,+ bgroup "overlap" bDifferenceOverlap,+ bgroup "equal" bDifferenceEqual+ ]++bDifferenceDisjoint :: [Benchmark]+bDifferenceDisjoint =+ [ bgroup' "Bytes" genBytesMapsDisjoint b,+ bgroup' "Int" genIntMapsDisjoint b+ ]+ where+ b size = bench (show size) . whnf (\(xs, ys) -> HM.difference xs ys)++bDifferenceOverlap :: [Benchmark]+bDifferenceOverlap =+ [ bgroup' "Bytes" genBytesMapsOverlap b,+ bgroup' "Int" genIntMapsOverlap b+ ]+ where+ b size = bench (show size) . whnf (\(xs, ys) -> HM.difference xs ys)++bDifferenceEqual :: [Benchmark]+bDifferenceEqual =+ [ bgroup' "Bytes" genBytesMap b,+ bgroup' "Int" genIntMap b+ ]+ where+ b size = bench (show size) . whnf (\m -> HM.difference m m)++bDifferenceWith :: Benchmark+bDifferenceWith =+ bgroup+ "differenceWith"+ [ bgroup "disjoint" bDifferenceWithDisjoint,+ bgroup "overlap" bDifferenceWithOverlap,+ bgroup "equal" bDifferenceWithEqual+ ]++differenceWithF :: Int -> Int -> Maybe Int+differenceWithF x y = Just (x + y)++bDifferenceWithDisjoint :: [Benchmark]+bDifferenceWithDisjoint =+ [ bgroup' "Bytes" genBytesMapsDisjoint b,+ bgroup' "Int" genIntMapsDisjoint b+ ]+ where+ b size = bench (show size) . whnf (\(xs, ys) -> HM.differenceWith differenceWithF xs ys)++bDifferenceWithOverlap :: [Benchmark]+bDifferenceWithOverlap =+ [ bgroup' "Bytes" genBytesMapsOverlap b,+ bgroup' "Int" genIntMapsOverlap b+ ]+ where+ b size = bench (show size) . whnf (\(xs, ys) -> HM.differenceWith differenceWithF xs ys)++bDifferenceWithEqual :: [Benchmark]+bDifferenceWithEqual =+ [ bgroup' "Bytes" genBytesMap b,+ bgroup' "Int" genIntMap b+ ]+ where+ b size = bench (show size) . whnf (\m -> HM.differenceWith differenceWithF m m)++bSetFromList :: Benchmark+bSetFromList =+ bgroup+ "fromList"+ [ bgroup' "Bytes" (\s gen -> genNBytes s bytesLength gen) b,+ bgroup' "Int" genInts b+ ]+ where+ b size = bench (show size) . whnf Data.HashSet.fromList++-------------------------------------------------------------------------------+-- Boilerplate++bgroup' ::+ (NFData env) =>+ String ->+ (Int -> IOGenM StdGen -> IO env) ->+ (Int -> env -> Benchmark) ->+ Benchmark+bgroup' = bgroup'WithSizes defaultSizes++bgroup'WithSizes ::+ (NFData env) =>+ [Int] ->+ String ->+ (Int -> IOGenM StdGen -> IO env) ->+ (Int -> env -> Benchmark) ->+ Benchmark+bgroup'WithSizes sizes name setup b = bgroup name [env' setup b s | s <- sizes]++env' ::+ (NFData env) =>+ (Int -> IOGenM StdGen -> IO env) ->+ (Int -> env -> Benchmark) ->+ Int ->+ Benchmark+env' setup b size =+ env+ ( do+ gen <- newIOGenM defaultGen+ setup size gen+ )+ (b size)++-------------------------------------------------------------------------------+-- Generators++keysToMap :: (Hashable k) => [k] -> HashMap k Int+keysToMap = HM.fromList . map (\k -> (k, hashWithSalt 123 k))++genInts ::+ (StatefulGen g m) =>+ Int ->+ g ->+ m [Int]+genInts n = replicateM n . uniformM++genBytesMap :: (StatefulGen g m) => Int -> g -> m (HashMap Bytes Int)+genBytesMap s gen = do+ ks <- Key.Bytes.genNBytes s bytesLength gen+ return (keysToMap ks)++genIntMap :: (StatefulGen g m) => Int -> g -> m (HashMap Int Int)+genIntMap s gen = do+ ks <- genInts s gen+ return (keysToMap ks)++genBytesMapsOverlap ::+ (StatefulGen g m) =>+ Int -> g -> m (HashMap Bytes Int, HashMap Bytes Int)+genBytesMapsOverlap s gen = do+ (trues, falses) <- Key.Bytes.genDisjoint s bytesLength gen+ let (a_sep, b_sep) = splitAt (s `div` 4) trues+ return+ ( keysToMap falses `HM.union` keysToMap a_sep,+ keysToMap falses `HM.union` keysToMap b_sep+ )++genIntMapsOverlap ::+ (StatefulGen g m) =>+ Int -> g -> m (HashMap Int Int, HashMap Int Int)+genIntMapsOverlap s gen = do+ let s_overlap = s `div` 2+ let s_a_sep = (s - s_overlap) `div` 2+ let s_b_sep = s - s_overlap - s_a_sep+ overlap <- genInts s_overlap gen+ a_sep <- genInts s_a_sep gen+ b_sep <- genInts s_b_sep gen+ return+ ( keysToMap overlap `HM.union` keysToMap a_sep,+ keysToMap overlap `HM.union` keysToMap b_sep+ )++genIntMapsDisjoint ::+ (StatefulGen g m) =>+ Int -> g -> m (HashMap Int Int, HashMap Int Int)+genIntMapsDisjoint s gen = do+ ints <- genInts s gen+ let (trues, falses) = Data.List.partition intPredicate ints+ return (keysToMap trues, keysToMap falses)++genBytesMapsDisjoint ::+ (StatefulGen g m) =>+ Int -> g -> m (HashMap Bytes Int, HashMap Bytes Int)+genBytesMapsDisjoint s gen = do+ (trues, falses) <- Key.Bytes.genDisjoint s bytesLength gen+ return (keysToMap trues, keysToMap falses)++intPredicate :: Int -> Bool+intPredicate n = testBit n 31
+ benchmarks/Key/Bytes.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Key.Bytes where++import Control.DeepSeq+import Control.Monad (replicateM)+import Data.ByteString.Short+import Data.Hashable+import Data.List+import System.Random.Stateful++newtype Bytes = Bytes {unBytes :: ShortByteString}+ deriving (Eq, Hashable, Show, NFData)++genBytes ::+ (StatefulGen g m) =>+ Int ->+ g ->+ m Bytes+genBytes len gen = Bytes <$> uniformShortByteStringM len gen++genNBytes ::+ (StatefulGen g m) =>+ Int ->+ Int ->+ g ->+ m [Bytes]+genNBytes n len = replicateM n . genBytes len++-- | @genDisjoint n len gen@ generates @n@ 'Bytes' in total. The returned lists+-- each contain roughly half of the total.+genDisjoint ::+ (StatefulGen g m) =>+ Int ->+ -- | Must be positive+ Int ->+ g ->+ m ([Bytes], [Bytes])+genDisjoint n len gen = Data.List.partition predicate <$> genNBytes n len gen+ where+ predicate (Bytes sbs) = even (Data.ByteString.Short.head sbs)++{-+instance Uniform Bytes where+ uniformM = genBytes 32+-}
− benchmarks/Makefile
@@ -1,45 +0,0 @@-ghc-prof-flags :=-ifdef ENABLE_PROFILING- ghc-prof-flags += -prof -hisuf p_hi -osuf p_o- lib-suffix := _p-else- lib-suffix :=-endif--ghc := ghc-extra-ghc-flags :=--package := unordered-containers-version := $(shell awk '/^version:/{print $$2}' ../$(package).cabal)-lib := ../dist/build/libHS$(package)-$(version)$(lib-suffix).a-ghc-flags := -Wall -O2 -hide-all-packages \- -package-conf ../dist/package.conf.inplace -package base -package mtl \- -package unordered-containers -package containers -package criterion \- -package deepseq -package hashable -package random -package bytestring \- $(ghc-prof-flags) -rtsopts-ghc-flags += $(extra-ghc-flags)-criterion-flags :=--%.o: %.hs- $(ghc) $(ghc-flags) -c -o $@ $<--programs := bench--.PHONY: all-all: $(programs)--bench: $(lib) Benchmarks.o Util/Int.o Util/ByteString.o Util/String.o- ranlib $(lib)- $(ghc) $(ghc-flags) -threaded -o $@ $(filter %.o,$^) $(lib)--.PHONY: bench-all-bench-all: bench- ./bench $(criterion-flags) +RTS -H -RTS `./bench -l | sed 's/ *\(.*\)/\1/' | grep -v "Benchmarks:\|IntMap\|Map"`--.PHONY: clean-clean:- -find . \( -name '*.o' -o -name '*.hi' \) -exec rm {} \;- -rm -f $(programs)--Benchmarks.o: Util/Int.o Util/ByteString.o Util/String.o-Util/ByteString.o: Util/String.o
benchmarks/Util/ByteString.hs view
@@ -2,10 +2,9 @@ -- random 'ByteString's. module Util.ByteString where -import qualified Data.ByteString as S+import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C--import Util.String as String+import qualified Util.String as String -- | Generate a number of fixed length 'ByteString's where the content -- of the strings are letters in ascending order.
+ tests/Main.hs view
@@ -0,0 +1,17 @@+module Main (main) where++import GHC.IO.Encoding (setLocaleEncoding, utf8)+import Test.Tasty (defaultMain, testGroup)++import qualified Properties+import qualified Regressions+import qualified Strictness++main :: IO ()+main = do+ setLocaleEncoding utf8+ defaultMain $ testGroup "All"+ [ Properties.tests+ , Regressions.tests+ , Strictness.tests+ ]
− tests/MapProperties.hs
@@ -1,222 +0,0 @@- {-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | Tests for the 'Data.HashMap.Lazy' module. We test functions by--- comparing them to a simpler model, an association list.--module Main (main) where--import qualified Data.Foldable as Foldable-import Data.Function (on)-import Data.Hashable (Hashable(hash))-import qualified Data.List as L-import qualified Data.HashMap.Lazy as M-import Test.QuickCheck (Arbitrary)-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)---- Key type that generates more hash collisions.-newtype Key = K { unK :: Int }- deriving (Arbitrary, Eq, Ord, Show)--instance Hashable Key where- hash k = hash (unK k) `mod` 20----------------------------------------------------------------------------- * Properties----------------------------------------------------------------------------- ** Instances--pEq :: [(Key, Int)] -> [(Key, Int)] -> Bool-pEq xs ys = (as ==) `eq` (M.fromList as ==) $ bs- where as = fromList xs- bs = fromList ys--pNeq :: [(Key, Int)] -> [(Key, Int)] -> Bool-pNeq xs = (xs /=) `eq` (M.fromList xs /=)--pFunctor :: [(Key, Int)] -> Bool-pFunctor = fmap (\ (k, v) -> (k, v + 1)) `eq` (toAscList . fmap (+ 1))--pFoldable :: [(Int, Int)] -> Bool-pFoldable = (L.sort . Foldable.foldr (\ (_, v) z -> v:z) []) `eq`- (L.sort . Foldable.foldr (:) [])----------------------------------------------------------------------------- ** Basic interface--pSize :: [(Key, Int)] -> Bool-pSize = length `eq` M.size--pLookup :: Key -> [(Key, Int)] -> Bool-pLookup k = L.lookup k `eq` M.lookup k--pInsert :: Key -> Int -> [(Key, Int)] -> Bool-pInsert k v = insert (k, v) `eq` (toAscList . M.insert k v)--pDelete :: Key -> [(Key, Int)] -> Bool-pDelete k = delete k `eq` (toAscList . M.delete k)--pInsertWith :: Key -> [(Key, Int)] -> Bool-pInsertWith k = insertWith (+) (k, 1) `eq`- (toAscList . M.insertWith (+) k 1)----------------------------------------------------------------------------- ** Combine--pUnion :: [(Key, Int)] -> [(Key, Int)] -> Bool-pUnion xs ys = L.sort (unionByKey as bs) == - toAscList (M.union (M.fromList as) (M.fromList bs))- where- as = fromList xs- bs = fromList ys--pUnionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool-pUnionWith xs ys = L.sort (unionByKeyWith (-) as bs) ==- toAscList (M.unionWith (-) (M.fromList as) (M.fromList bs))- where- as = fromList xs- bs = fromList ys----------------------------------------------------------------------------- ** Transformations--pMap :: [(Key, Int)] -> Bool-pMap = map (\ (k, v) -> (k, v + 1)) `eq` (toAscList . M.map (+ 1))----------------------------------------------------------------------------- ** Folds--pFoldr :: [(Int, Int)] -> Bool-pFoldr = (L.sort . L.foldr (\ (_, v) z -> v:z) []) `eq`- (L.sort . M.foldr (:) [])--pFoldrWithKey :: [(Int, Int)] -> Bool-pFoldrWithKey = (sortByKey . L.foldr (:) []) `eq`- (sortByKey . M.foldrWithKey f [])- where f k v z = (k, v) : z--pFoldl' :: Int -> [(Int, Int)] -> Bool-pFoldl' z0 = L.foldl' (\ z (_, v) -> z + v) z0 `eq` M.foldl' (+) z0----------------------------------------------------------------------------- ** Conversions--pToList :: [(Key, Int)] -> Bool-pToList = id `eq` toAscList--pElems :: [(Key, Int)] -> Bool-pElems = (L.sort . map snd) `eq` (L.sort . M.elems)--pKeys :: [(Key, Int)] -> Bool-pKeys = map fst `eq` (L.sort . M.keys)----------------------------------------------------------------------------- * Test list--tests :: [Test]-tests =- [- -- Instances- testGroup "instances"- [ testProperty "==" pEq- , testProperty "/=" pNeq- , testProperty "Functor" pFunctor- , testProperty "Foldable" pFoldable- ]- -- Basic interface- , testGroup "basic interface"- [ testProperty "size" pSize- , testProperty "lookup" pLookup- , testProperty "insert" pInsert- , testProperty "delete" pDelete- , testProperty "insertWith" pInsertWith- ]- -- Combine- , testProperty "union" pUnion- , testProperty "unionWith" pUnionWith- -- Transformations- , testProperty "map" pMap- -- Folds- , testGroup "folds"- [ testProperty "foldr" pFoldr- , testProperty "foldrWithKey" pFoldrWithKey- , testProperty "foldl'" pFoldl'- ]- -- Conversions- , testGroup "conversions"- [ testProperty "elems" pElems- , testProperty "keys" pKeys- , testProperty "toList" pToList- ]- ]----------------------------------------------------------------------------- * Model---- Invariant: the list is sorted in ascending order, by key.-type Model k v = [(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' in the same- -- way- -> (M.HashMap k v -> a) -- ^ Function that modified a 'HashMap'- -> [(k, v)] -- ^ Initial content of the 'HashMap' and 'Model'- -> Bool -- ^ True if the functions are equivalent-eq f g xs = g (M.fromList ys) == f ys- where ys = fromList xs--insert :: Ord k => (k, v) -> Model k v -> Model k v-insert x [] = [x]-insert x@(k, _) (y@(k', _):xs)- | k == k' = x : xs- | k > k' = y : insert x xs- | otherwise = x : y : xs--delete :: Ord k => k -> Model k v -> Model k v-delete _ [] = []-delete k ys@(y@(k', _):xs)- | k == k' = xs- | k > k' = y : delete k xs- | otherwise = ys--insertWith :: Ord k => (v -> v -> v) -> (k, v) -> Model k v -> Model k v-insertWith _ x [] = [x]-insertWith f x@(k, v) (y@(k', v'):xs)- | k == k' = (k', f v v') : xs- | k > k' = y : insertWith f x xs- | otherwise = x : y : xs---- | Create a model from a list of key-value pairs. If the input--- contains multiple entries for the same key, the latter one is used.-fromList :: Ord k => [(k, v)] -> Model k v-fromList = L.foldl' (\ m p -> insert p m) []----------------------------------------------------------------------------- * Test harness--main :: IO ()-main = defaultMain tests----------------------------------------------------------------------------- * Helpers--sortByKey :: Ord k => [(k, v)] -> [(k, v)]-sortByKey = L.sortBy (compare `on` fst)--unionByKey :: (Eq k, Eq v) => [(k, v)] -> [(k, v)] -> [(k, v)]-unionByKey = L.unionBy ((==) `on` fst)--unionByKeyWith :: (Eq k, Eq v) => (v -> v -> v) -> [(k,v)] -> [(k,v)] -> [(k,v)]-unionByKeyWith f a b = go a b- where- go [] ys = ys- go (x:xs) ys =- case L.lookup (fst x) ys of- Just z -> (fst x, f (snd x) z) : go xs (filter ((/= fst x) . fst) ys)- Nothing -> x : go xs ys--toAscList :: (Ord k, Ord v) => M.HashMap k v -> [(k, v)]-toAscList = L.sort . M.toList
+ tests/Properties.hs view
@@ -0,0 +1,16 @@+module Properties (tests) where++import Test.Tasty (TestTree, testGroup)++import qualified Properties.HashMapLazy+import qualified Properties.HashMapStrict+import qualified Properties.HashSet+import qualified Properties.List++tests :: TestTree+tests = testGroup "Properties"+ [ Properties.HashMapLazy.tests+ , Properties.HashMapStrict.tests+ , Properties.HashSet.tests+ , Properties.List.tests+ ]
+ tests/Properties/HashMapLazy.hs view
@@ -0,0 +1,484 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# 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+#define MODULE_NAME Properties.HashMapLazy+#endif++module MODULE_NAME (tests) where++import Control.Applicative (Const (..))+import Data.Bifoldable+import Data.Function (on)+import Data.Functor.Identity (Identity (..))+import Data.Hashable (Hashable (hashWithSalt))+import Data.HashMap.Internal.Debug (Validity (..), valid)+import Data.Maybe (isJust)+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 Test.QuickCheck as QC++#if defined(STRICT)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as M+#else+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HM+import qualified Data.Map.Lazy as M+#endif++instance (Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where+ arbitrary = HM.fromList <$> arbitrary+ shrink = fmap HM.fromList . shrink . HM.toList++------------------------------------------------------------------------+-- Helpers++type HMK = HashMap Key+type HMKI = HMK Int++sortByKey :: Ord k => [(k, v)] -> [(k, v)]+sortByKey = List.sortBy (compare `on` fst)++toOrdMap :: Ord k => HashMap k v -> M.Map k v+toOrdMap = M.fromList . HM.toList++isValid :: (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.+data Magma a+ = Leaf a+ | Op (Magma a) (Magma a)+ deriving (Show, Eq, Ord)++instance Hashable a => Hashable (Magma a) where+ hashWithSalt s (Leaf a) = hashWithSalt s (hashWithSalt (1::Int) a)+ hashWithSalt s (Op m n) = hashWithSalt s (hashWithSalt (hashWithSalt (2::Int) m) n)++------------------------------------------------------------------------+-- Test list++tests :: TestTree+tests =+ testGroup+#if defined(STRICT)+ "Data.HashMap.Strict"+#else+ "Data.HashMap.Lazy"+#endif+ [+ -- Instances+ testGroup "instances"+ [ 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+ , 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 "lookupKey" $+ [ testProperty "isJust (lookupKey k m) == member k m" $+ \(k :: Key) (m :: HMKI) -> isJust (HM.lookupKey k m) === HM.member k 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 "model" $+ \(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 "delete k m ⊆ m" $+ \k (m :: HMKI) -> 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+ , 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)+ , testProperty "differenceWith (\\x y -> Just $ f x y) xs ys == intersectionWith f xs ys `union` xs" $+ \(Fn2 f) (x :: HMK A) (y :: HMK B) ->+ HM.differenceWith (\a b -> Just $ f a b) x y+ === HM.intersectionWith f x y `HM.union` x+ ]+ , testGroup "differenceWithKey"+ [ testProperty "model" $+ \(Fn3 f) (x :: HMK A) (y :: HMK B) ->+ toOrdMap (HM.differenceWithKey f x y) === M.differenceWithKey f (toOrdMap x) (toOrdMap y)+ , testProperty "valid" $+ \(Fn3 f) (x :: HMK A) (y :: HMK B) -> isValid (HM.differenceWithKey f x y)+ , testProperty "differenceWithKey (\\k x y -> Just $ f k x y) xs ys == intersectionWithKey f xs ys `union` xs" $+ \(Fn3 f) (x :: HMK A) (y :: HMK B) ->+ HM.differenceWithKey (\k a b -> Just $ f k a b) x y+ === HM.intersectionWithKey f x y `HM.union` x+ ]+ , 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 "disjoint"+ [ testProperty "model" $+ \(x :: HMKI) (y :: HMKI) ->+ HM.disjoint x y === M.disjoint (toOrdMap x) (toOrdMap y)+ ]+ , testGroup "compose"+ [ testProperty "valid" $+ \(x :: HMK Int) (y :: HMK Key) -> isValid (HM.compose x y)+ ]+ -- Transformations+ , 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 "traverseWithKey"+ [ testProperty "model" $ QC.mapSize (\s -> min 18 $ div s 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 -> min 18 $ div s 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 "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+ , 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))+ ]
+ tests/Properties/HashMapStrict.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE CPP #-}++#define STRICT++#include "HashMapLazy.hs"
+ tests/Properties/HashSet.hs view
@@ -0,0 +1,138 @@+{-# 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@. @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 Data.Set (Set)+import Test.QuickCheck (Fun, pattern Fn, (===), (==>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (Arbitrary (..), testProperty)+import Util.Key (Key, keyToInt)++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++instance (Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where+ arbitrary = HM.fromList <$> arbitrary+ shrink = fmap HM.fromList . shrink . HM.toList++instance (Hashable a, Arbitrary a) => Arbitrary (HashSet a) where+ arbitrary = HS.fromMap <$> arbitrary+ shrink = fmap HS.fromMap . shrink . HS.toMap++------------------------------------------------------------------------+-- Helpers++type HSK = HashSet Key++toOrdSet :: Ord a => HashSet a -> Set a+toOrdSet = S.fromList . HS.toList++------------------------------------------------------------------------+-- Test list++tests :: TestTree+tests = testGroup "Data.HashSet"+ [ -- 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)+ ]+ , 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+ ]+ -- Basic interface+ , testProperty "size" $+ \(x :: HSK) -> HS.size x === List.length (HS.toList x)+ , testProperty "member" $+ \e (s :: HSK) -> HS.member e s === S.member e (toOrdSet s)+ , testProperty "insert" $+ \e (s :: HSK) -> toOrdSet (HS.insert e s) === S.insert e (toOrdSet s)+ , testProperty "delete" $+ \e (s :: HSK) -> toOrdSet (HS.delete e s) === S.delete e (toOrdSet s)+ -- Combine+ , testProperty "union" $+ \(x :: HSK) y -> toOrdSet (HS.union x y) === S.union (toOrdSet x) (toOrdSet y)+ -- Transformations+ , testProperty "map" $+ \(Fn f :: Fun Key Key) (s :: HSK) -> toOrdSet (HS.map f s) === S.map f (toOrdSet s)+ -- Folds+ , testProperty "foldr" $+ \(s :: HSK) ->+ List.sort (HS.foldr (:) [] s) === List.sort (S.foldr (:) [] (toOrdSet s))+ , testProperty "foldl'" $+ \(s :: HSK) z0 ->+ let f z k = keyToInt k + z+ in HS.foldl' f z0 s === S.foldl' f z0 (toOrdSet s)+ -- Filter+ , testProperty "filter" $+ \(Fn p) (s :: HSK) -> toOrdSet (HS.filter p s) === S.filter p (toOrdSet s)+ -- Conversions+ , testProperty "toList" $+ \(xs :: [Key]) -> List.sort (HS.toList (HS.fromList xs)) === S.toAscList (S.fromList xs)+ ]
+ tests/Properties/List.hs view
@@ -0,0 +1,64 @@+module Properties.List (tests) where++import Data.HashMap.Internal.List+import Data.List (nub, sort, sortBy)+import Data.Ord (comparing)+import Test.QuickCheck (Property, property, (===), (==>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (testProperty)++tests :: TestTree+tests = testGroup "Data.HashMap.Internal.List"+ [ testProperty "isPermutationBy" pIsPermutation+ , testProperty "isPermutationBy of different length" pIsPermutationDiffLength+ , testProperty "pUnorderedCompare" pUnorderedCompare+ , testGroup "modelUnorderedCompare"+ [ testProperty "reflexive" modelUnorderedCompareRefl+ , testProperty "anti-symmetric" modelUnorderedCompareAntiSymm+ , testProperty "transitive" modelUnorderedCompareTrans+ ]+ ]++pIsPermutation :: [Char] -> [Int] -> Bool+pIsPermutation xs is = isPermutationBy (==) xs xs'+ where+ is' = nub is ++ [maximum (0:is) + 1 ..]+ xs' = map fst . sortBy (comparing snd) $ zip xs is'++pIsPermutationDiffLength :: [Int] -> [Int] -> Property+pIsPermutationDiffLength xs ys =+ length xs /= length ys ==> isPermutationBy (==) xs ys === False++-- | Homogenous version of 'unorderedCompare'+--+-- *Compare smallest non-equal elements of the two lists*.+modelUnorderedCompare :: Ord a => [a] -> [a] -> Ordering+modelUnorderedCompare as bs = compare (sort as) (sort bs)++modelUnorderedCompareRefl :: [Int] -> Property+modelUnorderedCompareRefl xs = modelUnorderedCompare xs xs === EQ++modelUnorderedCompareAntiSymm :: [Int] -> [Int] -> Property+modelUnorderedCompareAntiSymm xs ys = case a of+ EQ -> b === EQ+ LT -> b === GT+ GT -> b === LT+ where+ a = modelUnorderedCompare xs ys+ b = modelUnorderedCompare ys xs++modelUnorderedCompareTrans :: [Int] -> [Int] -> [Int] -> Property+modelUnorderedCompareTrans xs ys zs =+ case (modelUnorderedCompare xs ys, modelUnorderedCompare ys zs) of+ (EQ, yz) -> xz === yz+ (xy, EQ) -> xz === xy+ (LT, LT) -> xz === LT+ (GT, GT) -> xz === GT+ (LT, GT) -> property True+ (GT, LT) -> property True+ where+ xz = modelUnorderedCompare xs zs++pUnorderedCompare :: [Int] -> [Int] -> Property+pUnorderedCompare xs ys =+ unorderedCompare compare xs ys === modelUnorderedCompare xs ys
+ tests/Regressions.hs view
@@ -0,0 +1,289 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_GHC -Wno-x-partial #-}+module Regressions (tests) where++import Control.Exception (evaluate)+import Control.Monad (replicateM)+import Data.Bits (shiftL)+import Data.Hashable (Hashable (..))+import Data.List (delete)+import Data.Maybe (isJust, isNothing)+import GHC.Exts (touch#)+import GHC.IO (IO (..))+import Numeric.Natural (Natural)+import System.Mem (performGC)+import System.Mem.Weak (deRefWeak, mkWeakPtr)+import System.Random (randomIO)+import Test.HUnit (Assertion, assert)+import Test.QuickCheck+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)+import Test.Tasty.QuickCheck (testProperty)++import qualified Data.HashMap.Lazy as HML+import qualified Data.HashMap.Strict as HMS+import qualified Data.HashSet as HS+import qualified Test.Tasty as Tasty++import qualified Data.Foldable as Foldable+import NoThunks.Class (noThunksInValues)++issue32 :: Assertion+issue32 = assert $ isJust $ HMS.lookup 7 m'+ where+ ns = [0..16] :: [Int]+ m = HMS.fromList (zip ns (repeat []))+ m' = HMS.delete 10 m++------------------------------------------------------------------------+-- Issue #39++-- First regression++issue39 :: Assertion+issue39 = assert $ hm1 == hm2+ where+ hm1 = HMS.fromList ([a, b] `zip` [1, 1 :: Int ..])+ hm2 = HMS.fromList ([b, a] `zip` [1, 1 :: Int ..])+ a = (1, -1) :: (Int, Int)+ b = (-1, 1) :: (Int, Int)++-- Second regression++newtype Keys = Keys [Int]+ deriving Show++instance Arbitrary Keys where+ arbitrary = sized $ \l -> do+ pis <- replicateM (l+1) positiveInt+ return (Keys $ prefixSum pis)++ shrink (Keys ls) =+ let l = length ls+ in if l == 1+ then []+ else [ Keys (dropAt i ls) | i <- [0..l-1] ]++positiveInt :: Gen Int+positiveInt = (+1) . abs <$> arbitrary++prefixSum :: [Int] -> [Int]+prefixSum = loop 0+ where+ loop _ [] = []+ loop prefix (l:ls) = let n = l + prefix+ in n : loop n ls++dropAt :: Int -> [a] -> [a]+dropAt _ [] = []+dropAt i (l:ls) | i == 0 = ls+ | otherwise = l : dropAt (i-1) ls++propEqAfterDelete :: Keys -> Bool+propEqAfterDelete (Keys keys) =+ let keyMap = mapFromKeys keys+ k = head keys+ in HMS.delete k keyMap == mapFromKeys (delete k keys)++mapFromKeys :: [Int] -> HMS.HashMap Int ()+mapFromKeys keys = HMS.fromList (zip keys (repeat ()))++------------------------------------------------------------------------+-- Issue #254++-- Key type that always collides.+newtype KC = KC Int+ deriving (Eq, Ord, Show)+instance Hashable KC where+ hashWithSalt salt _ = salt++touch :: a -> IO ()+touch a = IO (\s -> (# touch# a s, () #))++-- We want to make sure that old values in the HashMap are evicted when new values are inserted,+-- even if they aren't evaluated. To do that, we use the WeakPtr trick described at+-- http://simonmar.github.io/posts/2018-06-20-Finding-fixing-space-leaks.html.+-- We insert a value named oldV into the HashMap, then insert over it, checking oldV is no longer reachable.+--+-- To make the test robust, it's important that oldV isn't hoisted up to the top or shared.+-- To do that, we generate it randomly.+issue254Lazy :: Assertion+issue254Lazy = do+ i :: Int <- randomIO+ let oldV = error $ "Should not be evaluated: " ++ show i+ weakV <- mkWeakPtr oldV Nothing -- add the ability to test whether oldV is alive+ mp <- evaluate $ HML.insert (KC 1) (error "Should not be evaluated") $ HML.fromList [(KC 0, "1"), (KC 1, oldV)]+ performGC+ res <- deRefWeak weakV -- gives Just if oldV is still alive+ touch mp -- makes sure that we didn't GC away the whole HashMap, just oldV+ assert $ isNothing res++-- Like issue254Lazy, but using strict HashMap+issue254Strict :: Assertion+issue254Strict = do+ i :: Int <- randomIO+ let oldV = show i+ weakV <- mkWeakPtr oldV Nothing+ mp <- evaluate $ HMS.insert (KC 1) "3" $ HMS.fromList [(KC 0, "1"), (KC 1, oldV)]+ performGC+ res <- deRefWeak weakV+ touch mp+ assert $ isNothing res++------------------------------------------------------------------------+-- Issue #379+++issue379Union :: Assertion+issue379Union = do+ let m0 = HMS.fromList [(KC 1, ()), (KC 2, ())]+ let m1 = HMS.fromList [(KC 2, ()), (KC 3, ())]+ let u = m0 `HMS.union` m1+ mThunkInfo <- noThunksInValues mempty (Foldable.toList u)+ assert $ isNothing mThunkInfo++issue379StrictUnionWith :: Assertion+issue379StrictUnionWith = do+ let m0 = HMS.fromList [(KC 1, 10), (KC 2, 20 :: Int)]+ let m1 = HMS.fromList [(KC 2, 20), (KC 3, 30)]+ let u = HMS.unionWith (+) m0 m1+ mThunkInfo <- noThunksInValues mempty (Foldable.toList u)+ assert $ isNothing mThunkInfo++issue379StrictUnionWithKey :: Assertion+issue379StrictUnionWithKey = do+ let m0 = HMS.fromList [(KC 1, 10), (KC 2, 20 :: Int)]+ let m1 = HMS.fromList [(KC 2, 20), (KC 3, 30)]+ let u = HMS.unionWithKey (\(KC i) v0 v1 -> i + v0 + v1) m0 m1+ mThunkInfo <- noThunksInValues mempty (Foldable.toList u)+ assert $ isNothing mThunkInfo++-- Another key type that always collides.+--+-- Note (sjakobi): The KC newtype of Int somehow can't be used to demonstrate+-- the space leak in issue379LazyUnionWith. This type does the trick.+newtype SC = SC String+ deriving (Eq, Ord, Show)+instance Hashable SC where+ hashWithSalt salt _ = salt++issue379LazyUnionWith :: Assertion+issue379LazyUnionWith = do+ i :: Int <- randomIO+ let k = SC (show i)+ weakK <- mkWeakPtr k Nothing -- add the ability to test whether k is alive+ let f :: Int -> Int+ f x = error ("Should not be evaluated " ++ show x)+ let m = HML.fromList [(SC "1", f 1), (SC "2", f 2), (k, f 3)]+ let u = HML.unionWith (+) m m+ Just v <- evaluate $ HML.lookup k u+ performGC+ res <- deRefWeak weakK -- gives Just if k is still alive+ touch v -- makes sure that we didn't GC away the combined value+ assert $ isNothing res++------------------------------------------------------------------------+-- Issue #381++issue381mapMaybe :: Assertion+issue381mapMaybe = do+ let m0 = HMS.fromList [(KC 1, 10), (KC 2, 20 :: Int)]+ let m1 = HMS.mapMaybe (Just . (+ 1)) m0+ mThunkInfo <- noThunksInValues mempty (Foldable.toList m1)+ assert $ isNothing mThunkInfo++issue381mapMaybeWithKey :: Assertion+issue381mapMaybeWithKey = do+ let m0 = HMS.fromList [(KC 1, 10), (KC 2, 20 :: Int)]+ let m1 = HMS.mapMaybeWithKey (\(KC k) v -> Just (k + v)) m0+ mThunkInfo <- noThunksInValues mempty (Foldable.toList m1)+ assert $ isNothing mThunkInfo++------------------------------------------------------------------------+-- Issue #382++issue382 :: Assertion+issue382 = do+ i :: Int <- randomIO+ let k = SC (show i)+ weakK <- mkWeakPtr k Nothing -- add the ability to test whether k is alive+ let f :: Int -> Int -> Int+ f x = error ("Should not be evaluated " ++ show x)+ let m = HML.fromListWith f [(k, 1), (k, 2)]+ Just v <- evaluate $ HML.lookup k m+ performGC+ res <- deRefWeak weakK -- gives Just if k is still alive+ touch v -- makes sure that we didn't GC away the combined value+ assert $ isNothing res++------------------------------------------------------------------------+-- Issue #383++-- Custom Functor to prevent interference from alterF rules+newtype MyIdentity a = MyIdentity a+instance Functor MyIdentity where+ fmap f (MyIdentity x) = MyIdentity (f x)++issue383 :: Assertion+issue383 = do+ i :: Int <- randomIO+ let f Nothing = MyIdentity (Just (fromIntegral @Int @Natural (abs i)))+ f Just{} = MyIdentity (error "Impossible")+ let (MyIdentity m) = HMS.alterF f () mempty+ mThunkInfo <- noThunksInValues mempty (Foldable.toList m)+ assert $ isNothing mThunkInfo++------------------------------------------------------------------------+-- Issue #420++issue420 :: Assertion+issue420 = do+ let k1 :: Int = 1 `shiftL` 10+ let k2 :: Int = 2 `shiftL` 10+ let s0 = HS.fromList [k1, k2]+ let s1 = s0 `HS.intersection` s0+ assert $ k1 `HS.member` s1+ assert $ k2 `HS.member` s1++------------------------------------------------------------------------+-- Issue 491++issue491 :: TestTree+issue491 = Tasty.localOption (Tasty.mkTimeout 1000000) $ testGroup "issue491" $+ [ testCase "1" $ assert $ m [0, -1] `HML.isSubmapOf` m [0, -1]+ , testCase "2" $ assert $ m [1, 0b11111] `HML.isSubmapOf` m [1, 0b11111]+ , testCase "3" $ assert $ m [0, 1] `HML.isSubmapOf` m [0, 1, 0b11111]+ ]+ where m = HS.toMap . HS.fromList @Int++------------------------------------------------------------------------+-- * Test list++tests :: TestTree+tests = testGroup "Regression tests"+ [+ testCase "issue32" issue32+ , testCase "issue39a" issue39+ , testProperty "issue39b" propEqAfterDelete+ , testCase "issue254 lazy" issue254Lazy+ , testCase "issue254 strict" issue254Strict+ , testGroup "issue379"+ [ testCase "Lazy.unionWith" issue379LazyUnionWith+ , testCase "union" issue379Union+ , testCase "Strict.unionWith" issue379StrictUnionWith+ , testCase "Strict.unionWithKey" issue379StrictUnionWithKey+ ]+ , testGroup "issue381"+ [ testCase "mapMaybe" issue381mapMaybe+ , testCase "mapMaybeWithKey" issue381mapMaybeWithKey+ ]+ , testCase "issue382" issue382+ , testCase "issue383" issue383+ , testCase "issue420" issue420+ , issue491+ ]
− tests/SetProperties.hs
@@ -1,171 +0,0 @@- {-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | Tests for the 'Data.HashSet' module. We test functions by--- comparing them to a simpler model, a list.--module Main (main) where--import qualified Data.Foldable as Foldable-import Data.Hashable (Hashable(hash))-import qualified Data.List as L-import qualified Data.HashSet as S-import qualified Data.Set as Set-import Test.QuickCheck (Arbitrary)-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)---- Key type that generates more hash collisions.-newtype Key = K { unK :: Int }- deriving (Arbitrary, Eq, Ord, Show)--instance Hashable Key where- hash k = hash (unK k) `mod` 20----------------------------------------------------------------------------- * Properties----------------------------------------------------------------------------- ** Instances--pEq :: [Key] -> [Key] -> Bool-pEq xs = (unique xs ==) `eq` (S.fromList xs ==)--pNeq :: [Key] -> [Key] -> Bool-pNeq xs = (unique xs /=) `eq` (S.fromList xs /=)--pFoldable :: [Int] -> Bool-pFoldable = (L.sort . Foldable.foldr (:) []) `eq`- (L.sort . Foldable.foldr (:) [])----------------------------------------------------------------------------- ** Basic interface--pSize :: [Key] -> Bool-pSize = length `eq` S.size--pMember :: Key -> [Key] -> Bool-pMember k = L.elem k `eq` S.member k--pInsert :: Key -> [Key] -> Bool-pInsert a = insert a `eq` (toAscList . S.insert a)--pDelete :: Key -> [Key] -> Bool-pDelete a = delete a `eq` (toAscList . S.delete a)----------------------------------------------------------------------------- ** Combine--pUnion :: [Key] -> [Key] -> Bool-pUnion xs ys = L.sort (L.union as bs) ==- toAscList (S.union (S.fromList as) (S.fromList bs))- where- as = fromList xs- bs = fromList ys----------------------------------------------------------------------------- ** Transformations--pMap :: [Key] -> Bool-pMap = map f `eq` (toAscList . S.map f)- where f (K k) = K (k + 1)----------------------------------------------------------------------------- ** Folds--pFoldr :: [Int] -> Bool-pFoldr = (L.sort . L.foldr (:) []) `eq`- (L.sort . S.foldr (:) [])--pFoldl' :: Int -> [Int] -> Bool-pFoldl' z0 = L.foldl' (+) z0 `eq` S.foldl' (+) z0----------------------------------------------------------------------------- ** Conversions--pToList :: [Key] -> Bool-pToList = id `eq` toAscList----------------------------------------------------------------------------- * Test list--tests :: [Test]-tests =- [- -- Instances- testGroup "instances"- [ testProperty "==" pEq- , testProperty "/=" pNeq- , testProperty "Foldable" pFoldable- ]- -- 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'- ]- -- Conversions- , testGroup "conversions"- [ testProperty "toList" pToList- ]- ]----------------------------------------------------------------------------- * Model---- Invariant: the list is sorted in ascending order, by key.-type Model a = [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 ys) == f ys- where ys = fromList xs--insert :: Ord a => a -> Model a -> Model a-insert x [] = [x]-insert x (y:xs)- | x == y = x : xs- | x > y = y : insert x xs- | otherwise = x : y : xs--delete :: Ord a => a -> Model a -> Model a-delete _ [] = []-delete k ys@(y:xs)- | k == y = xs- | k > y = y : delete k xs- | otherwise = ys---- | Create a model from a list of key-value pairs. If the input--- contains multiple entries for the same key, the latter one is used.-fromList :: Ord a => [a] -> Model a-fromList = L.foldl' (\ m p -> insert p m) []----------------------------------------------------------------------------- * Test harness--main :: IO ()-main = defaultMain tests----------------------------------------------------------------------------- * Helpers--toAscList :: Ord a => S.HashSet a -> [a]-toAscList = L.sort . S.toList--unique :: (Eq a, Ord a) => [a] -> [a]-unique = Set.toList . Set.fromList
+ tests/Strictness.hs view
@@ -0,0 +1,175 @@+{-# 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 (Foldable (..))+import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap)+import Data.Maybe (fromMaybe, isJust)+import Test.ChasingBottoms.IsBottom+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 Prelude hiding (Foldable (..))++import qualified Data.HashMap.Strict as HM++instance (Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where+ arbitrary = HM.fromList <$> arbitrary+ shrink = fmap HM.fromList . shrink . HM.toList++------------------------------------------------------------------------+-- * Properties++------------------------------------------------------------------------+-- ** Strict module++pSingletonKeyStrict :: Int -> Bool+pSingletonKeyStrict v = isBottom $ HM.singleton (bottom :: Key) v++pSingletonValueStrict :: Key -> Bool+pSingletonValueStrict k = isBottom $ HM.singleton k (bottom :: Int)++pLookupDefaultKeyStrict :: Int -> HashMap Key Int -> Bool+pLookupDefaultKeyStrict def m = isBottom $ HM.lookupDefault def bottom m++pFindWithDefaultKeyStrict :: Int -> HashMap Key Int -> Bool+pFindWithDefaultKeyStrict def m = isBottom $ HM.findWithDefault def bottom m++pAdjustKeyStrict :: (Int -> Int) -> HashMap Key Int -> Bool+pAdjustKeyStrict f m = isBottom $ HM.adjust f bottom m++pAdjustValueStrict :: Key -> HashMap Key Int -> Bool+pAdjustValueStrict k m+ | k `HM.member` m = isBottom $ HM.adjust (const bottom) k m+ | otherwise = case HM.keys m of+ [] -> True+ (k':_) -> isBottom $ HM.adjust (const bottom) k' m++pInsertKeyStrict :: Int -> HashMap Key Int -> Bool+pInsertKeyStrict v m = isBottom $ HM.insert bottom v m++pInsertValueStrict :: Key -> HashMap Key Int -> Bool+pInsertValueStrict k m = isBottom $ HM.insert k bottom m++pInsertWithKeyStrict :: (Int -> Int -> Int) -> Int -> HashMap Key Int -> Bool+pInsertWithKeyStrict f v m = isBottom $ HM.insertWith f bottom v m++pInsertWithValueStrict :: (Int -> Int -> Int) -> Key -> Int -> HashMap Key Int+ -> Bool+pInsertWithValueStrict f k v m+ | HM.member k m = isBottom $ HM.insertWith (const2 bottom) k v m+ | otherwise = isBottom $ HM.insertWith f k bottom m++pFromListKeyStrict :: Bool+pFromListKeyStrict = isBottom $ HM.fromList [(undefined :: Key, 1 :: Int)]++pFromListValueStrict :: Key -> Bool+pFromListValueStrict k = isBottom $ HM.fromList [(k, undefined)]++pFromListWithKeyStrict :: (Int -> Int -> Int) -> Bool+pFromListWithKeyStrict f =+ isBottom $ HM.fromListWith f [(undefined :: Key, 1 :: Int)]++-- The strictness properties of 'fromListWith' are not entirely+-- trivial.+-- fromListWith f kvs is strict in the first value seen for each+-- key, but potentially lazy in the rest: the combining function+-- could be lazy in the "new" value. fromListWith must, however,+-- be strict in whatever value is actually inserted into the map.+-- Getting all these properties specified efficiently seems tricky.+-- Since it's not hard, we verify that the converted HashMap has+-- no unforced values. Rather than trying to go into detail for the+-- rest, this test compares the strictness behavior of fromListWith+-- to that of insertWith. The latter should be easier to specify+-- and (if we choose to do so) test thoroughly.+--+-- We'll fake up a representation of things that are possibly+-- bottom by using Nothing to represent bottom. The combining+-- (partial) function is represented by a "lazy total" function+-- Maybe a -> Maybe a -> Maybe a, along with a function determining+-- whether the result should be non-bottom, Maybe a -> Maybe a -> Bool,+-- indicating how the combining function should behave if neither+-- 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 continuous.+pFromListWithValueResultStrict :: [(Key, Maybe A)]+ -> Fun (Maybe A, Maybe A) A+ -> Fun (Maybe A, Maybe A) Bool+ -> Property+pFromListWithValueResultStrict lst comb_lazy calc_good_raw+ = all (all isJust) recovered .&&. (recovered === recover (fmap recover fake_map))+ where+ recovered :: Maybe (HashMap Key (Maybe A))+ recovered = recover (fmap recover real_map)+ -- What we get out of the conversion using insertWith+ fake_map = foldl' (\m (k,v) -> HM.insertWith real_comb k v m) HM.empty real_list++ -- A continuous version of calc_good_raw+ calc_good Nothing Nothing = cgr Nothing Nothing+ calc_good Nothing y@(Just _) = cgr Nothing Nothing || cgr Nothing y+ calc_good x@(Just _) Nothing = cgr Nothing Nothing || cgr x Nothing+ calc_good x y = cgr Nothing Nothing || cgr Nothing y || cgr x Nothing || cgr x y+ cgr = curry $ apply calc_good_raw++ -- The Maybe A -> Maybe A -> Maybe A that we're after, representing a+ -- potentially less total function than comb_lazy+ comb x y = apply comb_lazy (x, y) <$ guard (calc_good x y)++ -- What we get out of the conversion using fromListWith+ real_map = HM.fromListWith real_comb real_list++ -- A list that may have actual bottom values in it.+ real_list = map (second (fromMaybe bottom)) lst++ -- A genuinely partial function mirroring comb+ real_comb x y = fromMaybe bottom $ comb (recover x) (recover y)++ recover :: a -> Maybe a+ recover a = a <$ guard (not $ isBottom a)++------------------------------------------------------------------------+-- * Test list++tests :: TestTree+tests = testGroup "Strictness"+ [+ -- Basic interface+ testGroup "HashMap.Strict"+ [ testProperty "singleton is key-strict" pSingletonKeyStrict+ , testProperty "singleton is value-strict" pSingletonValueStrict+ , testProperty "member is key-strict" $ keyStrict HM.member+ , testProperty "lookup is key-strict" $ keyStrict HM.lookup+ , testProperty "lookupDefault is key-strict" pLookupDefaultKeyStrict+ , testProperty "findWithDefault is key-strict" pFindWithDefaultKeyStrict+ , testProperty "! is key-strict" $ keyStrict (flip (HM.!))+ , testProperty "delete is key-strict" $ keyStrict HM.delete+ , testProperty "adjust is key-strict" pAdjustKeyStrict+ , testProperty "adjust is value-strict" pAdjustValueStrict+ , testProperty "insert is key-strict" pInsertKeyStrict+ , testProperty "insert is value-strict" pInsertValueStrict+ , testProperty "insertWith is key-strict" pInsertWithKeyStrict+ , testProperty "insertWith is value-strict" pInsertWithValueStrict+ , testProperty "fromList is key-strict" pFromListKeyStrict+ , testProperty "fromList is value-strict" pFromListValueStrict+ , testProperty "fromListWith is key-strict" pFromListWithKeyStrict+ , testProperty "fromListWith is value-strict" pFromListWithValueResultStrict+ ]+ ]++------------------------------------------------------------------------+-- * Utilities++keyStrict :: (Key -> HashMap Key Int -> a) -> HashMap Key Int -> Bool+keyStrict f m = isBottom $ f bottom m++const2 :: a -> b -> c -> a+const2 x _ _ = x
+ tests/Util/Key.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MagicHash #-}+{-# 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.Exts (Int (..), bitReverse#, int2Word#, word2Int#)+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)+ -- Hashes where the lowest `maxChildren` bits are set are interesting+ -- edge cases. See #491.+ , (1, QC.elements [-1, 0xFF, 0xFFF])+ ]+ i <- QC.frequency gens+ transform <- QC.elements [id, moreCollisions, bitReverse]+ pure (transform i)++-- | Mask out most bits to produce more collisions+moreCollisions :: Int -> Int+moreCollisions w = fromIntegral (w .&. moreCollisionsMask)++-- | Bitmask for @moreCollisions@+moreCollisionsMask :: Int+moreCollisionsMask = sum [bit n | n <- [0, 3, 8, 14, 61]]++-- | Reverse order of bits, in order to generate variation in the+-- high bits, resulting in HashMap trees of greater height.+bitReverse :: Int -> Int+bitReverse (I# i) = I# (word2Int# (bitReverse# (int2Word# i)))++keyToInt :: Key -> Int+keyToInt (K h x) = h * fromEnum x++incKey :: Key -> Key+incKey (K h x) = K (h + 1) x++-- | 4 colliding keys at a given hash.+collisionAtHash :: Int -> (Key, Key, Key, Key)+collisionAtHash h = (K h A, K h B, K h C, K h D)
unordered-containers.cabal view
@@ -1,5 +1,5 @@ name: unordered-containers-version: 0.1.4.6+version: 0.2.21 synopsis: Efficient hashing-based container types description: Efficient hashing-based container types. The containers have been@@ -8,82 +8,151 @@ . The declared cost of each operation is either worst-case or amortized, but remains valid even if structures are shared.+ .+ /Security/+ .+ This package currently provides no defenses against hash collision attacks+ such as HashDoS.+ Users who need to store keys derived from untrusted input are advised to use+ @Data.Map@ or @Data.Set@ from the @containers@ package instead. license: BSD3 license-file: LICENSE-author: Johan Tibell <johan.tibell@gmail.com>-maintainer: johan.tibell@gmail.com-bug-reports: https://github.com/tibbe/unordered-containers/issues-copyright: (c) Daan Leijen 2002- (c) Andriy Palamarchuk 2008- (c) 2010-2011 Johan Tibell+author: Johan Tibell+maintainer: simon.jakobi@gmail.com, David.Feuer@gmail.com+Homepage: https://github.com/haskell-unordered-containers/unordered-containers+bug-reports: https://github.com/haskell-unordered-containers/unordered-containers/issues+copyright: 2010-2014 Johan Tibell+ 2010 Edward Z. Yang category: Data build-type: Simple-cabal-version: >=1.8--- The test files shouldn't have to go here, but the source files for--- the test-suite stanzas don't get picked up by `cabal sdist`.-Extra-source-files:- tests/MapProperties.hs- tests/SetProperties.hs- benchmarks/Benchmarks.hs- benchmarks/Makefile- benchmarks/Util/*.hs+cabal-version: >=1.10+extra-source-files: CHANGES.md +tested-with:+ GHC ==9.12.2+ || ==9.10.2+ || ==9.8.4+ || ==9.6.7+ || ==9.4.8+ || ==9.2.8+ || ==9.0.2+ || ==8.10.7++flag debug+ description: Enable debug support+ default: False+ library exposed-modules:+ Data.HashMap.Internal+ Data.HashMap.Internal.Array+ Data.HashMap.Internal.Debug+ Data.HashMap.Internal.List+ Data.HashMap.Internal.Strict Data.HashMap.Lazy Data.HashMap.Strict Data.HashSet+ Data.HashSet.Internal build-depends:- base >= 4 && < 4.6,- deepseq >= 1.1 && < 1.4,- hashable >= 1.0.1.1 && < 1.2+ base >= 4.14 && < 5,+ deepseq >= 1.4.3,+ hashable >= 1.4 && < 1.6+ if impl(ghc)+ build-depends:+ template-haskell >= 2.16 && < 2.24 - other-modules:- Data.FullList.Lazy- Data.FullList.Strict- Data.HashMap.Common- Data.HashMap.Lazy.Internal- Data.HashMap.Strict.Internal+ default-language: Haskell2010 - ghc-options: -Wall -O2- if impl(ghc >= 6.8)- ghc-options: -fwarn-tabs- if impl(ghc > 6.10)- ghc-options: -fregs-graph+ other-extensions:+ RoleAnnotations,+ UnboxedTuples,+ ScopedTypeVariables,+ MagicHash,+ BangPatterns -test-suite map-properties+ ghc-options: -Wall -O2 -fwarn-tabs -ferror-spans++ if flag(debug)+ cpp-options: -DASSERTS++test-suite unordered-containers-tests hs-source-dirs: tests- main-is: MapProperties.hs+ main-is: Main.hs type: exitcode-stdio-1.0+ other-modules:+ Regressions+ Properties+ Properties.HashMapLazy+ Properties.HashMapStrict+ Properties.HashSet+ Properties.List+ Strictness+ Util.Key build-depends:- base >= 4,- hashable >= 1.0.1.1,+ base,+ ChasingBottoms,+ containers >= 0.5.8,+ hashable,+ HUnit, QuickCheck >= 2.4.0.1,- test-framework >= 0.3.3,- test-framework-quickcheck2 >= 0.2.9,+ nothunks >= 0.1.3,+ random,+ tasty >= 1.4.0.3,+ tasty-hunit >= 0.10.0.3,+ tasty-quickcheck >= 0.10.1.2, unordered-containers - ghc-options: -Wall-+ default-language: Haskell2010+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ cpp-options: -DASSERTS -test-suite set-properties- hs-source-dirs: tests- main-is: SetProperties.hs+benchmark package-comparisons+ hs-source-dirs: benchmarks+ main-is: Benchmarks.hs type: exitcode-stdio-1.0 + other-modules:+ Util.ByteString+ Util.String+ Util.Int+ build-depends:- base >= 4,+ base >= 4.8.0,+ bytestring >= 0.10.0.0, containers,- hashable >= 1.0.1.1,- QuickCheck >= 2.4.0.1,- test-framework >= 0.3.3,- test-framework-quickcheck2 >= 0.2.9,+ deepseq,+ hashable,+ hashmap,+ random,+ tasty-bench >= 0.3.1, unordered-containers - ghc-options: -Wall+ default-language: Haskell2010+ ghc-options: -Wall -O2 -rtsopts "-with-rtsopts=-A32m" -fproc-alignment=64+ -- cpp-options: -DBENCH_containers_Map -DBENCH_containers_IntMap -DBENCH_hashmap_Map +benchmark fine-grained+ hs-source-dirs: benchmarks+ main-is: FineGrained.hs+ type: exitcode-stdio-1.0++ other-modules:+ Key.Bytes++ build-depends:+ base,+ bytestring >= 0.11.3,+ deepseq,+ hashable,+ random,+ tasty-bench,+ unordered-containers++ default-language: Haskell2010+ ghc-options: -Wall -O2 -rtsopts "-with-rtsopts=-A64m" -fproc-alignment=64+ source-repository head type: git- location: https://github.com/tibbe/unordered-containers.git+ location: https://github.com/haskell-unordered-containers/unordered-containers.git