diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,177 @@ +## [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. diff --git a/Data/HashMap/Internal.hs b/Data/HashMap/Internal.hs --- a/Data/HashMap/Internal.hs +++ b/Data/HashMap/Internal.hs @@ -1,2305 +1,2994 @@ -{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE LambdaCase #-} -#if __GLASGOW_HASKELL__ >= 802 -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE UnboxedSums #-} -#endif -{-# 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. - -module Data.HashMap.Internal - ( - HashMap(..) - , Leaf(..) - - -- * Construction - , empty - , singleton - - -- * Basic interface - , null - , size - , member - , lookup - , (!?) - , findWithDefault - , lookupDefault - , (!) - , insert - , insertWith - , unsafeInsert - , delete - , adjust - , update - , alter - , alterF - , isSubmapOf - , isSubmapOfBy - - -- * Combine - -- ** Union - , union - , unionWith - , unionWithKey - , unions - - -- ** Compose - , compose - - -- * Transformations - , map - , mapWithKey - , traverseWithKey - - -- * Difference and intersection - , difference - , differenceWith - , intersection - , intersectionWith - , intersectionWithKey - - -- * 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 - , bitmapIndexedOrFull - , collision - , hash - , mask - , index - , bitsPerSubkey - , fullNodeMask - , sparseIndex - , two - , unionArrayBy - , update16 - , update16M - , update16With' - , updateOrConcatWith - , updateOrConcatWithKey - , filterMapAux - , equalKeys - , equalKeys1 - , lookupRecordCollision - , LookupRes(..) - , insert' - , delete' - , lookup' - , insertNewKey - , insertKeyExists - , deleteKeyExists - , insertModifying - , ptrEq - , adjust# - ) where - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative ((<$>), Applicative(pure)) -import Data.Monoid (Monoid(mempty, mappend)) -import Data.Traversable (Traversable(..)) -import Data.Word (Word) -#endif -#if __GLASGOW_HASKELL__ >= 711 -import Data.Semigroup (Semigroup((<>))) -#endif -import Control.DeepSeq (NFData(rnf)) -import Control.Monad.ST (ST) -import Data.Bits ((.&.), (.|.), complement, popCount, unsafeShiftL, unsafeShiftR) -import Data.Data hiding (Typeable) -import qualified Data.Foldable as Foldable -#if MIN_VERSION_base(4,10,0) -import Data.Bifoldable -#endif -import qualified Data.List as L -import GHC.Exts ((==#), build, reallyUnsafePtrEquality#, inline) -import Prelude hiding (filter, foldl, foldr, lookup, map, null, pred) -import Text.Read hiding (step) - -import qualified Data.HashMap.Internal.Array as A -import qualified Data.Hashable as H -import Data.Hashable (Hashable) -import Data.HashMap.Internal.Unsafe (runST) -import Data.HashMap.Internal.List (isPermutationBy, unorderedCompare) -import Data.Typeable (Typeable) - -import GHC.Exts (isTrue#) -import qualified GHC.Exts as Exts - -#if MIN_VERSION_base(4,9,0) -import Data.Functor.Classes -import GHC.Stack -#endif - -#if MIN_VERSION_hashable(1,2,5) -import qualified Data.Hashable.Lifted as H -#endif - -#if __GLASGOW_HASKELL__ >= 802 -import GHC.Exts (TYPE, Int (..), Int#) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity (..)) -#endif -import Control.Applicative (Const (..)) -import Data.Coerce (coerce) - --- | A set of values. A set cannot contain duplicate values. ------------------------------------------------------------------------- - --- | Convenience function. Compute a hash value for the given value. -hash :: H.Hashable a => a -> Hash -hash = fromIntegral . H.hash - -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 - --- Invariant: The length of the 1st argument to 'Full' is --- 2^bitsPerSubkey - --- | A map from keys to values. A map cannot contain duplicate keys; --- each key can map to at most one value. -data HashMap k v - = Empty - | BitmapIndexed !Bitmap !(A.Array (HashMap k v)) - | Leaf !Hash !(Leaf k v) - | Full !(A.Array (HashMap k v)) - | Collision !Hash !(A.Array (Leaf k v)) - deriving (Typeable) - -type role HashMap nominal representational - -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 - -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' #-} -#if MIN_VERSION_base(4,8,0) - null = null - {-# INLINE null #-} - length = size - {-# INLINE length #-} -#endif - -#if MIN_VERSION_base(4,10,0) --- | @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 #-} -#endif - -#if __GLASGOW_HASKELL__ >= 711 --- | '<>' = '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 (Eq k, Hashable k) => Semigroup (HashMap k v) where - (<>) = union - {-# INLINE (<>) #-} -#endif - --- | '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 (Eq k, Hashable k) => Monoid (HashMap k v) where - mempty = empty - {-# INLINE mempty #-} -#if __GLASGOW_HASKELL__ >= 711 - mappend = (<>) -#else - mappend = union -#endif - {-# INLINE mappend #-} - -instance (Data k, Data v, Eq k, Hashable k) => Data (HashMap k v) where - gfoldl f z m = z fromList `f` toList m - toConstr _ = fromListConstr - gunfold k z c = case constrIndex c of - 1 -> k (z fromList) - _ -> error "gunfold" - dataTypeOf _ = hashMapDataType - dataCast2 f = gcast2 f - -fromListConstr :: Constr -fromListConstr = mkConstr hashMapDataType "fromList" [] Prefix - -hashMapDataType :: DataType -hashMapDataType = mkDataType "Data.HashMap.Internal.HashMap" [fromListConstr] - -type Hash = Word -type Bitmap = Word -type Shift = Int - -#if MIN_VERSION_base(4,9,0) -instance Show2 HashMap where - liftShowsPrec2 spk slk spv slv d m = - 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 (Eq k, Hashable k, Read k) => Read1 (HashMap k) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList - where - rp' = liftReadsPrec rp rl - rl' = liftReadList rp rl -#endif - -instance (Eq k, Hashable k, Read k, Read e) => Read (HashMap k e) where - readPrec = parens $ prec 10 $ do - Ident "fromList" <- lexP - xs <- readPrec - return (fromList xs) - - 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 #-} - -#if MIN_VERSION_base(4,9,0) -instance Eq2 HashMap where - liftEq2 = equal2 - -instance Eq k => Eq1 (HashMap k) where - liftEq = equal1 -#endif - --- | Note that, in the presence of hash collisions, equal @HashMap@s may --- behave differently, i.e. substitutivity 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 substitutivity can be observed with any function --- that depends on the key ordering, such as folds and traversals. -instance (Eq k, Eq v) => Eq (HashMap k v) where - (==) = equal1 (==) - --- We rely on there being no Empty constructors in the tree! --- This ensures that two equal HashMaps will have the same --- shape, modulo the order of entries in Collisions. -equal1 :: Eq k - => (v -> v' -> Bool) - -> HashMap k v -> HashMap k v' -> Bool -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 (toList' t1 []) (toList' t2 []) - where - -- If the two trees are the same, then their lists of 'Leaf's and - -- 'Collision's read from left to right should be the same (modulo the - -- order of elements in 'Collision'). - - go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) - | k1 == k2 && - leafEq l1 l2 - = go tl1 tl2 - go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2) - | k1 == k2 && - 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' - -#if MIN_VERSION_base(4,9,0) -instance Ord2 HashMap where - liftCompare2 = cmp - -instance Ord k => Ord1 (HashMap k) where - liftCompare = cmp compare -#endif - --- | 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 (toList' t1 []) (toList' t2 []) - where - go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) - = compare k1 k2 `mappend` - leafCompare l1 l2 `mappend` - go tl1 tl2 - go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2) - = compare k1 k2 `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, toList' includes non Leaf / Collision" - - leafCompare (L k v) (L k' v') = cmpk k k' `mappend` cmpv v v' - --- Same as 'equal' but doesn't compare the values. -equalKeys1 :: (k -> k' -> Bool) -> HashMap k v -> HashMap k' v' -> Bool -equalKeys1 eq t1 t2 = go (toList' t1 []) (toList' t2 []) - where - go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) - | k1 == k2 && leafEq l1 l2 - = go tl1 tl2 - go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2) - | k1 == k2 && A.length ary1 == A.length ary2 && - 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 - -#if MIN_VERSION_hashable(1,2,5) -instance H.Hashable2 HashMap where - liftHashWithSalt2 hk hv salt hm = go salt (toList' 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 - = L.foldl' H.hashWithSalt s . arrayHashesSorted s - - -- arrayHashesSorted :: Int -> A.Array (Leaf k v) -> [Int] - arrayHashesSorted s = L.sort . L.map (hashLeafWithSalt s) . A.toList - -instance (Hashable k) => H.Hashable1 (HashMap k) where - liftHashWithSalt = H.liftHashWithSalt2 H.hashWithSalt -#endif - -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 - = L.foldl' H.hashWithSalt s . arrayHashesSorted s - - arrayHashesSorted :: Int -> A.Array (Leaf k v) -> [Int] - arrayHashesSorted s = L.sort . L.map (hashLeafWithSalt s) . A.toList - - -- Helper to get 'Leaf's and 'Collision's as a list. -toList' :: HashMap k v -> [HashMap k v] -> [HashMap k v] -toList' (BitmapIndexed _ ary) a = A.foldr toList' a ary -toList' (Full ary) a = A.foldr toList' a ary -toList' l@(Leaf _ _) a = l : a -toList' c@(Collision _ _) a = c : a -toList' Empty a = a - --- Helper function to detect 'Leaf's and 'Collision's. -isLeafOrCollision :: HashMap k v -> Bool -isLeafOrCollision (Leaf _ _) = True -isLeafOrCollision (Collision _ _) = True -isLeafOrCollision _ = False - ------------------------------------------------------------------------- --- * Construction - --- | /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 :: (Eq k, 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 :: (Eq k, Hashable k) => k -> HashMap k v -> Maybe v -#if __GLASGOW_HASKELL__ >= 802 --- 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# :: (Eq k, Hashable k) => k -> HashMap k v -> (# (# #) | v #) -lookup# k m = lookupCont (\_ -> (# (# #) | #)) (\v _i -> (# | v #)) (hash k) k 0 m -{-# INLINABLE lookup# #-} - -#else - -lookup k m = lookupCont (\_ -> Nothing) (\v _i -> Just v) (hash k) k 0 m -{-# INLINABLE lookup #-} -#endif - --- | 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 -#if __GLASGOW_HASKELL__ >= 802 --- 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' #-} -#else -lookup' h k m = lookupCont (\_ -> Nothing) (\v _i -> Just v) h k 0 m -{-# INLINABLE lookup' #-} -#endif - --- The result of a lookup, keeping track of if a hash collision occured. --- If a collision did not occur then it will have the Int value (-1). -data LookupRes a = Absent | Present a !Int - --- 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 -#if __GLASGOW_HASKELL__ >= 802 -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# #-} - -#else /* GHC < 8.2 so there are no unboxed sums */ - -lookupRecordCollision h k m = lookupCont (\_ -> Absent) Present h k 0 m -{-# INLINABLE lookupRecordCollision #-} -#endif - --- 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. --- --- The @Int@ argument is the offset of the subkey in the hash. When looking up --- keys at the top-level of a hashmap, the offset should be 0. When looking up --- keys at level @n@ of a hashmap, the offset should be @n * bitsPerSubkey@. -lookupCont :: -#if __GLASGOW_HASKELL__ >= 802 - 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 - -> Int -- The offset of the subkey in the hash. - -> HashMap k v -> r -lookupCont absent present !h0 !k0 !s0 !m0 = go h0 k0 s0 m0 - where - go :: Eq k => Hash -> k -> Int -> HashMap k v -> r - go !_ !_ !_ Empty = absent (# #) - go h k _ (Leaf hx (L kx x)) - | h == hx && k == kx = present x (-1) - | otherwise = absent (# #) - go h k s (BitmapIndexed b v) - | b .&. m == 0 = absent (# #) - | otherwise = - go h k (s+bitsPerSubkey) (A.index v (sparseIndex b m)) - where m = mask h s - go h k s (Full v) = - go h k (s+bitsPerSubkey) (A.index v (index h s)) - go h k _ (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 -(!?) :: (Eq k, 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 :: (Eq k, 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 :: (Eq k, Hashable k) - => v -- ^ Default value to return. - -> k -> HashMap k v -> v -lookupDefault def k t = findWithDefault def k t -{-# 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. -#if MIN_VERSION_base(4,9,0) -(!) :: (Eq k, Hashable k, HasCallStack) => HashMap k v -> k -> v -#else -(!) :: (Eq k, Hashable k) => HashMap k v -> k -> v -#endif -(!) m k = case lookup k m of - Just v -> v - Nothing -> error "Data.HashMap.Internal.(!): key not found" -{-# INLINABLE (!) #-} - -infixl 9 ! - --- | 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 -bitmapIndexedOrFull b ary - | b == fullNodeMask = 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 :: (Eq k, 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 = - let !st = A.index ary i - !st' = go h k x (s+bitsPerSubkey) 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) = - let !st = A.index ary i - !st' = go h k x (s+bitsPerSubkey) st - in if st' `ptrEq` st - then t - else Full (update16 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 = - let !st = A.index ary i - !st' = go h k x (s+bitsPerSubkey) st - in BitmapIndexed b (A.update ary i st') - where m = mask h s - i = sparseIndex b m - go h k x s (Full ary) = - let !st = A.index ary i - !st' = go h k x (s+bitsPerSubkey) st - in Full (update16 ary i st') - where i = index h s - go h k x s t@(Collision hy v) - | h == hy = Collision h (snocNewLeaf (L k x) v) - | otherwise = - go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) - where - snocNewLeaf :: Leaf k v -> A.Array (Leaf k v) -> A.Array (Leaf k v) - snocNewLeaf leaf ary = A.run $ do - let n = A.length ary - mary <- A.new_ (n + 1) - A.copy ary 0 mary 0 n - A.write mary n leaf - return mary -{-# 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). --- --- We can skip the key equality check on a Leaf because we know the leaf must be --- for this key. -insertKeyExists :: Int -> Hash -> k -> v -> HashMap k v -> HashMap k v -insertKeyExists !collPos0 !h0 !k0 x0 !m0 = go collPos0 h0 k0 x0 0 m0 - where - go !_collPos !h !k x !_s (Leaf _hy _kx) - = Leaf h (L k x) - go collPos h k x s (BitmapIndexed b ary) - | b .&. m == 0 = - let !ary' = A.insert ary i $ Leaf h (L k x) - in bitmapIndexedOrFull (b .|. m) ary' - | otherwise = - let !st = A.index ary i - !st' = go collPos h k x (s+bitsPerSubkey) st - in BitmapIndexed b (A.update ary i st') - where m = mask h s - i = sparseIndex b m - go collPos h k x s (Full ary) = - let !st = A.index ary i - !st' = go collPos h k x (s+bitsPerSubkey) st - in Full (update16 ary i st') - where i = index h s - go collPos h k x _s (Collision _hy 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 :: (Eq k, 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 !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 (s+bitsPerSubkey) st - A.unsafeUpdateM ary i st' - return t - where m = mask h s - i = sparseIndex b m - go h k x s t@(Full ary) = do - st <- A.indexM ary i - st' <- go h k x (s+bitsPerSubkey) st - 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 (s+bitsPerSubkey) 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 - idx2 | index h1 s < index h2 s = 1 - | otherwise = 0 -{-# 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 :: (Eq k, 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 :: (Eq k, 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 = - let !st = A.index ary i - !st' = go h k (s+bitsPerSubkey) 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) = - let !st = A.index ary i - !st' = go h k (s+bitsPerSubkey) st - ary' = update16 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 - | i >= n = A.run $ do - -- Not found, append to the end. - mary <- A.new_ (n + 1) - A.copy ary 0 mary 0 n - A.write mary n (L k x) - return mary - | 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. (Eq k, 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. (Eq k, 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 return $! Leaf h (L k (f k x y)) - 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 (s+bitsPerSubkey) st - A.unsafeUpdateM ary i st' - return t - where m = mask h s - i = sparseIndex b m - go h k x s t@(Full ary) = do - st <- A.indexM ary i - st' <- go h k x (s+bitsPerSubkey) st - 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 (\key a b -> (# f key a b #) ) 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 :: (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v -delete k m = delete' (hash k) k m -{-# INLINABLE delete #-} - -delete' :: Eq k => Hash -> k -> HashMap k v -> HashMap k v -delete' h0 k0 m0 = go h0 k0 0 m0 - where - go !_ !_ !_ Empty = Empty - go h k _ t@(Leaf hy (L ky _)) - | hy == h && ky == k = Empty - | otherwise = t - go h k s t@(BitmapIndexed b ary) - | b .&. m == 0 = t - | otherwise = - let !st = A.index ary i - !st' = go h k (s+bitsPerSubkey) st - in if st' `ptrEq` st - then t - else case st' of - Empty | A.length ary == 1 -> Empty - | A.length ary == 2 -> - case (i, A.index ary 0, A.index ary 1) of - (0, _, l) | isLeafOrCollision l -> l - (1, l, _) | isLeafOrCollision l -> l - _ -> bIndexed - | otherwise -> bIndexed - where - bIndexed = BitmapIndexed (b .&. complement m) (A.delete ary i) - l | isLeafOrCollision l && A.length ary == 1 -> l - _ -> BitmapIndexed b (A.update ary i st') - where m = mask h s - i = sparseIndex b m - go h k s t@(Full ary) = - let !st = A.index ary i - !st' = go h k (s+bitsPerSubkey) st - in if st' `ptrEq` st - then t - else case st' of - Empty -> - let ary' = A.delete ary i - bm = fullNodeMask .&. complement (1 `unsafeShiftL` i) - in BitmapIndexed bm ary' - _ -> Full (A.update ary i st') - where i = index h s - go h k _ t@(Collision hy v) - | h == hy = case indexOf k v of - Just i - | A.length v == 2 -> - if i == 0 - then Leaf h (A.index v 1) - else Leaf h (A.index v 0) - | otherwise -> Collision h (A.delete v i) - Nothing -> t - | otherwise = t -{-# INLINABLE delete' #-} - --- | 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. --- --- We can skip: --- - the key equality check on the leaf, if we reach a leaf it must be the key -deleteKeyExists :: Int -> Hash -> k -> HashMap k v -> HashMap k v -deleteKeyExists !collPos0 !h0 !k0 !m0 = go collPos0 h0 k0 0 m0 - where - go :: Int -> Hash -> k -> Int -> HashMap k v -> HashMap k v - go !_collPos !_h !_k !_s (Leaf _ _) = Empty - go collPos h k s (BitmapIndexed b ary) = - let !st = A.index ary i - !st' = go collPos h k (s+bitsPerSubkey) st - in case st' of - Empty | A.length ary == 1 -> Empty - | A.length ary == 2 -> - case (i, A.index ary 0, A.index ary 1) of - (0, _, l) | isLeafOrCollision l -> l - (1, l, _) | isLeafOrCollision l -> l - _ -> bIndexed - | otherwise -> bIndexed - where - bIndexed = BitmapIndexed (b .&. complement m) (A.delete ary i) - l | isLeafOrCollision l && A.length ary == 1 -> l - _ -> BitmapIndexed b (A.update ary i st') - where m = mask h s - i = sparseIndex b m - go collPos h k s (Full ary) = - let !st = A.index ary i - !st' = go collPos h k (s+bitsPerSubkey) st - in case st' of - Empty -> - let ary' = A.delete ary i - bm = fullNodeMask .&. complement (1 `unsafeShiftL` i) - in BitmapIndexed bm ary' - _ -> Full (A.update ary i st') - where i = index h s - go collPos h _ _ (Collision _hy v) - | A.length v == 2 - = if collPos == 0 - then Leaf h (A.index v 1) - else Leaf h (A.index v 0) - | otherwise = Collision h (A.delete v collPos) - go !_ !_ !_ !_ Empty = Empty -- error "Internal error: deleteKeyExists empty" -{-# 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 :: (Eq k, 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# :: (Eq k, 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 = let !st = A.index ary i - !st' = go h k (s+bitsPerSubkey) 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) = - let i = index h s - !st = A.index ary i - !st' = go h k (s+bitsPerSubkey) st - ary' = update16 ary i $! st' - in if ptrEq st st' - then t - else Full ary' - 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 :: (Eq k, 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 :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v --- TODO(m-renaud): Consider using specialized insert and delete for alter. -alter f k m = - case f (lookup k m) of - Nothing -> delete k m - Just v -> insert k v m -{-# 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 --- . --- --- @since 0.2.10 -alterF :: (Functor f, Eq k, 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) $ \fres -> - case fres of - 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 #-} - -#if MIN_VERSION_base(4,8,0) --- 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, Eq k, 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, Eq k, 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 - 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 = case lookupRes of - Absent -> Nothing - Present v _ -> Just v -{-# INLINABLE alterFEager #-} -#endif - --- | /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 :: (Eq k, Hashable k, Eq v) => HashMap k v -> HashMap k v -> Bool -isSubmapOf = (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 :: (Eq k, 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 = - go (s+bitsPerSubkey) t1 (A.index ls2 (sparseIndex b m)) - where m = mask h1 s - - -- Similar to the previous case we need to traverse l2 at the index for the hash h1. - go s t1@(Collision h1 _) (Full ls2) = - go (s+bitsPerSubkey) t1 (A.index ls2 (index h1 s)) - - -- In cases where the first and second map are BitmapIndexed or Full, - -- traverse down the tree at the appropriate indices. - go s (BitmapIndexed b1 ls1) (BitmapIndexed b2 ls2) = - submapBitmapIndexed (go (s+bitsPerSubkey)) b1 ls1 b2 ls2 - go s (BitmapIndexed b1 ls1) (Full ls2) = - submapBitmapIndexed (go (s+bitsPerSubkey)) b1 ls1 fullNodeMask ls2 - go s (Full ls1) (Full ls2) = - submapBitmapIndexed (go (s+bitsPerSubkey)) fullNodeMask ls1 fullNodeMask 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 - | 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 = comp (A.index ary1 i) (A.index ary2 j) && - 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, Hashable k) => HashMap k v -> HashMap k v -> HashMap k v -union = unionWith const -{-# INLINABLE union #-} - --- | /O(n+m)/ The union of two maps. If a key occurs in both maps, --- the provided function (first argument) will be used to compute the --- result. -unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v - -> HashMap k v -unionWith f = unionWithKey (const f) -{-# INLINE unionWith #-} - --- | /O(n+m)/ The union of two maps. If a key occurs in both maps, --- the provided function (first argument) will be used to compute the --- result. -unionWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> HashMap k v -> HashMap k v - -> 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 f 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 (s+bitsPerSubkey)) b1 b2 ary1 ary2 - in bitmapIndexedOrFull b' ary' - go s (BitmapIndexed b1 ary1) (Full ary2) = - let ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2 - in Full ary' - go s (Full ary1) (BitmapIndexed b2 ary2) = - let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2 - in Full ary' - go s (Full ary1) (Full ary2) = - let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask - 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 (s+bitsPerSubkey) 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 (s+bitsPerSubkey) 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' = update16With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 - in Full ary' - go s t1 (Full ary2) = - let h1 = leafHashCode t1 - i = index h1 s - ary' = update16With' ary2 i $ \st2 -> go (s+bitsPerSubkey) 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 $! go (s+bitsPerSubkey) 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 -unionArrayBy f b1 b2 ary1 ary2 = A.run $ do - let b' = b1 .|. b2 - mary <- A.new_ (popCount b') - -- iterate over nonzero bits of b1 .|. b2 - -- it would be nice if we could shift m by more than 1 each time - let ba = b1 .&. b2 - go !i !i1 !i2 !m - | m > b' = return () - | b' .&. m == 0 = go i i1 i2 (m `unsafeShiftL` 1) - | ba .&. m /= 0 = 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) (m `unsafeShiftL` 1) - | b1 .&. m /= 0 = do - A.write mary i =<< A.indexM ary1 i1 - go (i+1) (i1+1) (i2 ) (m `unsafeShiftL` 1) - | otherwise = do - A.write mary i =<< A.indexM ary2 i2 - go (i+1) (i1 ) (i2+1) (m `unsafeShiftL` 1) - go 0 0 0 (b' .&. negate b') -- XXX: b' must be non-zero - 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, Hashable k) => [HashMap k v] -> HashMap k v -unions = L.foldl' union empty -{-# INLINE unions #-} - - ------------------------------------------------------------------------- --- * Compose - --- | Relate the keys of one map to the values of --- the other, by using the values of the former as keys for lookups --- in the latter. --- --- 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 UNRELEASED -compose :: (Eq b, 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 #-} - --- TODO: We should be able to use mutation to create the new --- 'HashMap'. - --- | /O(n)/ Perform an 'Applicative' action for each key-value pair --- in a 'HashMap' and produce a 'HashMap' of all the results. --- --- 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 #-} - ------------------------------------------------------------------------- --- * Difference and intersection - --- | /O(n*log m)/ 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 -{-# INLINABLE difference #-} - --- | /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 :: (Eq k, Hashable k) => (v -> w -> Maybe v) -> HashMap k v -> HashMap k w -> HashMap k v -differenceWith f a b = foldlWithKey' go empty a - where - go m k v = case lookup k b of - Nothing -> insert k v m - Just w -> maybe m (\y -> insert k y m) (f v w) -{-# INLINABLE differenceWith #-} - --- | /O(n*log m)/ Intersection of two maps. Return elements of the first --- map for keys existing in the second. -intersection :: (Eq k, Hashable k) => HashMap k v -> HashMap k w -> HashMap k v -intersection a b = foldlWithKey' go empty a - where - go m k v = case lookup k b of - Just _ -> insert k v m - _ -> m -{-# INLINABLE intersection #-} - --- | /O(n*log m)/ Intersection of two maps. If a key occurs in both maps --- the provided function is used to combine the values from the two --- maps. -intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1 - -> HashMap k v2 -> HashMap k v3 -intersectionWith f a b = foldlWithKey' go empty a - where - go m k v = case lookup k b of - Just w -> insert k (f v w) m - _ -> m -{-# INLINABLE intersectionWith #-} - --- | /O(n*log m)/ Intersection of two maps. If a key occurs in both maps --- the provided function is used to combine the values from the two --- maps. -intersectionWithKey :: (Eq k, Hashable k) => (k -> v1 -> v2 -> v3) - -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 -intersectionWithKey f a b = foldlWithKey' go empty a - where - go m k v = case lookup k b of - Just w -> insert k (f k v w) m - _ -> m -{-# INLINABLE intersectionWithKey #-} - ------------------------------------------------------------------------- --- * 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 fullNodeMask - 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.trim mary 1 - _ -> do - ary2 <- A.trim 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 = case go (A.index ary i) 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.trim mary j - return $! Collision h ary2 - | Just el <- onColl $! A.index ary i - = A.write mary j el >> step ary mary (i+1) (j+1) n - | 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 = L.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 = L.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. -toList :: HashMap k v -> [(k, v)] -toList t = build (\ c z -> foldrWithKey (curry c) z t) -{-# INLINE toList #-} - --- | /O(n)/ Construct a map with the supplied mappings. If the list --- contains duplicate mappings, the later mappings take precedence. -fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v -fromList = L.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 occurences 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 :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v -fromListWith f = L.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 :: (Eq k, Hashable k) => (k -> v -> v -> v) -> [(k, v)] -> HashMap k v -fromListWithKey f = L.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) empty -{-# INLINE fromListWithKey #-} - ------------------------------------------------------------------------- --- Array operations - --- | /O(n)/ Look up the value associated with the given key in an --- array. -lookupInArrayCont :: -#if __GLASGOW_HASKELL__ >= 802 - 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 = go k0 ary0 0 (A.length ary0) - where - go :: Eq k => k -> A.Array (Leaf k v) -> Int -> Int -> r - go !k !ary !i !n - | i >= n = absent (# #) - | otherwise = case A.index ary i of - (L kx v) - | k == kx -> present v i - | otherwise -> go 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 - | i >= n = A.run $ do - -- Not found, append to the end. - mary <- A.new_ (n + 1) - A.copy ary 0 mary 0 n - A.write mary n (L k v) - return mary - | L kx y <- A.index ary i - , k == kx - , (# v2 #) <- f k v y - = A.update ary i (L k v2) - | otherwise - = go k v ary (i+1) n -{-# INLINABLE updateOrSnocWithKey #-} - -updateOrConcatWith :: Eq k => (v -> v -> v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -updateOrConcatWith f = updateOrConcatWithKey (const f) -{-# INLINABLE updateOrConcatWith #-} - -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 () - | otherwise = case A.index indices i2 of - Just i1 -> do -- key occurs in both arrays, store combination in position i1 - L k v1 <- A.indexM ary1 i1 - L _ v2 <- A.indexM ary2 i2 - A.write mary i1 (L k (f k v1 v2)) - go iEnd (i2+1) - Nothing -> 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. -update16 :: A.Array e -> Int -> e -> A.Array e -update16 ary idx b = runST (update16M ary idx b) -{-# INLINE update16 #-} - --- | /O(n)/ Update the element at the given position in this array. -update16M :: A.Array e -> Int -> e -> ST s (A.Array e) -update16M ary idx b = do - mary <- clone16 ary - A.write mary idx b - A.unsafeFreeze mary -{-# INLINE update16M #-} - --- | /O(n)/ Update the element at the given position in this array, by applying a function to it. -update16With' :: A.Array e -> Int -> (e -> e) -> A.Array e -update16With' ary idx f - | (# x #) <- A.index# ary idx - = update16 ary idx $! f x -{-# INLINE update16With' #-} - --- | Unsafely clone an array of 16 elements. The length of the input --- array is not checked. -clone16 :: A.Array e -> ST s (A.MArray s e) -clone16 ary = - A.thaw ary 0 16 - ------------------------------------------------------------------------- --- Bit twiddling - -bitsPerSubkey :: Int -bitsPerSubkey = 4 - -maxChildren :: Int -maxChildren = 1 `unsafeShiftL` bitsPerSubkey - -subkeyMask :: Bitmap -subkeyMask = 1 `unsafeShiftL` bitsPerSubkey - 1 - -sparseIndex :: Bitmap -> Bitmap -> Int -sparseIndex b m = popCount (b .&. (m - 1)) - -mask :: Word -> Shift -> Bitmap -mask w s = 1 `unsafeShiftL` index w s -{-# INLINE mask #-} - --- | Mask out the 'bitsPerSubkey' bits used for indexing at this level --- of the tree. -index :: Hash -> Shift -> Int -index w s = fromIntegral $ (unsafeShiftR w s) .&. subkeyMask -{-# INLINE index #-} - --- | A bitmask with the 'bitsPerSubkey' least significant bits set. -fullNodeMask :: Bitmap -fullNodeMask = complement (complement 0 `unsafeShiftL` maxChildren) -{-# INLINE fullNodeMask #-} - --- | 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 = isTrue# (reallyUnsafePtrEquality# x y ==# 1#) -{-# INLINE ptrEq #-} - ------------------------------------------------------------------------- --- IsList instance -instance (Eq k, Hashable k) => Exts.IsList (HashMap k v) where - type Item (HashMap k v) = (k, v) - fromList = fromList - toList = toList +{-# 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 +-- . +-- +-- @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 diff --git a/Data/HashMap/Internal/Array.hs b/Data/HashMap/Internal/Array.hs --- a/Data/HashMap/Internal/Array.hs +++ b/Data/HashMap/Internal/Array.hs @@ -1,4 +1,10 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples, ScopedTypeVariables #-} +{-# 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 #-} @@ -20,14 +26,15 @@ -- -- Note that no bounds checking are performed. module Data.HashMap.Internal.Array - ( Array - , MArray + ( Array(..) + , MArray(..) -- * Creation , new , new_ , singleton , singletonM + , snoc , pair -- * Basic interface @@ -35,7 +42,6 @@ , lengthM , read , write - , index , indexM , index# , update @@ -45,7 +51,6 @@ , insertM , delete , sameArray1 - , trim , unsafeFreeze , unsafeThaw @@ -53,6 +58,7 @@ , run , copy , copyM + , cloneM -- * Folds , foldl @@ -65,116 +71,42 @@ , thaw , map , map' + , filter + , mapMaybe , traverse , traverse' , toList , fromList + , fromList' + , shrink ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative (..), (<$>)) -#endif -import Control.Applicative (liftA2) -import Control.DeepSeq -import GHC.Exts(Int(..), Int#, reallyUnsafePtrEquality#, tagToEnum#, unsafeCoerce#, State#) -import GHC.ST (ST(..)) -import Control.Monad.ST (stToIO) - -#if __GLASGOW_HASKELL__ >= 709 -import Prelude hiding (filter, foldMap, foldr, foldl, length, map, read, traverse, all) -#else -import Prelude hiding (filter, foldr, foldl, length, map, read, all) -#endif - -#if __GLASGOW_HASKELL__ >= 710 -import GHC.Exts (SmallArray#, newSmallArray#, readSmallArray#, writeSmallArray#, - indexSmallArray#, unsafeFreezeSmallArray#, unsafeThawSmallArray#, - SmallMutableArray#, sizeofSmallArray#, copySmallArray#, thawSmallArray#, - sizeofSmallMutableArray#, copySmallMutableArray#, cloneSmallMutableArray#) +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) -#else -import GHC.Exts (Array#, newArray#, readArray#, writeArray#, - indexArray#, unsafeFreezeArray#, unsafeThawArray#, - MutableArray#, sizeofArray#, copyArray#, thawArray#, - sizeofMutableArray#, copyMutableArray#, cloneMutableArray#) -import Data.Monoid (Monoid (..)) -#endif +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 -import Data.HashMap.Internal.Unsafe (runST) -import Control.Monad ((>=>)) - -#if __GLASGOW_HASKELL__ >= 710 -type Array# a = SmallArray# a -type MutableArray# a = SmallMutableArray# a - -newArray# :: Int# -> a -> State# d -> (# State# d, SmallMutableArray# d a #) -newArray# = newSmallArray# - -unsafeFreezeArray# :: SmallMutableArray# d a - -> State# d -> (# State# d, SmallArray# a #) -unsafeFreezeArray# = unsafeFreezeSmallArray# - -readArray# :: SmallMutableArray# d a - -> Int# -> State# d -> (# State# d, a #) -readArray# = readSmallArray# - -writeArray# :: SmallMutableArray# d a - -> Int# -> a -> State# d -> State# d -writeArray# = writeSmallArray# - -indexArray# :: SmallArray# a -> Int# -> (# a #) -indexArray# = indexSmallArray# - -unsafeThawArray# :: SmallArray# a - -> State# d -> (# State# d, SmallMutableArray# d a #) -unsafeThawArray# = unsafeThawSmallArray# - -sizeofArray# :: SmallArray# a -> Int# -sizeofArray# = sizeofSmallArray# - -copyArray# :: SmallArray# a - -> Int# - -> SmallMutableArray# d a - -> Int# - -> Int# - -> State# d - -> State# d -copyArray# = copySmallArray# - -cloneMutableArray# :: SmallMutableArray# s a - -> Int# - -> Int# - -> State# s - -> (# State# s, SmallMutableArray# s a #) -cloneMutableArray# = cloneSmallMutableArray# - -thawArray# :: SmallArray# a - -> Int# - -> Int# - -> State# d - -> (# State# d, SmallMutableArray# d a #) -thawArray# = thawSmallArray# - -sizeofMutableArray# :: SmallMutableArray# s a -> Int# -sizeofMutableArray# = sizeofSmallMutableArray# - -copyMutableArray# :: SmallMutableArray# d a - -> Int# - -> SmallMutableArray# d a - -> Int# - -> Int# - -> State# d - -> State# d -copyMutableArray# = copySmallMutableArray# -#endif - ------------------------------------------------------------------------- - #if defined(ASSERTS) -- This fugly hack is brought by GHC's apparent reluctance to deal -- with MagicHash and UnboxedTuples when inferring types. Eek! @@ -182,19 +114,21 @@ 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 :: !(Array# a) + unArray :: !(SmallArray# a) } instance Show a => Show (Array a) where @@ -222,17 +156,26 @@ !lenys = length ys0 length :: Array a -> Int -length ary = I# (sizeofArray# (unArray ary)) +length ary = I# (sizeofSmallArray# (unArray ary)) {-# INLINE length #-} data MArray s a = MArray { - unMArray :: !(MutableArray# s a) + unMArray :: !(SmallMutableArray# s a) } -lengthM :: MArray s a -> Int -lengthM mary = I# (sizeofMutableArray# (unMArray mary)) +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 @@ -250,20 +193,43 @@ -- 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 (I# n#) b = - CHECK_GT("new",n,(0 :: Int)) +new _n@(I# n#) b = + CHECK_GT("new",_n,(0 :: Int)) ST $ \s -> - case newArray# n# b s of + 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 #-} @@ -272,6 +238,15 @@ 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 @@ -281,44 +256,43 @@ read :: MArray s a -> Int -> ST s a read ary _i@(I# i#) = ST $ \ s -> - CHECK_BOUNDS("read", lengthM ary, _i) - readArray# (unMArray ary) i# 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", lengthM ary, _i) - case writeArray# (unMArray ary) i# b s of + CHECK_BOUNDS("write", unsafeLengthM ary, _i) + case writeSmallArray# (unMArray ary) i# b s of s' -> (# s' , () #) {-# INLINE write #-} -index :: Array a -> Int -> a -index ary _i@(I# i#) = - CHECK_BOUNDS("index", length ary, _i) - case indexArray# (unArray ary) i# of (# b #) -> b -{-# INLINE index #-} - +-- | 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) - indexArray# (unArray 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 indexArray# (unArray ary) i# of (# b #) -> return b + case indexSmallArray# (unArray ary) i# of (# b #) -> return b {-# INLINE indexM #-} unsafeFreeze :: MArray s a -> ST s (Array a) unsafeFreeze mary - = ST $ \s -> case unsafeFreezeArray# (unMArray mary) s of + = 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 unsafeThawArray# (unArray ary) s of + = ST $ \s -> case unsafeThawSmallArray# (unArray ary) s of (# s', mary #) -> (# s', MArray mary #) {-# INLINE unsafeThaw #-} @@ -330,58 +304,52 @@ 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, lengthM dst) + CHECK_LE("copy", _didx + _n, unsafeLengthM dst) ST $ \ s# -> - case copyArray# (unArray src) sidx# (unMArray dst) didx# n# s# of + 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", lengthM src, _sidx + _n - 1) - CHECK_BOUNDS("copyM: dst", lengthM dst, _didx + _n - 1) + CHECK_BOUNDS("copyM: src", unsafeLengthM src, _sidx + _n - 1) + CHECK_BOUNDS("copyM: dst", unsafeLengthM dst, _didx + _n - 1) ST $ \ s# -> - case copyMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of + 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", lengthM _mary, _off - 1) - CHECK_BOUNDS("cloneM_end", lengthM _mary, _off + _len - 1) + CHECK_BOUNDS("cloneM_off", unsafeLengthM _mary, _off) + CHECK_BOUNDS("cloneM_end", unsafeLengthM _mary, _off + _len - 1) ST $ \ s -> - case cloneMutableArray# mary# off# len# s of + case cloneSmallMutableArray# mary# off# len# s of (# s', mary'# #) -> (# s', MArray mary'# #) --- | Create a new array of the @n@ first elements of @mary@. -trim :: MArray s a -> Int -> ST s (Array a) -trim mary n = cloneM mary 0 n >>= unsafeFreeze -{-# INLINE trim #-} - --- | /O(n)/ Insert an element at the given position in this array, +-- | \(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, +-- | \(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) + do mary <- new (count+1) b copy ary 0 mary 0 idx - write mary idx b 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. +-- | \(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. +-- | \(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) @@ -391,7 +359,7 @@ where !count = length ary {-# INLINE updateM #-} --- | /O(n)/ Update the element at the given positio in this array, by +-- | \(O(n)\) Update the element at the given position in this array, by -- applying a function to it. Evaluates the element to WHNF before -- inserting it into the array. updateWith' :: Array e -> Int -> (e -> e) -> Array e @@ -400,7 +368,7 @@ = update ary idx $! f x {-# INLINE updateWith' #-} --- | /O(1)/ Update the element at the given position in this array, +-- | \(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 = @@ -412,13 +380,13 @@ {-# INLINE unsafeUpdateM #-} foldl' :: (b -> a -> b) -> b -> Array a -> b -foldl' f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 +foldl' f = \ z0 ary0 -> foldl'_ ary0 (length ary0) 0 z0 where - go ary n i !z + foldl'_ !ary n i !z | i >= n = z | otherwise = case index# ary i of - (# x #) -> go ary n (i+1) (f z x) + (# x #) -> foldl'_ ary n (i+1) (f z x) {-# INLINE foldl' #-} foldr' :: (a -> b -> b) -> b -> Array a -> b @@ -431,13 +399,13 @@ {-# INLINE foldr' #-} foldr :: (a -> b -> b) -> b -> Array a -> b -foldr f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 +foldr f = \ z0 ary0 -> foldr_ ary0 (length ary0) 0 z0 where - go ary n i z + foldr_ !ary n i z | i >= n = z | otherwise = case index# ary i of - (# x #) -> f x (go ary n (i+1) z) + (# x #) -> f x (foldr_ ary n (i+1) z) {-# INLINE foldr #-} foldl :: (b -> a -> b) -> b -> Array a -> b @@ -473,19 +441,19 @@ {-# NOINLINE undefinedElem #-} thaw :: Array e -> Int -> Int -> ST s (MArray s e) -thaw !ary !_o@(I# o#) (I# n#) = - CHECK_LE("thaw", _o + n, length ary) - ST $ \ s -> case thawArray# (unArray ary) o# n# s of +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, +-- | \(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, +-- | \(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 @@ -497,15 +465,17 @@ where !count = length ary {-# INLINE deleteM #-} -map :: (a -> b) -> Array a -> Array b +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 mary + | i >= n = return () | otherwise = do x <- indexM ary i write mary i $ f x @@ -513,36 +483,105 @@ {-# INLINE map #-} -- | Strict version of 'map'. -map' :: (a -> b) -> Array a -> Array b +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 mary + | i >= n = return () | otherwise = do x <- indexM ary i write mary i $! f x go ary mary (i+1) n {-# INLINE map' #-} -fromList :: Int -> [a] -> Array a +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 [] !mary !_ = return mary - go (x:xs) mary i = do write mary i x - go xs mary (i+1) + 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. MutableArray# s a -> ST s (Array a)} +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 diff --git a/Data/HashMap/Internal/Debug.hs b/Data/HashMap/Internal/Debug.hs new file mode 100644 --- /dev/null +++ b/Data/HashMap/Internal/Debug.hs @@ -0,0 +1,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 diff --git a/Data/HashMap/Internal/List.hs b/Data/HashMap/Internal/List.hs --- a/Data/HashMap/Internal/List.hs +++ b/Data/HashMap/Internal/List.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} {-# OPTIONS_HADDOCK not-home #-} @@ -25,12 +26,10 @@ , unorderedCompare ) where +import Data.List (sortBy) import Data.Maybe (fromMaybe) -import Data.List (sortBy) -import Data.Monoid -import Prelude --- Note: previous implemenation isPermutation = null (as // bs) +-- Note: previous implementation isPermutation = null (as // bs) -- was O(n^2) too. -- -- This assumes lists are of equal length @@ -51,7 +50,7 @@ -- The idea: -- --- Homogeonous version +-- Homogenous version -- -- uc :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering -- uc c as bs = compare (sortBy c as) (sortBy c bs) @@ -68,7 +67,7 @@ go [] [] = EQ go [] (_ : _) = LT go (_ : _) [] = GT - go (x : xs) (y : ys) = c x y `mappend` go xs ys + 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') diff --git a/Data/HashMap/Internal/Strict.hs b/Data/HashMap/Internal/Strict.hs --- a/Data/HashMap/Internal/Strict.hs +++ b/Data/HashMap/Internal/Strict.hs @@ -1,6 +1,11 @@ -{-# LANGUAGE BangPatterns, CPP, PatternGuards, MagicHash, UnboxedTuples #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} ------------------------------------------------------------------------ @@ -34,8 +39,8 @@ -- 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) so in practice these +-- 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 ( @@ -45,102 +50,113 @@ HashMap -- * Construction - , empty + , HM.empty , singleton -- * Basic interface , HM.null - , size + , HM.size , HM.member , HM.lookup , (HM.!?) , HM.findWithDefault - , lookupDefault - , (!) + , HM.lookupDefault + , (HM.!) + , HM.lookupKey , insert , insertWith - , delete + , HM.delete , adjust , update , alter , alterF - , isSubmapOf - , isSubmapOfBy + , HM.isSubmapOf + , HM.isSubmapOfBy -- * Combine -- ** Union - , union + , HM.union , unionWith , unionWithKey - , unions + , HM.unions -- ** Compose - , compose + , HM.compose -- * Transformations , map , mapWithKey , traverseWithKey + , HM.mapKeys -- * Difference and intersection - , difference + , HM.difference , differenceWith - , intersection + , differenceWithKey + , HM.intersection , intersectionWith , intersectionWithKey + , HM.disjoint -- * Folds - , foldMapWithKey - , foldr' - , foldl' - , foldrWithKey' - , foldlWithKey' + , HM.foldMapWithKey + , HM.foldr' + , HM.foldl' + , HM.foldrWithKey' + , HM.foldlWithKey' , HM.foldr , HM.foldl - , foldrWithKey - , foldlWithKey + , HM.foldrWithKey + , HM.foldlWithKey -- * Filter , HM.filter - , filterWithKey + , HM.filterWithKey , mapMaybe , mapMaybeWithKey -- * Conversions - , keys - , elems + , HM.keys + , HM.elems -- ** Lists - , toList + , HM.toList , fromList , fromListWith , fromListWithKey ) where -import Data.Bits ((.&.), (.|.)) - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative (..), (<$>)) -#endif -import qualified Data.List as L -import Data.Hashable (Hashable) -import Prelude hiding (map, lookup) +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.HashMap.Internal as HM -import Data.HashMap.Internal hiding ( - alter, alterF, adjust, fromList, fromListWith, fromListWithKey, - insert, insertWith, - differenceWith, intersectionWith, intersectionWithKey, map, mapWithKey, - mapMaybe, mapMaybeWithKey, singleton, update, unionWith, unionWithKey, - traverseWithKey) -import Data.HashMap.Internal.Unsafe (runST) -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity -#endif -import Control.Applicative (Const (..)) -import Data.Coerce +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: @@ -153,28 +169,28 @@ ------------------------------------------------------------------------ -- * Construction --- | /O(1)/ Construct a map with a single element. +-- | \(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 +-- | \(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 :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v +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 +-- | \(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 :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v +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 @@ -183,24 +199,26 @@ 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` (collision h l (L k x)) - | otherwise = x `seq` runST (two s h k x hy t) + 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 bitmapIndexedOrFull (b .|. m) ary' + in HM.bitmapIndexedOrFull (b .|. m) ary' | otherwise = - let st = A.index ary i - st' = go h k x (s+bitsPerSubkey) st - ary' = A.update ary i $! st' - in BitmapIndexed b ary' + 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) = - let st = A.index ary i - st' = go h k x (s+bitsPerSubkey) st - ary' = update16 ary i $! st' - in 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) @@ -208,38 +226,39 @@ {-# INLINABLE insertWith #-} -- | In-place update version of insertWith -unsafeInsertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v +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 :: (Eq k, Hashable k) => (k -> v -> v -> v) -> k -> v -> HashMap k v +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 $! collision h l l' - | otherwise = x `seq` two s h k x hy t + 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 $! bitmapIndexedOrFull (b .|. m) ary' + return $! HM.bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i - st' <- go h k x (s+bitsPerSubkey) st + st' <- go h k x (nextShift s) st A.unsafeUpdateM ary i st' return t where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = do st <- A.indexM ary i - st' <- go h k x (s+bitsPerSubkey) st + st' <- go h k x (nextShift s) st A.unsafeUpdateM ary i st' return t where i = index h s @@ -248,9 +267,9 @@ | 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 +-- | \(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 :: (Eq k, Hashable k) => (v -> v) -> k -> HashMap k v -> HashMap k v +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 @@ -260,31 +279,34 @@ | otherwise = t go h k s t@(BitmapIndexed b ary) | b .&. m == 0 = t - | otherwise = let st = A.index ary i - st' = go h k (s+bitsPerSubkey) st - ary' = A.update ary i $! st' - in BitmapIndexed b ary' + | 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) = - let i = index h s - st = A.index ary i - st' = go h k (s+bitsPerSubkey) st - ary' = update16 ary i $! st' - in 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@ +-- | \(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 :: (Eq k, Hashable k) => (a -> Maybe a) -> k -> HashMap k a -> HashMap k a +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 +-- | \(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: @@ -292,14 +314,23 @@ -- @ -- 'lookup' k ('alter' f k m) = f ('lookup' k m) -- @ -alter :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v +alter :: Hashable k => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v alter f k m = - case f (HM.lookup k m) of - Nothing -> delete k m - Just v -> insert k v m + let !h = hash k + !lookupRes = HM.lookupRecordCollision h k m + in case f (HM.lookupResToMaybe lookupRes) of + Nothing -> case lookupRes of + Absent -> m + Present _ collPos -> HM.deleteKeyExists collPos h k m + Just !v' -> case lookupRes of + Absent -> HM.insertNewKey h k v' m + Present v collPos -> + if v `ptrEq` v' + then m + else HM.insertKeyExists collPos h k v' m {-# INLINABLE alter #-} --- | /O(log n)/ The expression (@'alterF' f k map@) alters the value @x@ at +-- | \(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. @@ -308,7 +339,7 @@ -- . -- -- @since 0.2.10 -alterF :: (Functor f, Eq k, Hashable k) +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 @@ -317,18 +348,16 @@ -- @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) $ \fres -> - case fres of - Nothing -> maybe m (const (delete' h k m)) mv - Just !v' -> insert' h k v' m + 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 #-} -#if MIN_VERSION_base(4,8,0) -- See notes in Data.HashMap.Internal test_bottom :: a test_bottom = error "Data.HashMap.alterF internal error: hit test_bottom" @@ -348,13 +377,13 @@ "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}) + 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 (insertModifying x (\mold -> case runIdentity (f (Just mold)) of - Nothing -> bogus# (# #) - Just !new -> (# new #))) + 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 @@ -366,7 +395,7 @@ Nothing -> impossibleAdjust)) "alterFlookup" forall _ign1 _ign2 (f :: Maybe a -> Const r (Maybe a)) . - alterFWeird _ign1 _ign2 f = \ !k !m -> Const (getConst (f (lookup k m))) + 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 @@ -377,7 +406,7 @@ -- -- Failure to abide by these laws will make demons come out of your nose. alterFWeird - :: (Functor f, Eq k, Hashable k) + :: (Functor f, Hashable k) => f (Maybe v) -> f (Maybe v) -> (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v) @@ -387,7 +416,7 @@ -- | 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, Eq k, Hashable k) +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 @@ -400,44 +429,41 @@ Absent -> m -- Key did exist, no collision - Present _ collPos -> deleteKeyExists collPos h k m + Present _ collPos -> HM.deleteKeyExists collPos h k m ------------------------------ -- Update value - Just v' -> case lookupRes of + Just !v' -> case lookupRes of -- Key did not exist before, insert v' under a new key - Absent -> insertNewKey h k v' m + Absent -> HM.insertNewKey h k v' m -- Key existed before, no hash collision - Present v collPos -> v' `seq` + 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 + else HM.insertKeyExists collPos h k v' m where !h = hash k - !lookupRes = lookupRecordCollision h k m - !mv = case lookupRes of - Absent -> Nothing - Present v _ -> Just v + !lookupRes = HM.lookupRecordCollision h k m + !mv = HM.lookupResToMaybe lookupRes {-# INLINABLE alterFEager #-} -#endif ------------------------------------------------------------------------ -- * Combine --- | /O(n+m)/ The union of two maps. If a key occurs in both maps, +-- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the result. -unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v +unionWith :: Eq k => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWith f = unionWithKey (const f) {-# INLINE unionWith #-} --- | /O(n+m)/ The union of two maps. If a key occurs in both maps, +-- | \(O(n+m)\) The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the result. -unionWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> HashMap k v -> HashMap k v +unionWithKey :: Eq k => (k -> v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWithKey f = go 0 where @@ -448,7 +474,7 @@ 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 collision h1 l1 l2 + 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) @@ -457,30 +483,30 @@ | 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 (updateOrConcatWithKey f ls1 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' = unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2 - in bitmapIndexedOrFull b' ary' + ary' = HM.unionArrayBy (go (nextShift s)) b1 b2 ary1 ary2 + in HM.bitmapIndexedOrFull b' ary' go s (BitmapIndexed b1 ary1) (Full ary2) = - let ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2 + let ary' = HM.unionArrayBy (go (nextShift s)) b1 fullBitmap ary1 ary2 in Full ary' go s (Full ary1) (BitmapIndexed b2 ary2) = - let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2 + let ary' = HM.unionArrayBy (go (nextShift s)) fullBitmap b2 ary1 ary2 in Full ary' go s (Full ary1) (Full ary2) = - let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask + 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 bitmapIndexedOrFull b' ary' + in HM.bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary1 i $ \st1 -> - go (s+bitsPerSubkey) st1 t2 + go (nextShift s) st1 t2 in BitmapIndexed b1 ary' where h2 = leafHashCode t2 @@ -489,9 +515,9 @@ go s t1 (BitmapIndexed b2 ary2) | b2 .&. m1 == 0 = let ary' = A.insert ary2 i $! t1 b' = b2 .|. m1 - in bitmapIndexedOrFull b' ary' + in HM.bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary2 i $ \st2 -> - go (s+bitsPerSubkey) t1 st2 + go (nextShift s) t1 st2 in BitmapIndexed b2 ary' where h1 = leafHashCode t1 @@ -500,12 +526,12 @@ go s (Full ary1) t2 = let h2 = leafHashCode t2 i = index h2 s - ary' = update16With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 + 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' = update16With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 + ary' = HM.updateFullArrayWith' ary2 i $ \st2 -> go (nextShift s) t1 st2 in Full ary' leafHashCode (Leaf h _) = h @@ -513,7 +539,7 @@ leafHashCode _ = error "leafHashCode" goDifferentHash s h1 h2 t1 t2 - | m1 == m2 = BitmapIndexed m1 (A.singleton $! go (s+bitsPerSubkey) 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 @@ -524,7 +550,7 @@ ------------------------------------------------------------------------ -- * Transformations --- | /O(n)/ Transform this map by applying a function to every value. +-- | \(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 @@ -536,7 +562,7 @@ 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. +-- | \(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 #-} @@ -545,24 +571,24 @@ ------------------------------------------------------------------------ -- * Filter --- | /O(n)/ Transform this map by applying a function to every value +-- | \(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 +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') + 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 +-- | \(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 +-- | \(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. -- @@ -591,53 +617,57 @@ ------------------------------------------------------------------------ -- * Difference and intersection --- | /O(n*log m)/ Difference with a combining function. When two equal keys are +-- | \(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 :: (Eq k, Hashable k) => (v -> w -> Maybe v) -> HashMap k v -> HashMap k w -> HashMap k v -differenceWith f a b = foldlWithKey' go empty a - where - go m k v = case HM.lookup k b of - Nothing -> insert k v m - Just w -> maybe m (\y -> insert k y m) (f v w) -{-# INLINABLE differenceWith #-} +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+m)/ Intersection of two maps. If a key occurs in both maps +-- | \(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, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1 +intersectionWith :: Eq k => (v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 -intersectionWith f a b = foldlWithKey' go empty a - where - go m k v = case HM.lookup k b of - Just w -> insert k (f v w) m - _ -> m +intersectionWith f = Exts.inline intersectionWithKey $ const f {-# INLINABLE intersectionWith #-} --- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps +-- | \(O(n+m)\) Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. -intersectionWithKey :: (Eq k, Hashable k) => (k -> v1 -> v2 -> v3) +intersectionWithKey :: Eq k => (k -> v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 -intersectionWithKey f a b = foldlWithKey' go empty a - where - go m k v = case HM.lookup k b of - Just w -> insert k (f k v w) m - _ -> m +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 +-- | \(O(n \log n)\) Construct a map with the supplied mappings. If the -- list contains duplicate mappings, the later mappings take -- precedence. -fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v -fromList = L.foldl' (\ m (k, !v) -> HM.unsafeInsert k v m) empty +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 +-- | \(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)@. -- @@ -660,18 +690,18 @@ -- > = fromList [('a', [3, 1]), ('b', [2])] -- -- Note that the lists in the resulting map contain elements in reverse order --- from their occurences in the original list. +-- from their occurrences in the original list. -- -- More generally, duplicate entries are accumulated as follows; -- this matters when @f@ is not commutative or not associative. -- -- > fromListWith f [(k, a), (k, b), (k, c), (k, d)] -- > = fromList [(k, f d (f c (f b a)))] -fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v -fromListWith f = L.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty +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 +-- | \(O(n \log n)\) Construct a map from a list of elements. Uses -- the provided function to merge duplicate entries. -- -- === Examples @@ -697,8 +727,8 @@ -- > = fromList [(k, f k d (f k c (f k b a)))] -- -- @since 0.2.11 -fromListWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> [(k, v)] -> HashMap k v -fromListWithKey f = L.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) empty +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 #-} ------------------------------------------------------------------------ @@ -709,9 +739,9 @@ 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 + | 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 @@ -734,16 +764,11 @@ updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0) where go !k v !ary !i !n - | i >= n = A.run $ do - -- Not found, append to the end. - mary <- A.new_ (n + 1) - A.copy ary 0 mary 0 n - let !l = v `seq` (L k v) - A.write mary n l - return mary - | 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 + -- 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 #-} ------------------------------------------------------------------------ diff --git a/Data/HashMap/Internal/Unsafe.hs b/Data/HashMap/Internal/Unsafe.hs deleted file mode 100644 --- a/Data/HashMap/Internal/Unsafe.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE CPP #-} - -#if !MIN_VERSION_base(4,9,0) -{-# LANGUAGE MagicHash, Rank2Types, UnboxedTuples #-} -#endif - -{-# 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 --- --- This module exports a workaround for this bug: --- --- http://hackage.haskell.org/trac/ghc/ticket/5916 --- --- Please read the comments in ghc/libraries/base/GHC/ST.lhs to --- understand what's going on here. --- --- Code that uses this module should be compiled with -fno-full-laziness -module Data.HashMap.Internal.Unsafe - ( runST - ) where - -#if MIN_VERSION_base(4,9,0) --- The GHC issue was fixed in GHC 8.0/base 4.9 -import Control.Monad.ST - -#else - -import GHC.Base (realWorld#) -import qualified GHC.ST as ST - --- | Return the value computed by a state transformer computation. --- The @forall@ ensures that the internal state used by the 'ST' --- computation is inaccessible to the rest of the program. -runST :: (forall s. ST.ST s a) -> a -runST st = runSTRep (case st of { ST.ST st_rep -> st_rep }) -{-# INLINE runST #-} - -runSTRep :: (forall s. ST.STRep s a) -> a -runSTRep st_rep = case st_rep realWorld# of - (# _, r #) -> r -{-# INLINE [0] runSTRep #-} -#endif diff --git a/Data/HashMap/Lazy.hs b/Data/HashMap/Lazy.hs --- a/Data/HashMap/Lazy.hs +++ b/Data/HashMap/Lazy.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} ------------------------------------------------------------------------ @@ -19,8 +19,8 @@ -- 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) so in practice these +-- 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 ( @@ -42,6 +42,7 @@ , findWithDefault , lookupDefault , (!) + , lookupKey , insert , insertWith , delete @@ -66,13 +67,16 @@ , map , mapWithKey , traverseWithKey + , mapKeys -- * Difference and intersection , difference , differenceWith + , differenceWithKey , intersection , intersectionWith , intersectionWithKey + , disjoint -- * Folds , foldMapWithKey @@ -105,9 +109,10 @@ , HS.keysSet ) where -import Data.HashMap.Internal as HM +import Data.HashMap.Internal +import Prelude () + import qualified Data.HashSet.Internal as HS -import Prelude () -- $strictness -- diff --git a/Data/HashMap/Strict.hs b/Data/HashMap/Strict.hs --- a/Data/HashMap/Strict.hs +++ b/Data/HashMap/Strict.hs @@ -18,8 +18,8 @@ -- 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) so in practice these +-- 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 ( @@ -41,6 +41,7 @@ , findWithDefault , lookupDefault , (!) + , lookupKey , insert , insertWith , delete @@ -65,13 +66,16 @@ , map , mapWithKey , traverseWithKey + , mapKeys -- * Difference and intersection , difference , differenceWith + , differenceWithKey , intersection , intersectionWith , intersectionWithKey + , disjoint -- * Folds , foldMapWithKey @@ -104,9 +108,10 @@ , HS.keysSet ) where -import Data.HashMap.Internal.Strict as HM +import Data.HashMap.Internal.Strict +import Prelude () + import qualified Data.HashSet.Internal as HS -import Prelude () -- $strictness -- diff --git a/Data/HashSet.hs b/Data/HashSet.hs --- a/Data/HashSet.hs +++ b/Data/HashSet.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} -#endif ------------------------------------------------------------------------ {-| @@ -88,8 +86,8 @@ 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) so in practice these +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. -} @@ -109,6 +107,7 @@ , null , size , member + , lookupElement , insert , delete , isSubsetOf @@ -119,6 +118,7 @@ -- * Difference and intersection , difference , intersection + , disjoint -- * Folds , foldl' @@ -139,4 +139,4 @@ ) where import Data.HashSet.Internal -import Prelude () +import Prelude () diff --git a/Data/HashSet/Internal.hs b/Data/HashSet/Internal.hs --- a/Data/HashSet/Internal.hs +++ b/Data/HashSet/Internal.hs @@ -1,11 +1,9 @@ -{-# LANGUAGE CPP, DeriveDataTypeable #-} -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeFamilies #-} -#endif -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK not-home #-} ------------------------------------------------------------------------ @@ -38,13 +36,13 @@ -- 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) so in practice these +-- 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 + HashSet(..) -- * Construction , empty @@ -54,6 +52,7 @@ , null , size , member + , lookupElement , insert , delete , isSubsetOf @@ -68,6 +67,7 @@ -- * Difference and intersection , difference , intersection + , disjoint -- * Folds , foldr @@ -92,54 +92,44 @@ , keysSet ) where -import Control.DeepSeq (NFData(..)) -import Data.Data hiding (Typeable) -import Data.HashMap.Internal - ( HashMap, foldMapWithKey, foldlWithKey, foldrWithKey - , equalKeys, equalKeys1) -import Data.Hashable (Hashable(hashWithSalt)) -#if __GLASGOW_HASKELL__ >= 711 -import Data.Semigroup (Semigroup(..)) -#elif __GLASGOW_HASKELL__ < 709 -import Data.Monoid (Monoid(..)) -#endif -import GHC.Exts (build) -import Prelude hiding (filter, foldr, foldl, map, null) -import qualified Data.Foldable as Foldable -import qualified Data.HashMap.Internal as H -import qualified Data.List as List -import Data.Typeable (Typeable) -import Text.Read - -#if __GLASGOW_HASKELL__ >= 708 -import qualified GHC.Exts as Exts -#endif - -#if MIN_VERSION_base(4,9,0) +import Control.DeepSeq (NFData (..), NFData1 (..), liftRnf2) +import Data.Data (Constr, Data (..), DataType) import Data.Functor.Classes -#endif - -#if MIN_VERSION_hashable(1,2,5) -import qualified Data.Hashable.Lifted as H -#endif +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 Data.Functor ((<$)) +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 () - } deriving (Typeable) + } -#if __GLASGOW_HASKELL__ >= 708 type role HashSet nominal -#endif +-- | @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. substitutivity may be violated: +-- behave differently, i.e. extensionality may be violated: -- -- >>> data D = A | B deriving (Eq, Show) -- >>> instance Hashable D where hashWithSalt salt _d = salt @@ -154,25 +144,21 @@ -- >>> toList y -- [B,A] -- --- In general, the lack of substitutivity can be observed with any function +-- In general, the lack of extensionality can be observed with any function -- that depends on the key ordering, such as folds and traversals. -instance (Eq a) => Eq (HashSet a) where +instance Eq a => Eq (HashSet a) where HashSet a == HashSet b = equalKeys a b {-# INLINE (==) #-} -#if MIN_VERSION_base(4,9,0) instance Eq1 HashSet where liftEq eq (HashSet a) (HashSet b) = equalKeys1 eq a b -#endif instance (Ord a) => Ord (HashSet a) where compare (HashSet a) (HashSet b) = compare a b {-# INLINE compare #-} -#if MIN_VERSION_base(4,9,0) instance Ord1 HashSet where liftCompare c (HashSet a) (HashSet b) = liftCompare2 c compare a b -#endif instance Foldable.Foldable HashSet where foldMap f = foldMapWithKey (\a _ -> f a) . asMap @@ -184,19 +170,16 @@ {-# INLINE foldl' #-} foldr' = foldr' {-# INLINE foldr' #-} -#if MIN_VERSION_base(4,8,0) toList = toList {-# INLINE toList #-} null = null {-# INLINE null #-} length = size {-# INLINE length #-} -#endif -#if __GLASGOW_HASKELL__ >= 711 -- | '<>' = 'union' -- --- /O(n+m)/ +-- \(O(n+m)\) -- -- To obtain good performance, the smaller set must be presented as -- the first argument. @@ -205,16 +188,17 @@ -- -- >>> fromList [1,2] <> fromList [2,3] -- fromList [1,2,3] -instance (Hashable a, Eq a) => Semigroup (HashSet a) where +instance Hashable a => Semigroup (HashSet a) where (<>) = union {-# INLINE (<>) #-} -#endif + stimes = stimesIdempotentMonoid + {-# INLINE stimes #-} -- | 'mempty' = 'empty' -- -- 'mappend' = 'union' -- --- /O(n+m)/ +-- \(O(n+m)\) -- -- To obtain good performance, the smaller set must be presented as -- the first argument. @@ -223,65 +207,56 @@ -- -- >>> mappend (fromList [1,2]) (fromList [2,3]) -- fromList [1,2,3] -instance (Hashable a, Eq a) => Monoid (HashSet a) where +instance Hashable a => Monoid (HashSet a) where mempty = empty {-# INLINE mempty #-} -#if __GLASGOW_HASKELL__ >= 711 mappend = (<>) -#else - mappend = union -#endif {-# INLINE mappend #-} -instance (Eq a, Hashable a, Read a) => Read (HashSet a) where +instance (Hashable a, Read a) => Read (HashSet a) where readPrec = parens $ prec 10 $ do Ident "fromList" <- lexP - xs <- readPrec - return (fromList xs) + fromList <$> readPrec readListPrec = readListPrecDefault -#if MIN_VERSION_base(4,9,0) instance Show1 HashSet where liftShowsPrec sp sl d m = showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) -#endif instance (Show a) => Show (HashSet a) where showsPrec d m = showParen (d > 10) $ showString "fromList " . shows (toList m) -instance (Data a, Eq a, Hashable a) => Data (HashSet a) where +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 constrIndex c of + gunfold k z c = case Data.constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" dataTypeOf _ = hashSetDataType - dataCast1 f = gcast1 f + dataCast1 f = Data.gcast1 f -#if MIN_VERSION_hashable(1,2,6) -instance H.Hashable1 HashSet where - liftHashWithSalt h s = H.liftHashWithSalt2 h hashWithSalt s . asMap -#endif +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 = mkConstr hashSetDataType "fromList" [] Prefix +fromListConstr = Data.mkConstr hashSetDataType "fromList" [] Data.Prefix hashSetDataType :: DataType -hashSetDataType = mkDataType "Data.HashSet.Internal.HashSet" [fromListConstr] +hashSetDataType = Data.mkDataType "Data.HashSet.Internal.HashSet" [fromListConstr] --- | /O(1)/ Construct an empty set. +-- | \(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. +-- | \(O(1)\) Construct a set with a single element. -- -- >>> HashSet.singleton 1 -- fromList [1] @@ -289,21 +264,21 @@ singleton a = HashSet (H.singleton a ()) {-# INLINABLE singleton #-} --- | /O(1)/ Convert to set to the equivalent 'HashMap' with @()@ values. +-- | \(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. +-- | \(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'. +-- | \(O(n)\) Produce a 'HashSet' of all the keys in the given 'HashMap'. -- -- >>> HashSet.keysSet (HashMap.fromList [(1, "a"), (2, "b")] -- fromList [1,2] @@ -312,7 +287,7 @@ keysSet :: HashMap k a -> HashSet k keysSet m = fromMap (() <$ m) --- | /O(n*log m)/ Inclusion of sets. +-- | \(O(n \log m)\) Inclusion of sets. -- -- ==== __Examples__ -- @@ -323,28 +298,28 @@ -- False -- -- @since 0.2.12 -isSubsetOf :: (Eq a, Hashable a) => HashSet a -> HashSet a -> Bool +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. +-- | \(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, Hashable a) => HashSet a -> HashSet a -> HashSet a +union :: Eq a => HashSet a -> HashSet a -> HashSet a union s1 s2 = HashSet $ H.union (asMap s1) (asMap s2) {-# INLINE union #-} -- TODO: Figure out the time complexity of 'unions'. -- | Construct a set containing all elements from a list of sets. -unions :: (Eq a, Hashable a) => [HashSet a] -> HashSet a +unions :: Eq a => [HashSet a] -> HashSet a unions = List.foldl' union empty {-# INLINE unions #-} --- | /O(1)/ Return 'True' if this set is empty, 'False' otherwise. +-- | \(O(1)\) Return 'True' if this set is empty, 'False' otherwise. -- -- >>> HashSet.null HashSet.empty -- True @@ -354,7 +329,7 @@ null = H.null . asMap {-# INLINE null #-} --- | /O(n)/ Return the number of elements in this set. +-- | \(O(n)\) Return the number of elements in this set. -- -- >>> HashSet.size HashSet.empty -- 0 @@ -364,65 +339,87 @@ size = H.size . asMap {-# INLINE size #-} --- | /O(log n)/ Return 'True' if the given value is present in this +-- | \(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 :: (Eq a, Hashable a) => a -> HashSet a -> Bool +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)/ Add the specified value to this set. +-- | \(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 :: (Eq a, Hashable a) => a -> HashSet a -> HashSet a +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. +-- | \(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 :: (Eq a, Hashable a) => a -> HashSet a -> HashSet a +delete :: Hashable a => a -> HashSet a -> HashSet a delete a = HashSet . H.delete a . asMap {-# INLINABLE delete #-} --- | /O(n)/ Transform this set by applying a function to every value. +-- | \(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, Eq b) => (a -> b) -> HashSet a -> HashSet b +map :: Hashable 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 +-- | \(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 :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a +difference :: Hashable a => HashSet a -> HashSet a -> HashSet a difference (HashSet a) (HashSet b) = HashSet (H.difference a b) {-# INLINABLE difference #-} --- | /O(n)/ Intersection of two sets. Return elements present in both +-- | \(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, Hashable a) => HashSet a -> HashSet a -> HashSet a +intersection :: Eq a => HashSet a -> HashSet a -> HashSet a intersection (HashSet a) (HashSet b) = HashSet (H.intersection a b) {-# INLINABLE intersection #-} --- | /O(n)/ Reduce this set by applying a binary operator to all +-- | \(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 @@ -432,7 +429,7 @@ where g z k _ = f z k {-# INLINE foldl' #-} --- | /O(n)/ Reduce this set by applying a binary operator to all +-- | \(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 @@ -442,7 +439,7 @@ where g k _ z = f k z {-# INLINE foldr' #-} --- | /O(n)/ Reduce this set by applying a binary operator to all +-- | \(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 @@ -450,7 +447,7 @@ where g k _ z = f k z {-# INLINE foldr #-} --- | /O(n)/ Reduce this set by applying a binary operator to all +-- | \(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 @@ -458,26 +455,27 @@ where g z k _ = f z k {-# INLINE foldl #-} --- | /O(n)/ Filter this set by retaining only elements satisfying a +-- | \(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. +-- | \(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 = build (\ c z -> foldrWithKey ((const .) c) z (asMap t)) +toList t = Exts.build (\ c z -> foldrWithKey (const . c) z (asMap t)) {-# INLINE toList #-} --- | /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 +-- | \(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 __GLASGOW_HASKELL__ >= 708 -instance (Eq a, Hashable a) => Exts.IsList (HashSet a) where +#if defined(__GLASGOW_HASKELL__) +instance Hashable a => Exts.IsList (HashSet a) where type Item (HashSet a) = a fromList = fromList toList = toList diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs --- a/benchmarks/Benchmarks.hs +++ b/benchmarks/Benchmarks.hs @@ -1,29 +1,30 @@ -{-# LANGUAGE CPP, DeriveAnyClass, DeriveGeneric, GADTs, PackageImports, RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} module Main where -import Control.DeepSeq -import Gauge (bench, bgroup, defaultMain, env, nf, whnf) -import Data.Bits ((.&.)) -import Data.Functor.Identity -import Data.Hashable (Hashable, hash) -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 Data.List (foldl') -import Data.Maybe (fromMaybe) -import GHC.Generics (Generic) -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) -#if !MIN_VERSION_bytestring(0,10,0) -instance NFData BS.ByteString -#endif +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 @@ -125,6 +126,7 @@ main = do defaultMain [ +#ifdef BENCH_containers_Map env setupEnv $ \ ~(Env{..}) -> -- * Comparison to other data structures -- ** Map @@ -165,10 +167,12 @@ [ 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{..}) -> + env setupEnv $ \ ~(Env{..}) -> bgroup "hashmap/Map" [ bgroup "lookup" [ bench "String" $ whnf (lookupIHM keys) ihm @@ -206,14 +210,12 @@ [ bench "String" $ whnf (IHM.isSubmapOf ihmSubset) ihm , bench "ByteString" $ whnf (IHM.isSubmapOf ihmbsSubset) ihmbs ] - , bgroup "hash" - [ bench "String" $ whnf hash hm - , bench "ByteString" $ whnf hash hmbs - ] - ] + ], +#endif +#ifdef BENCH_containers_IntMap -- ** IntMap - , env setupEnv $ \ ~(Env{..}) -> + env setupEnv $ \ ~(Env{..}) -> bgroup "IntMap" [ bench "lookup" $ whnf (lookupIM keysI) im , bench "lookup-miss" $ whnf (lookupIM keysI') im @@ -224,9 +226,10 @@ , bench "size" $ whnf IM.size im , bench "fromList" $ whnf IM.fromList elemsI , bench "isSubmapOf" $ whnf (IM.isSubmapOf imSubset) im - ] + ], +#endif - , env setupEnv $ \ ~(Env{..}) -> + env setupEnv $ \ ~(Env{..}) -> bgroup "HashMap" [ -- * Basic interface bgroup "lookup" @@ -311,14 +314,21 @@ ] -- Combine - , bench "union" $ whnf (HM.union hmi) hmi2 + , 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 -- * Difference and intersection , bench "difference" $ whnf (HM.difference hmi) hmi2 - , bench "intersection" $ whnf (HM.intersection hmi) hmi2 -- Folds , bench "foldl'" $ whnf (HM.foldl' (+) 0) hmi @@ -361,20 +371,25 @@ , bench "Int" $ whnf (HM.fromListWith (+)) elemsDupI ] ] + -- Hashable instance + , bgroup "hash" + [ bench "String" $ whnf hash hm + , bench "ByteString" $ whnf hash hmbs + ] ] ] ------------------------------------------------------------------------ -- * 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 @@ -384,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 @@ -392,7 +407,7 @@ {-# SPECIALIZE delete :: [BS.ByteString] -> HM.HashMap BS.ByteString Int -> HM.HashMap BS.ByteString Int #-} -alterInsert :: (Eq k, Hashable k) => [(k, Int)] -> HM.HashMap k 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 @@ -403,7 +418,7 @@ {-# SPECIALIZE alterInsert :: [(BS.ByteString, Int)] -> HM.HashMap BS.ByteString Int -> HM.HashMap BS.ByteString Int #-} -alterDelete :: (Eq k, Hashable k) => [k] -> HM.HashMap k 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 @@ -414,7 +429,7 @@ {-# SPECIALIZE alterDelete :: [BS.ByteString] -> HM.HashMap BS.ByteString Int -> HM.HashMap BS.ByteString Int #-} -alterFInsert :: (Eq k, Hashable k) => [(k, Int)] -> HM.HashMap k 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 @@ -425,7 +440,7 @@ {-# SPECIALIZE alterFInsert :: [(BS.ByteString, Int)] -> HM.HashMap BS.ByteString Int -> HM.HashMap BS.ByteString Int #-} -alterFDelete :: (Eq k, Hashable k) => [k] -> HM.HashMap k 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 @@ -436,12 +451,13 @@ {-# SPECIALIZE alterFDelete :: [BS.ByteString] -> HM.HashMap BS.ByteString Int -> HM.HashMap BS.ByteString Int #-} -isSubmapOfNaive :: (Eq k, Hashable k) => HM.HashMap k Int -> HM.HashMap k Int -> Bool +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 @@ -462,17 +478,19 @@ {-# 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 :: (Eq k, Hashable k, Ord k) => [k] -> IHM.Map k Int -> Int +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 :: (Eq k, Hashable k, Ord k) => [(k, Int)] -> IHM.Map k 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 @@ -480,13 +498,15 @@ {-# SPECIALIZE insertIHM :: [(BS.ByteString, Int)] -> IHM.Map BS.ByteString Int -> IHM.Map BS.ByteString Int #-} -deleteIHM :: (Eq k, Hashable k, Ord k) => [k] -> IHM.Map k Int -> IHM.Map k 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 @@ -498,3 +518,4 @@ deleteIM :: [Int] -> IM.IntMap Int -> IM.IntMap Int deleteIM xs m0 = foldl' (\m k -> IM.delete k m) m0 xs +#endif diff --git a/benchmarks/FineGrained.hs b/benchmarks/FineGrained.hs new file mode 100644 --- /dev/null +++ b/benchmarks/FineGrained.hs @@ -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 diff --git a/benchmarks/Key/Bytes.hs b/benchmarks/Key/Bytes.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Key/Bytes.hs @@ -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 +-} diff --git a/benchmarks/Util/ByteString.hs b/benchmarks/Util/ByteString.hs --- a/benchmarks/Util/ByteString.hs +++ b/benchmarks/Util/ByteString.hs @@ -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. diff --git a/tests/HashMapProperties.hs b/tests/HashMapProperties.hs deleted file mode 100644 --- a/tests/HashMapProperties.hs +++ /dev/null @@ -1,591 +0,0 @@ -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v) - --- | 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 Control.Monad ( guard ) -import qualified Data.Foldable as Foldable -#if MIN_VERSION_base(4,10,0) -import Data.Bifoldable -#endif -import Data.Function (on) -import Data.Hashable (Hashable(hashWithSalt)) -import qualified Data.List as L -import Data.Ord (comparing) -#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 -import Test.QuickCheck (Arbitrary(..), Property, (==>), (===), forAll, elements) -import Test.Framework (Test, defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity (..)) -#endif -import Control.Applicative (Const (..)) -import Test.QuickCheck.Function (Fun, apply) -import Test.QuickCheck.Poly (A, B) - --- Key type that generates more hash collisions. -newtype Key = K { unK :: Int } - deriving (Arbitrary, Eq, Ord, Read, Show) - -instance Hashable Key where - hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20 - -instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where - arbitrary = fmap (HM.fromList) arbitrary - ------------------------------------------------------------------------- --- * Properties - ------------------------------------------------------------------------- --- ** Instances - -pEq :: [(Key, Int)] -> [(Key, Int)] -> Bool -pEq xs = (M.fromList xs ==) `eq` (HM.fromList xs ==) - -pNeq :: [(Key, Int)] -> [(Key, Int)] -> Bool -pNeq xs = (M.fromList xs /=) `eq` (HM.fromList xs /=) - --- We cannot compare to `Data.Map` as ordering is different. -pOrd1 :: [(Key, Int)] -> Bool -pOrd1 xs = compare x x == EQ - where - x = HM.fromList xs - -pOrd2 :: [(Key, Int)] -> [(Key, Int)] -> [(Key, Int)] -> Bool -pOrd2 xs ys zs = case (compare x y, compare y z) of - (EQ, o) -> compare x z == o - (o, EQ) -> compare x z == o - (LT, LT) -> compare x z == LT - (GT, GT) -> compare x z == GT - (LT, GT) -> True -- ys greater than xs and zs. - (GT, LT) -> True - where - x = HM.fromList xs - y = HM.fromList ys - z = HM.fromList zs - -pOrd3 :: [(Key, Int)] -> [(Key, Int)] -> Bool -pOrd3 xs ys = case (compare x y, compare y x) of - (EQ, EQ) -> True - (LT, GT) -> True - (GT, LT) -> True - _ -> False - where - x = HM.fromList xs - y = HM.fromList ys - -pOrdEq :: [(Key, Int)] -> [(Key, Int)] -> Bool -pOrdEq xs ys = case (compare x y, x == y) of - (EQ, True) -> True - (LT, False) -> True - (GT, False) -> True - _ -> False - where - x = HM.fromList xs - y = HM.fromList ys - -pReadShow :: [(Key, Int)] -> Bool -pReadShow xs = M.fromList xs == read (show (M.fromList xs)) - -pFunctor :: [(Key, Int)] -> Bool -pFunctor = fmap (+ 1) `eq_` fmap (+ 1) - -pFoldable :: [(Int, Int)] -> Bool -pFoldable = (L.sort . Foldable.foldr (:) []) `eq` - (L.sort . Foldable.foldr (:) []) - -pHashable :: [(Key, Int)] -> [Int] -> Int -> Property -pHashable xs is salt = - x == y ==> hashWithSalt salt x === hashWithSalt salt y - where - xs' = L.nubBy (\(k,_) (k',_) -> k == k') xs - ys = shuffle is xs' - x = HM.fromList xs' - y = HM.fromList ys - -- Shuffle the list using indexes in the second - shuffle :: [Int] -> [a] -> [a] - shuffle idxs = L.map snd - . L.sortBy (comparing fst) - . L.zip (idxs ++ [L.maximum (0:is) + 1 ..]) - ------------------------------------------------------------------------- --- ** Basic interface - -pSize :: [(Key, Int)] -> Bool -pSize = M.size `eq` HM.size - -pMember :: Key -> [(Key, Int)] -> Bool -pMember k = M.member k `eq` HM.member k - -pLookup :: Key -> [(Key, Int)] -> Bool -pLookup k = M.lookup k `eq` HM.lookup k - -pLookupOperator :: Key -> [(Key, Int)] -> Bool -pLookupOperator k = M.lookup k `eq` (HM.!? k) - -pInsert :: Key -> Int -> [(Key, Int)] -> Bool -pInsert k v = M.insert k v `eq_` HM.insert k v - -pDelete :: Key -> [(Key, Int)] -> Bool -pDelete k = M.delete k `eq_` HM.delete k - -newtype AlwaysCollide = AC Int - deriving (Arbitrary, Eq, Ord, Show) - -instance Hashable AlwaysCollide where - hashWithSalt _ _ = 1 - --- White-box test that tests the case of deleting one of two keys from --- a map, where the keys' hash values collide. -pDeleteCollision :: AlwaysCollide -> AlwaysCollide -> AlwaysCollide -> Int - -> Property -pDeleteCollision k1 k2 k3 idx = (k1 /= k2) && (k2 /= k3) && (k1 /= k3) ==> - HM.member toKeep $ HM.delete toDelete $ - HM.fromList [(k1, 1 :: Int), (k2, 2), (k3, 3)] - where - which = idx `mod` 3 - toDelete - | which == 0 = k1 - | which == 1 = k2 - | which == 2 = k3 - | otherwise = error "Impossible" - toKeep - | which == 0 = k2 - | which == 1 = k3 - | which == 2 = k1 - | otherwise = error "Impossible" - -pInsertWith :: Key -> [(Key, Int)] -> Bool -pInsertWith k = M.insertWith (+) k 1 `eq_` HM.insertWith (+) k 1 - -pAdjust :: Key -> [(Key, Int)] -> Bool -pAdjust k = M.adjust succ k `eq_` HM.adjust succ k - -pUpdateAdjust :: Key -> [(Key, Int)] -> Bool -pUpdateAdjust k = M.update (Just . succ) k `eq_` HM.update (Just . succ) k - -pUpdateDelete :: Key -> [(Key, Int)] -> Bool -pUpdateDelete k = M.update (const Nothing) k `eq_` HM.update (const Nothing) k - -pAlterAdjust :: Key -> [(Key, Int)] -> Bool -pAlterAdjust k = M.alter (fmap succ) k `eq_` HM.alter (fmap succ) k - -pAlterInsert :: Key -> [(Key, Int)] -> Bool -pAlterInsert k = M.alter (const $ Just 3) k `eq_` HM.alter (const $ Just 3) k - -pAlterDelete :: Key -> [(Key, Int)] -> Bool -pAlterDelete k = M.alter (const Nothing) k `eq_` HM.alter (const Nothing) k - - --- We choose the list functor here because we don't fuss with --- it in alterF rules and because it has a sufficiently interesting --- structure to have a good chance of breaking if something is wrong. -pAlterF :: Key -> Fun (Maybe A) [Maybe A] -> [(Key, A)] -> Property -pAlterF k f xs = - fmap M.toAscList (M.alterF (apply f) k (M.fromList xs)) - === - fmap toAscList (HM.alterF (apply f) k (HM.fromList xs)) - -#if !MIN_VERSION_base(4,8,0) -newtype Identity a = Identity {runIdentity :: a} -instance Functor Identity where - fmap f (Identity x) = Identity (f x) -#endif - -pAlterFAdjust :: Key -> [(Key, Int)] -> Bool -pAlterFAdjust k = - runIdentity . M.alterF (Identity . fmap succ) k `eq_` - runIdentity . HM.alterF (Identity . fmap succ) k - -pAlterFInsert :: Key -> [(Key, Int)] -> Bool -pAlterFInsert k = - runIdentity . M.alterF (const . Identity . Just $ 3) k `eq_` - runIdentity . HM.alterF (const . Identity . Just $ 3) k - -pAlterFInsertWith :: Key -> Fun Int Int -> [(Key, Int)] -> Bool -pAlterFInsertWith k f = - runIdentity . M.alterF (Identity . Just . maybe 3 (apply f)) k `eq_` - runIdentity . HM.alterF (Identity . Just . maybe 3 (apply f)) k - -pAlterFDelete :: Key -> [(Key, Int)] -> Bool -pAlterFDelete k = - runIdentity . M.alterF (const (Identity Nothing)) k `eq_` - runIdentity . HM.alterF (const (Identity Nothing)) k - -pAlterFLookup :: Key - -> Fun (Maybe A) B - -> [(Key, A)] -> Bool -pAlterFLookup k f = - getConst . M.alterF (Const . apply f :: Maybe A -> Const B (Maybe A)) k - `eq` - getConst . HM.alterF (Const . apply f) k - -pSubmap :: [(Key, Int)] -> [(Key, Int)] -> Bool -pSubmap xs ys = M.isSubmapOf (M.fromList xs) (M.fromList ys) == - HM.isSubmapOf (HM.fromList xs) (HM.fromList ys) - -pSubmapReflexive :: HashMap Key Int -> Bool -pSubmapReflexive m = HM.isSubmapOf m m - -pSubmapUnion :: HashMap Key Int -> HashMap Key Int -> Bool -pSubmapUnion m1 m2 = HM.isSubmapOf m1 (HM.union m1 m2) - -pNotSubmapUnion :: HashMap Key Int -> HashMap Key Int -> Property -pNotSubmapUnion m1 m2 = not (HM.isSubmapOf m1 m2) ==> HM.isSubmapOf m1 (HM.union m1 m2) - -pSubmapDifference :: HashMap Key Int -> HashMap Key Int -> Bool -pSubmapDifference m1 m2 = HM.isSubmapOf (HM.difference m1 m2) m1 - -pNotSubmapDifference :: HashMap Key Int -> HashMap Key Int -> Property -pNotSubmapDifference m1 m2 = - not (HM.null (HM.intersection m1 m2)) ==> - not (HM.isSubmapOf m1 (HM.difference m1 m2)) - -pSubmapDelete :: HashMap Key Int -> Property -pSubmapDelete m = not (HM.null m) ==> - forAll (elements (HM.keys m)) $ \k -> - HM.isSubmapOf (HM.delete k m) m - -pNotSubmapDelete :: HashMap Key Int -> Property -pNotSubmapDelete m = - not (HM.null m) ==> - forAll (elements (HM.keys m)) $ \k -> - not (HM.isSubmapOf m (HM.delete k m)) - -pSubmapInsert :: Key -> Int -> HashMap Key Int -> Property -pSubmapInsert k v m = not (HM.member k m) ==> HM.isSubmapOf m (HM.insert k v m) - -pNotSubmapInsert :: Key -> Int -> HashMap Key Int -> Property -pNotSubmapInsert k v m = not (HM.member k m) ==> not (HM.isSubmapOf (HM.insert k v m) m) - ------------------------------------------------------------------------- --- ** Combine - -pUnion :: [(Key, Int)] -> [(Key, Int)] -> Bool -pUnion xs ys = M.union (M.fromList xs) `eq_` HM.union (HM.fromList xs) $ ys - -pUnionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool -pUnionWith xs ys = M.unionWith (-) (M.fromList xs) `eq_` - HM.unionWith (-) (HM.fromList xs) $ ys - -pUnionWithKey :: [(Key, Int)] -> [(Key, Int)] -> Bool -pUnionWithKey xs ys = M.unionWithKey go (M.fromList xs) `eq_` - HM.unionWithKey go (HM.fromList xs) $ ys - where - go :: Key -> Int -> Int -> Int - go (K k) i1 i2 = k - i1 + i2 - -pUnions :: [[(Key, Int)]] -> Bool -pUnions xss = M.toAscList (M.unions (map M.fromList xss)) == - toAscList (HM.unions (map HM.fromList xss)) - ------------------------------------------------------------------------- --- ** Transformations - -pMap :: [(Key, Int)] -> Bool -pMap = M.map (+ 1) `eq_` HM.map (+ 1) - -pTraverse :: [(Key, Int)] -> Bool -pTraverse xs = - L.sort (fmap (L.sort . M.toList) (M.traverseWithKey (\_ v -> [v + 1, v + 2]) (M.fromList (take 10 xs)))) - == L.sort (fmap (L.sort . HM.toList) (HM.traverseWithKey (\_ v -> [v + 1, v + 2]) (HM.fromList (take 10 xs)))) - ------------------------------------------------------------------------- --- ** Difference and intersection - -pDifference :: [(Key, Int)] -> [(Key, Int)] -> Bool -pDifference xs ys = M.difference (M.fromList xs) `eq_` - HM.difference (HM.fromList xs) $ ys - -pDifferenceWith :: [(Key, Int)] -> [(Key, Int)] -> Bool -pDifferenceWith xs ys = M.differenceWith f (M.fromList xs) `eq_` - HM.differenceWith f (HM.fromList xs) $ ys - where - f x y = if x == 0 then Nothing else Just (x - y) - -pIntersection :: [(Key, Int)] -> [(Key, Int)] -> Bool -pIntersection xs ys = M.intersection (M.fromList xs) `eq_` - HM.intersection (HM.fromList xs) $ ys - -pIntersectionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool -pIntersectionWith xs ys = M.intersectionWith (-) (M.fromList xs) `eq_` - HM.intersectionWith (-) (HM.fromList xs) $ ys - -pIntersectionWithKey :: [(Key, Int)] -> [(Key, Int)] -> Bool -pIntersectionWithKey xs ys = M.intersectionWithKey go (M.fromList xs) `eq_` - HM.intersectionWithKey go (HM.fromList xs) $ ys - where - go :: Key -> Int -> Int -> Int - go (K k) i1 i2 = k - i1 - i2 - ------------------------------------------------------------------------- --- ** Folds - -pFoldr :: [(Int, Int)] -> Bool -pFoldr = (L.sort . M.foldr (:) []) `eq` (L.sort . HM.foldr (:) []) - -pFoldl :: [(Int, Int)] -> Bool -pFoldl = (L.sort . M.foldl (flip (:)) []) `eq` (L.sort . HM.foldl (flip (:)) []) - -#if MIN_VERSION_base(4,10,0) -pBifoldMap :: [(Int, Int)] -> Bool -pBifoldMap xs = concatMap f (HM.toList m) == bifoldMap (:[]) (:[]) m - where f (k, v) = [k, v] - m = HM.fromList xs - -pBifoldr :: [(Int, Int)] -> Bool -pBifoldr xs = concatMap f (HM.toList m) == bifoldr (:) (:) [] m - where f (k, v) = [k, v] - m = HM.fromList xs - -pBifoldl :: [(Int, Int)] -> Bool -pBifoldl xs = reverse (concatMap f $ HM.toList m) == bifoldl (flip (:)) (flip (:)) [] m - where f (k, v) = [k, v] - m = HM.fromList xs -#endif - -pFoldrWithKey :: [(Int, Int)] -> Bool -pFoldrWithKey = (sortByKey . M.foldrWithKey f []) `eq` - (sortByKey . HM.foldrWithKey f []) - where f k v z = (k, v) : z - -pFoldMapWithKey :: [(Int, Int)] -> Bool -pFoldMapWithKey = (sortByKey . M.foldMapWithKey f) `eq` - (sortByKey . HM.foldMapWithKey f) - where f k v = [(k, v)] - -pFoldrWithKey' :: [(Int, Int)] -> Bool -pFoldrWithKey' = (sortByKey . M.foldrWithKey' f []) `eq` - (sortByKey . HM.foldrWithKey' f []) - where f k v z = (k, v) : z - -pFoldlWithKey :: [(Int, Int)] -> Bool -pFoldlWithKey = (sortByKey . M.foldlWithKey f []) `eq` - (sortByKey . HM.foldlWithKey f []) - where f z k v = (k, v) : z - -pFoldlWithKey' :: [(Int, Int)] -> Bool -pFoldlWithKey' = (sortByKey . M.foldlWithKey' f []) `eq` - (sortByKey . HM.foldlWithKey' f []) - where f z k v = (k, v) : z - -pFoldl' :: [(Int, Int)] -> Bool -pFoldl' = (L.sort . M.foldl' (flip (:)) []) `eq` (L.sort . HM.foldl' (flip (:)) []) - -pFoldr' :: [(Int, Int)] -> Bool -pFoldr' = (L.sort . M.foldr' (:) []) `eq` (L.sort . HM.foldr' (:) []) - ------------------------------------------------------------------------- --- ** Filter - -pMapMaybeWithKey :: [(Key, Int)] -> Bool -pMapMaybeWithKey = M.mapMaybeWithKey f `eq_` HM.mapMaybeWithKey f - where f k v = guard (odd (unK k + v)) >> Just (v + 1) - -pMapMaybe :: [(Key, Int)] -> Bool -pMapMaybe = M.mapMaybe f `eq_` HM.mapMaybe f - where f v = guard (odd v) >> Just (v + 1) - -pFilter :: [(Key, Int)] -> Bool -pFilter = M.filter odd `eq_` HM.filter odd - -pFilterWithKey :: [(Key, Int)] -> Bool -pFilterWithKey = M.filterWithKey p `eq_` HM.filterWithKey p - where p k v = odd (unK k + v) - ------------------------------------------------------------------------- --- ** Conversions - --- 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) - --- 'eq_' already calls fromList. -pFromList :: [(Key, Int)] -> Bool -pFromList = id `eq_` id - -pFromListWith :: [(Key, Int)] -> Bool -pFromListWith kvs = (M.toAscList $ M.fromListWith Op kvsM) == - (toAscList $ HM.fromListWith Op kvsM) - where kvsM = fmap (fmap Leaf) kvs - -pFromListWithKey :: [(Key, Int)] -> Bool -pFromListWithKey kvs = (M.toAscList $ M.fromListWithKey combine kvsM) == - (toAscList $ HM.fromListWithKey combine kvsM) - where kvsM = fmap (\(K k,v) -> (Leaf k, Leaf v)) kvs - combine k v1 v2 = Op k (Op v1 v2) - -pToList :: [(Key, Int)] -> Bool -pToList = M.toAscList `eq` toAscList - -pElems :: [(Key, Int)] -> Bool -pElems = (L.sort . M.elems) `eq` (L.sort . HM.elems) - -pKeys :: [(Key, Int)] -> Bool -pKeys = (L.sort . M.keys) `eq` (L.sort . HM.keys) - ------------------------------------------------------------------------- --- * Test list - -tests :: [Test] -tests = - [ - -- Instances - testGroup "instances" - [ testProperty "==" pEq - , testProperty "/=" pNeq - , testProperty "compare reflexive" pOrd1 - , testProperty "compare transitive" pOrd2 - , testProperty "compare antisymmetric" pOrd3 - , testProperty "Ord => Eq" pOrdEq - , testProperty "Read/Show" pReadShow - , testProperty "Functor" pFunctor - , testProperty "Foldable" pFoldable - , testProperty "Hashable" pHashable - ] - -- Basic interface - , testGroup "basic interface" - [ testProperty "size" pSize - , testProperty "member" pMember - , testProperty "lookup" pLookup - , testProperty "!?" pLookupOperator - , testProperty "insert" pInsert - , testProperty "delete" pDelete - , testProperty "deleteCollision" pDeleteCollision - , testProperty "insertWith" pInsertWith - , testProperty "adjust" pAdjust - , testProperty "updateAdjust" pUpdateAdjust - , testProperty "updateDelete" pUpdateDelete - , testProperty "alterAdjust" pAlterAdjust - , testProperty "alterInsert" pAlterInsert - , testProperty "alterDelete" pAlterDelete - , testProperty "alterF" pAlterF - , testProperty "alterFAdjust" pAlterFAdjust - , testProperty "alterFInsert" pAlterFInsert - , testProperty "alterFInsertWith" pAlterFInsertWith - , testProperty "alterFDelete" pAlterFDelete - , testProperty "alterFLookup" pAlterFLookup - , testGroup "isSubmapOf" - [ testProperty "container compatibility" pSubmap - , testProperty "m ⊆ m" pSubmapReflexive - , testProperty "m1 ⊆ m1 ∪ m2" pSubmapUnion - , testProperty "m1 ⊈ m2 ⇒ m1 ∪ m2 ⊈ m1" pNotSubmapUnion - , testProperty "m1\\m2 ⊆ m1" pSubmapDifference - , testProperty "m1 ∩ m2 ≠ ∅ ⇒ m1 ⊈ m1\\m2 " pNotSubmapDifference - , testProperty "delete k m ⊆ m" pSubmapDelete - , testProperty "m ⊈ delete k m " pNotSubmapDelete - , testProperty "k ∉ m ⇒ m ⊆ insert k v m" pSubmapInsert - , testProperty "k ∉ m ⇒ insert k v m ⊈ m" pNotSubmapInsert - ] - ] - -- Combine - , testProperty "union" pUnion - , testProperty "unionWith" pUnionWith - , testProperty "unionWithKey" pUnionWithKey - , testProperty "unions" pUnions - -- Transformations - , testProperty "map" pMap - , testProperty "traverse" pTraverse - -- Folds - , testGroup "folds" - [ testProperty "foldr" pFoldr - , testProperty "foldl" pFoldl -#if MIN_VERSION_base(4,10,0) - , testProperty "bifoldMap" pBifoldMap - , testProperty "bifoldr" pBifoldr - , testProperty "bifoldl" pBifoldl -#endif - , testProperty "foldrWithKey" pFoldrWithKey - , testProperty "foldlWithKey" pFoldlWithKey - , testProperty "foldrWithKey'" pFoldrWithKey' - , testProperty "foldlWithKey'" pFoldlWithKey' - , testProperty "foldl'" pFoldl' - , testProperty "foldr'" pFoldr' - , testProperty "foldMapWithKey" pFoldMapWithKey - ] - , testGroup "difference and intersection" - [ testProperty "difference" pDifference - , testProperty "differenceWith" pDifferenceWith - , testProperty "intersection" pIntersection - , testProperty "intersectionWith" pIntersectionWith - , testProperty "intersectionWithKey" pIntersectionWithKey - ] - -- Filter - , testGroup "filter" - [ testProperty "filter" pFilter - , testProperty "filterWithKey" pFilterWithKey - , testProperty "mapMaybe" pMapMaybe - , testProperty "mapMaybeWithKey" pMapMaybeWithKey - ] - -- Conversions - , testGroup "conversions" - [ testProperty "elems" pElems - , testProperty "keys" pKeys - , testProperty "fromList" pFromList - , testProperty "fromListWith" pFromListWith - , testProperty "fromListWithKey" pFromListWithKey - , testProperty "toList" pToList - ] - ] - ------------------------------------------------------------------------- --- * Model - -type Model k v = M.Map k v - --- | Check that a function operating on a 'HashMap' is equivalent to --- one operating on a 'Model'. -eq :: (Eq a, Eq k, Hashable k, Ord k) - => (Model k v -> a) -- ^ Function that modifies a 'Model' - -> (HM.HashMap k v -> a) -- ^ Function that modified a 'HashMap' in the same - -- way - -> [(k, v)] -- ^ Initial content of the 'HashMap' and 'Model' - -> Bool -- ^ True if the functions are equivalent -eq f g xs = g (HM.fromList xs) == f (M.fromList xs) - -infix 4 `eq` - -eq_ :: (Eq k, Eq v, Hashable k, Ord k) - => (Model k v -> Model k v) -- ^ Function that modifies a 'Model' - -> (HM.HashMap k v -> HM.HashMap k v) -- ^ Function that modified a - -- 'HashMap' in the same way - -> [(k, v)] -- ^ Initial content of the 'HashMap' - -- and 'Model' - -> Bool -- ^ True if the functions are - -- equivalent -eq_ f g = (M.toAscList . f) `eq` (toAscList . g) - -infix 4 `eq_` - ------------------------------------------------------------------------- --- * Test harness - -main :: IO () -main = defaultMain tests - ------------------------------------------------------------------------- --- * Helpers - -sortByKey :: Ord k => [(k, v)] -> [(k, v)] -sortByKey = L.sortBy (compare `on` fst) - -toAscList :: Ord k => HM.HashMap k v -> [(k, v)] -toAscList = L.sortBy (compare `on` fst) . HM.toList diff --git a/tests/HashSetProperties.hs b/tests/HashSetProperties.hs deleted file mode 100644 --- a/tests/HashSetProperties.hs +++ /dev/null @@ -1,248 +0,0 @@ -{-# LANGUAGE CPP, 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(hashWithSalt)) -import qualified Data.List as L -import qualified Data.HashSet as S -import qualified Data.Set as Set -import Data.Ord (comparing) -import Test.QuickCheck (Arbitrary, Property, (==>), (===)) -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, Enum, Eq, Integral, Num, Ord, Read, Show, Real) - -instance Hashable Key where - hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20 - ------------------------------------------------------------------------- --- * Properties - ------------------------------------------------------------------------- --- ** Instances - -pEq :: [Key] -> [Key] -> Bool -pEq xs = (Set.fromList xs ==) `eq` (S.fromList xs ==) - -pNeq :: [Key] -> [Key] -> Bool -pNeq xs = (Set.fromList xs /=) `eq` (S.fromList xs /=) - --- We cannot compare to `Data.Map` as ordering is different. -pOrd1 :: [Key] -> Bool -pOrd1 xs = compare x x == EQ - where - x = S.fromList xs - -pOrd2 :: [Key] -> [Key] -> [Key] -> Bool -pOrd2 xs ys zs = case (compare x y, compare y z) of - (EQ, o) -> compare x z == o - (o, EQ) -> compare x z == o - (LT, LT) -> compare x z == LT - (GT, GT) -> compare x z == GT - (LT, GT) -> True -- ys greater than xs and zs. - (GT, LT) -> True - where - x = S.fromList xs - y = S.fromList ys - z = S.fromList zs - -pOrd3 :: [Key] -> [Key] -> Bool -pOrd3 xs ys = case (compare x y, compare y x) of - (EQ, EQ) -> True - (LT, GT) -> True - (GT, LT) -> True - _ -> False - where - x = S.fromList xs - y = S.fromList ys - -pOrdEq :: [Key] -> [Key] -> Bool -pOrdEq xs ys = case (compare x y, x == y) of - (EQ, True) -> True - (LT, False) -> True - (GT, False) -> True - _ -> False - where - x = S.fromList xs - y = S.fromList ys - -pReadShow :: [Key] -> Bool -pReadShow xs = Set.fromList xs == read (show (Set.fromList xs)) - -pFoldable :: [Int] -> Bool -pFoldable = (L.sort . Foldable.foldr (:) []) `eq` - (L.sort . Foldable.foldr (:) []) - -pPermutationEq :: [Key] -> [Int] -> Bool -pPermutationEq xs is = S.fromList xs == S.fromList ys - where - ys = shuffle is xs - shuffle idxs = L.map snd - . L.sortBy (comparing fst) - . L.zip (idxs ++ [L.maximum (0:is) + 1 ..]) - -pHashable :: [Key] -> [Int] -> Int -> Property -pHashable xs is salt = - x == y ==> hashWithSalt salt x === hashWithSalt salt y - where - xs' = L.nub xs - ys = shuffle is xs' - x = S.fromList xs' - y = S.fromList ys - shuffle idxs = L.map snd - . L.sortBy (comparing fst) - . L.zip (idxs ++ [L.maximum (0:is) + 1 ..]) - ------------------------------------------------------------------------- --- ** Basic interface - -pSize :: [Key] -> Bool -pSize = Set.size `eq` S.size - -pMember :: Key -> [Key] -> Bool -pMember k = Set.member k `eq` S.member k - -pInsert :: Key -> [Key] -> Bool -pInsert a = Set.insert a `eq_` S.insert a - -pDelete :: Key -> [Key] -> Bool -pDelete a = Set.delete a `eq_` S.delete a - ------------------------------------------------------------------------- --- ** Combine - -pUnion :: [Key] -> [Key] -> Bool -pUnion xs ys = Set.union (Set.fromList xs) `eq_` - S.union (S.fromList xs) $ ys - ------------------------------------------------------------------------- --- ** Transformations - -pMap :: [Key] -> Bool -pMap = Set.map (+ 1) `eq_` S.map (+ 1) - ------------------------------------------------------------------------- --- ** Folds - -pFoldr :: [Int] -> Bool -pFoldr = (L.sort . foldrSet (:) []) `eq` - (L.sort . S.foldr (:) []) - -foldrSet :: (a -> b -> b) -> b -> Set.Set a -> b -#if MIN_VERSION_containers(0,4,2) -foldrSet = Set.foldr -#else -foldrSet = Foldable.foldr -#endif - -pFoldl' :: Int -> [Int] -> Bool -pFoldl' z0 = foldl'Set (+) z0 `eq` S.foldl' (+) z0 - -foldl'Set :: (a -> b -> a) -> a -> Set.Set b -> a -#if MIN_VERSION_containers(0,4,2) -foldl'Set = Set.foldl' -#else -foldl'Set = Foldable.foldl' -#endif - ------------------------------------------------------------------------- --- ** Filter - -pFilter :: [Key] -> Bool -pFilter = Set.filter odd `eq_` S.filter odd - ------------------------------------------------------------------------- --- ** Conversions - -pToList :: [Key] -> Bool -pToList = Set.toAscList `eq` toAscList - ------------------------------------------------------------------------- --- * Test list - -tests :: [Test] -tests = - [ - -- Instances - testGroup "instances" - [ testProperty "==" pEq - , testProperty "Permutation ==" pPermutationEq - , testProperty "/=" pNeq - , testProperty "compare reflexive" pOrd1 - , testProperty "compare transitive" pOrd2 - , testProperty "compare antisymmetric" pOrd3 - , testProperty "Ord => Eq" pOrdEq - , testProperty "Read/Show" pReadShow - , testProperty "Foldable" pFoldable - , testProperty "Hashable" pHashable - ] - -- Basic interface - , testGroup "basic interface" - [ testProperty "size" pSize - , testProperty "member" pMember - , testProperty "insert" pInsert - , testProperty "delete" pDelete - ] - -- Combine - , testProperty "union" pUnion - -- Transformations - , testProperty "map" pMap - -- Folds - , testGroup "folds" - [ testProperty "foldr" pFoldr - , testProperty "foldl'" pFoldl' - ] - -- Filter - , testGroup "filter" - [ testProperty "filter" pFilter - ] - -- Conversions - , testGroup "conversions" - [ testProperty "toList" pToList - ] - ] - ------------------------------------------------------------------------- --- * Model - --- Invariant: the list is sorted in ascending order, by key. -type Model a = Set.Set a - --- | Check that a function operating on a 'HashMap' is equivalent to --- one operating on a 'Model'. -eq :: (Eq a, Hashable a, Ord a, Eq b) - => (Model a -> b) -- ^ Function that modifies a 'Model' in the same - -- way - -> (S.HashSet a -> b) -- ^ Function that modified a 'HashSet' - -> [a] -- ^ Initial content of the 'HashSet' and 'Model' - -> Bool -- ^ True if the functions are equivalent -eq f g xs = g (S.fromList xs) == f (Set.fromList xs) - -eq_ :: (Eq a, Hashable a, Ord a) - => (Model a -> Model a) -- ^ Function that modifies a 'Model' - -> (S.HashSet a -> S.HashSet a) -- ^ Function that modified a - -- 'HashSet' in the same way - -> [a] -- ^ Initial content of the 'HashSet' - -- and 'Model' - -> Bool -- ^ True if the functions are - -- equivalent -eq_ f g = (Set.toAscList . f) `eq` (toAscList . g) - ------------------------------------------------------------------------- --- * Test harness - -main :: IO () -main = defaultMain tests - ------------------------------------------------------------------------- --- * Helpers - -toAscList :: Ord a => S.HashSet a -> [a] -toAscList = L.sort . S.toList diff --git a/tests/List.hs b/tests/List.hs deleted file mode 100644 --- a/tests/List.hs +++ /dev/null @@ -1,68 +0,0 @@ -module Main (main) where - -import Data.HashMap.Internal.List -import Data.List (nub, sort, sortBy) -import Data.Ord (comparing) - -import Test.Framework (Test, defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck ((==>), (===), property, Property) - -tests :: Test -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 - -main :: IO () -main = defaultMain [tests] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 + ] diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -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 + ] diff --git a/tests/Properties/HashMapLazy.hs b/tests/Properties/HashMapLazy.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/HashMapLazy.hs @@ -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)) + ] diff --git a/tests/Properties/HashMapStrict.hs b/tests/Properties/HashMapStrict.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/HashMapStrict.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +#define STRICT + +#include "HashMapLazy.hs" diff --git a/tests/Properties/HashSet.hs b/tests/Properties/HashSet.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/HashSet.hs @@ -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) + ] diff --git a/tests/Properties/List.hs b/tests/Properties/List.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/List.hs @@ -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 diff --git a/tests/Regressions.hs b/tests/Regressions.hs --- a/tests/Regressions.hs +++ b/tests/Regressions.hs @@ -1,33 +1,44 @@ +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -module Main where +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -Wno-x-partial #-} +module Regressions (tests) where -import Control.Applicative ((<$>)) -import Control.Exception (evaluate) -import Control.Monad (replicateM) -import Data.Hashable (Hashable(..)) -import qualified Data.HashMap.Strict as HM -import qualified Data.HashMap.Lazy as HML -import Data.List (delete) -import Data.Maybe -import GHC.Exts (touch#) -import GHC.IO (IO (..)) -import System.Mem (performGC) -import System.Mem.Weak (mkWeakPtr, deRefWeak) -import System.Random (randomIO) -import Test.HUnit (Assertion, assert) -import Test.Framework (Test, defaultMain) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) +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 $ HM.lookup 7 m' +issue32 = assert $ isJust $ HMS.lookup 7 m' where ns = [0..16] :: [Int] - m = HM.fromList (zip ns (repeat [])) - m' = HM.delete 10 m + m = HMS.fromList (zip ns (repeat [])) + m' = HMS.delete 10 m ------------------------------------------------------------------------ -- Issue #39 @@ -37,8 +48,8 @@ issue39 :: Assertion issue39 = assert $ hm1 == hm2 where - hm1 = HM.fromList ([a, b] `zip` [1, 1 :: Int ..]) - hm2 = HM.fromList ([b, a] `zip` [1, 1 :: Int ..]) + 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) @@ -77,10 +88,10 @@ propEqAfterDelete (Keys keys) = let keyMap = mapFromKeys keys k = head keys - in HM.delete k keyMap == mapFromKeys (delete k keys) + in HMS.delete k keyMap == mapFromKeys (delete k keys) -mapFromKeys :: [Int] -> HM.HashMap Int () -mapFromKeys keys = HM.fromList (zip keys (repeat ())) +mapFromKeys :: [Int] -> HMS.HashMap Int () +mapFromKeys keys = HMS.fromList (zip keys (repeat ())) ------------------------------------------------------------------------ -- Issue #254 @@ -118,27 +129,161 @@ i :: Int <- randomIO let oldV = show i weakV <- mkWeakPtr oldV Nothing - mp <- evaluate $ HM.insert (KC 1) "3" $ HM.fromList [(KC 0, "1"), (KC 1, oldV)] + 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 :: [Test] -tests = +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 ] - ------------------------------------------------------------------------- --- * Test harness - -main :: IO () -main = defaultMain tests diff --git a/tests/Strictness.hs b/tests/Strictness.hs --- a/tests/Strictness.hs +++ b/tests/Strictness.hs @@ -1,44 +1,29 @@ -{-# LANGUAGE CPP, FlexibleInstances, GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v) -module Main (main) where +module Strictness (tests) where -import Data.Hashable (Hashable(hashWithSalt)) +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.Framework (Test, defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Arbitrary(arbitrary), Property, (===), (.&&.)) +import Test.QuickCheck (Arbitrary (..), Property, (.&&.), (===)) import Test.QuickCheck.Function -import Test.QuickCheck.Poly (A) -import Data.Maybe (fromMaybe, isJust) -import Control.Arrow (second) -import Control.Monad (guard) -import Data.Foldable (foldl') -#if !MIN_VERSION_base(4,8,0) -import Data.Functor ((<$)) -import Data.Foldable (all) -import Prelude hiding (all) -#endif - -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM - --- Key type that generates more hash collisions. -newtype Key = K { unK :: Int } - deriving (Arbitrary, Eq, Ord, Show) - -instance Hashable Key where - hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20 +import Test.QuickCheck.Poly (A) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Text.Show.Functions () +import Util.Key (Key) -instance (Arbitrary k, Arbitrary v, Eq k, Hashable k) => - Arbitrary (HashMap k v) where - arbitrary = HM.fromList `fmap` arbitrary +import Prelude hiding (Foldable (..)) -instance Show (Int -> Int) where - show _ = "" +import qualified Data.HashMap.Strict as HM -instance Show (Int -> Int -> Int) where - show _ = "" +instance (Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where + arbitrary = HM.fromList <$> arbitrary + shrink = fmap HM.fromList . shrink . HM.toList ------------------------------------------------------------------------ -- * Properties @@ -50,7 +35,7 @@ pSingletonKeyStrict v = isBottom $ HM.singleton (bottom :: Key) v pSingletonValueStrict :: Key -> Bool -pSingletonValueStrict k = isBottom $ (HM.singleton k (bottom :: Int)) +pSingletonValueStrict k = isBottom $ HM.singleton k (bottom :: Int) pLookupDefaultKeyStrict :: Int -> HashMap Key Int -> Bool pLookupDefaultKeyStrict def m = isBottom $ HM.lookupDefault def bottom m @@ -86,8 +71,8 @@ pFromListKeyStrict :: Bool pFromListKeyStrict = isBottom $ HM.fromList [(undefined :: Key, 1 :: Int)] -pFromListValueStrict :: Bool -pFromListValueStrict = isBottom $ HM.fromList [(K 1, undefined)] +pFromListValueStrict :: Key -> Bool +pFromListValueStrict k = isBottom $ HM.fromList [(k, undefined)] pFromListWithKeyStrict :: (Int -> Int -> Int) -> Bool pFromListWithKeyStrict f = @@ -115,7 +100,7 @@ -- argument, just the first argument, just the second argument, -- or both arguments are bottom. It would be quite tempting to -- just use Maybe A -> Maybe A -> Maybe A, but that would not --- necessarily be continous. +-- necessarily be continuous. pFromListWithValueResultStrict :: [(Key, Maybe A)] -> Fun (Maybe A, Maybe A) A -> Fun (Maybe A, Maybe A) Bool @@ -154,8 +139,8 @@ ------------------------------------------------------------------------ -- * Test list -tests :: [Test] -tests = +tests :: TestTree +tests = testGroup "Strictness" [ -- Basic interface testGroup "HashMap.Strict" @@ -179,12 +164,6 @@ , testProperty "fromListWith is value-strict" pFromListWithValueResultStrict ] ] - ------------------------------------------------------------------------- --- * Test harness - -main :: IO () -main = defaultMain tests ------------------------------------------------------------------------ -- * Utilities diff --git a/tests/Util/Key.hs b/tests/Util/Key.hs new file mode 100644 --- /dev/null +++ b/tests/Util/Key.hs @@ -0,0 +1,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) diff --git a/unordered-containers.cabal b/unordered-containers.cabal --- a/unordered-containers.cabal +++ b/unordered-containers.cabal @@ -1,5 +1,5 @@ name: unordered-containers -version: 0.2.13.0 +version: 0.2.21 synopsis: Efficient hashing-based container types description: Efficient hashing-based container types. The containers have been @@ -8,10 +8,17 @@ . 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 -maintainer: johan.tibell@gmail.com, David.Feuer@gmail.com +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 @@ -22,14 +29,14 @@ extra-source-files: CHANGES.md tested-with: - GHC ==8.10.1 - || ==8.8.3 - || ==8.6.5 - || ==8.4.4 - || ==8.2.2 - || ==8.0.2 - || ==7.10.3 - || ==7.8.4 + 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 @@ -39,18 +46,21 @@ exposed-modules: Data.HashMap.Internal Data.HashMap.Internal.Array + Data.HashMap.Internal.Debug Data.HashMap.Internal.List Data.HashMap.Internal.Strict - Data.HashMap.Internal.Unsafe Data.HashMap.Lazy Data.HashMap.Strict Data.HashSet Data.HashSet.Internal build-depends: - base >= 4.7 && < 5, - deepseq >= 1.1, - hashable >= 1.0.1.1 && < 1.4 + base >= 4.14 && < 5, + deepseq >= 1.4.3, + hashable >= 1.4 && < 1.6 + if impl(ghc) + build-depends: + template-haskell >= 2.16 && < 2.24 default-language: Haskell2010 @@ -63,149 +73,85 @@ ghc-options: -Wall -O2 -fwarn-tabs -ferror-spans - if impl (ghc < 8.2) - -- This is absolutely necessary (but not sufficient) for correctness due to - -- the referential-transparency-breaking mutability in unsafeInsertWith. See - -- #147 and GHC #13615 for details. The bug was fixed in GHC 8.2. - ghc-options: -feager-blackholing if flag(debug) cpp-options: -DASSERTS -test-suite hashmap-lazy-properties +test-suite unordered-containers-tests hs-source-dirs: tests - main-is: HashMapProperties.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, + ChasingBottoms, containers >= 0.5.8, - hashable >= 1.0.1.1, + 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 default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N cpp-options: -DASSERTS -test-suite hashmap-strict-properties - hs-source-dirs: tests - main-is: HashMapProperties.hs - type: exitcode-stdio-1.0 - - build-depends: - base, - containers >= 0.5.8, - hashable >= 1.0.1.1, - QuickCheck >= 2.4.0.1, - test-framework >= 0.3.3, - test-framework-quickcheck2 >= 0.2.9, - unordered-containers - - default-language: Haskell2010 - ghc-options: -Wall - cpp-options: -DASSERTS -DSTRICT - -test-suite hashset-properties - hs-source-dirs: tests - main-is: HashSetProperties.hs +benchmark package-comparisons + hs-source-dirs: benchmarks + main-is: Benchmarks.hs type: exitcode-stdio-1.0 - build-depends: - base, - containers >= 0.4, - hashable >= 1.0.1.1, - QuickCheck >= 2.4.0.1, - test-framework >= 0.3.3, - test-framework-quickcheck2 >= 0.2.9, - unordered-containers - - default-language: Haskell2010 - ghc-options: -Wall - cpp-options: -DASSERTS - -test-suite list-tests - hs-source-dirs: tests . - main-is: List.hs other-modules: - Data.HashMap.Internal.List - type: exitcode-stdio-1.0 - - build-depends: - base, - containers >= 0.4, - QuickCheck >= 2.4.0.1, - test-framework >= 0.3.3, - test-framework-quickcheck2 >= 0.2.9 - - default-language: Haskell2010 - ghc-options: -Wall - cpp-options: -DASSERTS - -test-suite regressions - hs-source-dirs: tests - main-is: Regressions.hs - type: exitcode-stdio-1.0 + Util.ByteString + Util.String + Util.Int build-depends: - base, - hashable >= 1.0.1.1, - HUnit, - QuickCheck >= 2.4.0.1, + base >= 4.8.0, + bytestring >= 0.10.0.0, + containers, + deepseq, + hashable, + hashmap, random, - test-framework >= 0.3.3, - test-framework-hunit, - test-framework-quickcheck2, - unordered-containers - - default-language: Haskell2010 - ghc-options: -Wall - cpp-options: -DASSERTS - -test-suite strictness-properties - hs-source-dirs: tests - main-is: Strictness.hs - type: exitcode-stdio-1.0 - - build-depends: - base, - ChasingBottoms, - containers >= 0.4.2, - hashable >= 1.0.1.1, - QuickCheck >= 2.4.0.1, - test-framework >= 0.3.3, - test-framework-quickcheck2 >= 0.2.9, + tasty-bench >= 0.3.1, unordered-containers default-language: Haskell2010 - ghc-options: -Wall - cpp-options: -DASSERTS + ghc-options: -Wall -O2 -rtsopts "-with-rtsopts=-A32m" -fproc-alignment=64 + -- cpp-options: -DBENCH_containers_Map -DBENCH_containers_IntMap -DBENCH_hashmap_Map -benchmark benchmarks +benchmark fine-grained hs-source-dirs: benchmarks - main-is: Benchmarks.hs + main-is: FineGrained.hs type: exitcode-stdio-1.0 other-modules: - Util.ByteString - Util.String - Util.Int + Key.Bytes build-depends: - base >= 4.8.0, - bytestring, - containers, - gauge >= 0.2.5 && < 0.3, - deepseq >= 1.4, - hashable >= 1.0.1.1, - hashmap, - mtl, + base, + bytestring >= 0.11.3, + deepseq, + hashable, random, + tasty-bench, unordered-containers default-language: Haskell2010 - ghc-options: -Wall -O2 -rtsopts -fwarn-tabs -ferror-spans + ghc-options: -Wall -O2 -rtsopts "-with-rtsopts=-A64m" -fproc-alignment=64 source-repository head type: git