diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,25 @@ +## [0.2.12.0] + +* Add `HashMap.isSubmapOf[By]` and `HashSet.isSubsetOf`. Thanks Sven Keidel. ([#282]) + +* Expose internal modules. ([#283]) + +* Documentation improvements in `Data.HashSet`, including a beginner-friendly + introduction. Thanks Matt Renaud. ([#267]) + +* `HashMap[.Strict].alterF`: Skip key deletion for absent keys. ([#288]) + +* Remove custom `unsafeShift{L,R}` definitions. ([#281]) + +* Various other documentation improvements. + +[0.2.12.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.11.0...v0.2.12.0 +[#267]: https://github.com/haskell-unordered-containers/unordered-containers/pull/267 +[#281]: https://github.com/haskell-unordered-containers/unordered-containers/pull/281 +[#282]: https://github.com/haskell-unordered-containers/unordered-containers/pull/282 +[#283]: https://github.com/haskell-unordered-containers/unordered-containers/pull/283 +[#288]: https://github.com/haskell-unordered-containers/unordered-containers/pull/288 + ## 0.2.11.0 * Add `HashMap.findWithDefault` (soft-deprecates `HashMap.lookupDefault`). diff --git a/Data/HashMap/Array.hs b/Data/HashMap/Array.hs deleted file mode 100644 --- a/Data/HashMap/Array.hs +++ /dev/null @@ -1,619 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} - --- | Zero based arrays. --- --- Note that no bounds checking are performed. -module Data.HashMap.Array - ( Array - , MArray - - -- * Creation - , new - , new_ - , singleton - , singletonM - , pair - - -- * Basic interface - , length - , lengthM - , read - , write - , index - , indexM - , index# - , update - , updateWith' - , unsafeUpdateM - , insert - , insertM - , delete - , sameArray1 - , trim - - , unsafeFreeze - , unsafeThaw - , unsafeSameArray - , run - , run2 - , copy - , copyM - - -- * Folds - , foldl - , foldl' - , foldr - , foldr' - , foldMap - - , thaw - , map - , map' - , traverse - , traverse' - , toList - , fromList - ) 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) -#else -import Prelude hiding (filter, foldr, foldl, length, map, read) -#endif - -#if __GLASGOW_HASKELL__ >= 710 -import GHC.Exts (SmallArray#, newSmallArray#, readSmallArray#, writeSmallArray#, - indexSmallArray#, unsafeFreezeSmallArray#, unsafeThawSmallArray#, - SmallMutableArray#, sizeofSmallArray#, copySmallArray#, thawSmallArray#, - sizeofSmallMutableArray#, copySmallMutableArray#, cloneSmallMutableArray#) - -#else -import GHC.Exts (Array#, newArray#, readArray#, writeArray#, - indexArray#, unsafeFreezeArray#, unsafeThawArray#, - MutableArray#, sizeofArray#, copyArray#, thawArray#, - sizeofMutableArray#, copyMutableArray#, cloneMutableArray#) -import Data.Monoid (Monoid (..)) -#endif - -#if defined(ASSERTS) -import qualified Prelude -#endif - -import Data.HashMap.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! -# define CHECK_BOUNDS(_func_,_len_,_k_) \ -if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.HashMap.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.Array." ++ (_func_) ++ ": Check failed: _lhs_ _op_ _rhs_ (" ++ show (_lhs_) ++ " vs. " ++ show (_rhs_) ++ ")") else -# 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_GT(_func_,_lhs_,_rhs_) -# define CHECK_LE(_func_,_lhs_,_rhs_) -# define CHECK_EQ(_func_,_lhs_,_rhs_) -#endif - -data Array a = Array { - unArray :: !(Array# a) - } - -instance Show a => Show (Array a) where - show = show . toList - --- Determines whether two arrays have the same memory address. --- This is more reliable than testing pointer equality on the --- Array wrappers, but it's still slightly bogus. -unsafeSameArray :: Array a -> Array b -> Bool -unsafeSameArray (Array xs) (Array ys) = - tagToEnum# (unsafeCoerce# reallyUnsafePtrEquality# xs ys) - -sameArray1 :: (a -> b -> Bool) -> Array a -> Array b -> Bool -sameArray1 eq !xs0 !ys0 - | lenxs /= lenys = False - | otherwise = go 0 xs0 ys0 - where - go !k !xs !ys - | k == lenxs = True - | (# x #) <- index# xs k - , (# y #) <- index# ys k - = eq x y && go (k + 1) xs ys - - !lenxs = length xs0 - !lenys = length ys0 - -length :: Array a -> Int -length ary = I# (sizeofArray# (unArray ary)) -{-# INLINE length #-} - --- | Smart constructor -array :: Array# a -> Int -> Array a -array ary _n = Array ary -{-# INLINE array #-} - -data MArray s a = MArray { - unMArray :: !(MutableArray# s a) - } - -lengthM :: MArray s a -> Int -lengthM mary = I# (sizeofMutableArray# (unMArray mary)) -{-# INLINE lengthM #-} - --- | Smart constructor -marray :: MutableArray# s a -> Int -> MArray s a -marray mary _n = MArray mary -{-# INLINE marray #-} - ------------------------------------------------------------------------- - -instance NFData a => NFData (Array a) where - rnf = rnfArray - -rnfArray :: NFData a => Array a -> () -rnfArray ary0 = go ary0 n0 0 - where - n0 = length ary0 - go !ary !n !i - | i >= n = () - | (# x #) <- index# ary i - = rnf x `seq` go ary n (i+1) --- We use index# just in case GHC can't see that the --- relevant rnf is strict, or in case it actually isn't. -{-# INLINE rnfArray #-} - --- | Create a new mutable array of specified size, in the specified --- state thread, with each element containing the specified initial --- value. -new :: Int -> a -> ST s (MArray s a) -new n@(I# n#) b = - CHECK_GT("new",n,(0 :: Int)) - ST $ \s -> - case newArray# n# b s of - (# s', ary #) -> (# s', marray ary n #) -{-# INLINE new #-} - -new_ :: Int -> ST s (MArray s a) -new_ n = new n undefinedElem - -singleton :: a -> Array a -singleton x = runST (singletonM x) -{-# INLINE singleton #-} - -singletonM :: a -> ST s (Array a) -singletonM x = new 1 x >>= unsafeFreeze -{-# INLINE singletonM #-} - -pair :: a -> a -> Array a -pair x y = run $ do - ary <- new 2 x - write ary 1 y - return ary -{-# INLINE pair #-} - -read :: MArray s a -> Int -> ST s a -read ary _i@(I# i#) = ST $ \ s -> - CHECK_BOUNDS("read", lengthM ary, _i) - readArray# (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 - 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 #-} - -index# :: Array a -> Int -> (# a #) -index# ary _i@(I# i#) = - CHECK_BOUNDS("index#", length ary, _i) - indexArray# (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 -{-# INLINE indexM #-} - -unsafeFreeze :: MArray s a -> ST s (Array a) -unsafeFreeze mary - = ST $ \s -> case unsafeFreezeArray# (unMArray mary) s of - (# s', ary #) -> (# s', array ary (lengthM mary) #) -{-# INLINE unsafeFreeze #-} - -unsafeThaw :: Array a -> ST s (MArray s a) -unsafeThaw ary - = ST $ \s -> case unsafeThawArray# (unArray ary) s of - (# s', mary #) -> (# s', marray mary (length ary) #) -{-# INLINE unsafeThaw #-} - -run :: (forall s . ST s (MArray s e)) -> Array e -run act = runST $ act >>= unsafeFreeze -{-# INLINE run #-} - -run2 :: (forall s. ST s (MArray s e, a)) -> (Array e, a) -run2 k = runST (do - (marr,b) <- k - arr <- unsafeFreeze marr - return (arr,b)) - --- | Unsafely copy the elements of an array. Array bounds are not checked. -copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s () -copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = - CHECK_LE("copy", _sidx + _n, length src) - CHECK_LE("copy", _didx + _n, lengthM dst) - ST $ \ s# -> - case copyArray# (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) - ST $ \ s# -> - case copyMutableArray# (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) - ST $ \ s -> - case cloneMutableArray# mary# off# len# s of - (# s', mary'# #) -> (# s', MArray mary'# #) - --- | Create a new array of the @n@ first elements of @mary@. -trim :: MArray s a -> Int -> ST s (Array a) -trim mary n = cloneM mary 0 n >>= unsafeFreeze -{-# INLINE trim #-} - --- | /O(n)/ Insert an element at the given position in this array, --- increasing its size by one. -insert :: Array e -> Int -> e -> Array e -insert ary idx b = runST (insertM ary idx b) -{-# INLINE insert #-} - --- | /O(n)/ Insert an element at the given position in this array, --- increasing its size by one. -insertM :: Array e -> Int -> e -> ST s (Array e) -insertM ary idx b = - CHECK_BOUNDS("insertM", count + 1, idx) - do mary <- new_ (count+1) - 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. -update :: Array e -> Int -> e -> Array e -update ary idx b = runST (updateM ary idx b) -{-# INLINE update #-} - --- | /O(n)/ Update the element at the given position in this array. -updateM :: Array e -> Int -> e -> ST s (Array e) -updateM ary idx b = - CHECK_BOUNDS("updateM", count, idx) - do mary <- thaw ary 0 count - write mary idx b - unsafeFreeze mary - where !count = length ary -{-# INLINE updateM #-} - --- | /O(n)/ Update the element at the given positio in this array, by --- applying a function to it. Evaluates the element to WHNF before --- inserting it into the array. -updateWith' :: Array e -> Int -> (e -> e) -> Array e -updateWith' ary idx f - | (# x #) <- index# ary idx - = update ary idx $! f x -{-# INLINE updateWith' #-} - --- | /O(1)/ Update the element at the given position in this array, --- without copying. -unsafeUpdateM :: Array e -> Int -> e -> ST s () -unsafeUpdateM ary idx b = - CHECK_BOUNDS("unsafeUpdateM", length ary, idx) - do mary <- unsafeThaw ary - write mary idx b - _ <- unsafeFreeze mary - return () -{-# INLINE unsafeUpdateM #-} - -foldl' :: (b -> a -> b) -> b -> Array a -> b -foldl' f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 - where - go ary n i !z - | i >= n = z - | otherwise - = case index# ary i of - (# x #) -> go ary n (i+1) (f z x) -{-# INLINE foldl' #-} - -foldr' :: (a -> b -> b) -> b -> Array a -> b -foldr' f = \ z0 ary0 -> go ary0 (length ary0 - 1) z0 - where - go !_ary (-1) z = z - go !ary i !z - | (# x #) <- index# ary i - = go ary (i - 1) (f x z) -{-# INLINE foldr' #-} - -foldr :: (a -> b -> b) -> b -> Array a -> b -foldr f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 - where - go ary n i z - | i >= n = z - | otherwise - = case index# ary i of - (# x #) -> f x (go ary n (i+1) z) -{-# INLINE foldr #-} - -foldl :: (b -> a -> b) -> b -> Array a -> b -foldl f = \ z0 ary0 -> go ary0 (length ary0 - 1) z0 - where - go _ary (-1) z = z - go ary i z - | (# x #) <- index# ary i - = f (go ary (i - 1) z) x -{-# INLINE foldl #-} - --- We go to a bit of trouble here to avoid appending an extra mempty. --- The below implementation is by Mateusz Kowalczyk, who indicates that --- benchmarks show it to be faster than one that avoids lifting out --- lst. -foldMap :: Monoid m => (a -> m) -> Array a -> m -foldMap f = \ary0 -> case length ary0 of - 0 -> mempty - len -> - let !lst = len - 1 - go i | (# x #) <- index# ary0 i, let fx = f x = - if i == lst then fx else fx `mappend` go (i + 1) - in go 0 -{-# INLINE foldMap #-} - -undefinedElem :: a -undefinedElem = error "Data.HashMap.Array: Undefined element" -{-# NOINLINE undefinedElem #-} - -thaw :: Array e -> Int -> Int -> ST s (MArray s e) -thaw !ary !_o@(I# o#) !n@(I# n#) = - CHECK_LE("thaw", _o + n, length ary) - ST $ \ s -> case thawArray# (unArray ary) o# n# s of - (# s2, mary# #) -> (# s2, marray mary# n #) -{-# INLINE thaw #-} - --- | /O(n)/ Delete an element at the given position in this array, --- decreasing its size by one. -delete :: Array e -> Int -> Array e -delete ary idx = runST (deleteM ary idx) -{-# INLINE delete #-} - --- | /O(n)/ Delete an element at the given position in this array, --- decreasing its size by one. -deleteM :: Array e -> Int -> ST s (Array e) -deleteM ary idx = do - CHECK_BOUNDS("deleteM", count, idx) - do mary <- new_ (count-1) - copy ary 0 mary 0 idx - copy ary (idx+1) mary idx (count-(idx+1)) - unsafeFreeze mary - where !count = length ary -{-# INLINE deleteM #-} - -map :: (a -> b) -> Array a -> Array b -map f = \ ary -> - let !n = length ary - in run $ do - mary <- new_ n - go ary mary 0 n - where - go ary mary i n - | i >= n = return mary - | otherwise = do - x <- indexM ary i - write mary i $ f x - go ary mary (i+1) n -{-# INLINE map #-} - --- | Strict version of 'map'. -map' :: (a -> b) -> Array a -> Array b -map' f = \ ary -> - let !n = length ary - in run $ do - mary <- new_ n - go ary mary 0 n - where - go ary mary i n - | i >= n = return mary - | otherwise = do - x <- indexM ary i - write mary i $! f x - go ary mary (i+1) n -{-# INLINE map' #-} - -fromList :: Int -> [a] -> Array a -fromList n xs0 = - CHECK_EQ("fromList", n, Prelude.length xs0) - run $ do - mary <- new_ n - go xs0 mary 0 - where - go [] !mary !_ = return mary - go (x:xs) mary i = do write mary i x - go xs mary (i+1) - -toList :: Array a -> [a] -toList = foldr (:) [] - -newtype STA a = STA {_runSTA :: forall s. MutableArray# s a -> ST s (Array a)} - -runSTA :: Int -> STA a -> Array a -runSTA !n (STA m) = runST $ new_ n >>= \ (MArray ar) -> m ar - -traverse :: Applicative f => (a -> f b) -> Array a -> f (Array b) -traverse f = \ !ary -> - let - !len = length ary - go !i - | i == len = pure $ STA $ \mary -> unsafeFreeze (MArray mary) - | (# x #) <- index# ary i - = liftA2 (\b (STA m) -> STA $ \mary -> - write (MArray mary) i b >> m mary) - (f x) (go (i + 1)) - in runSTA len <$> go 0 -{-# INLINE [1] traverse #-} - --- TODO: Would it be better to just use a lazy traversal --- and then force the elements of the result? My guess is --- yes. -traverse' :: Applicative f => (a -> f b) -> Array a -> f (Array b) -traverse' f = \ !ary -> - let - !len = length ary - go !i - | i == len = pure $ STA $ \mary -> unsafeFreeze (MArray mary) - | (# x #) <- index# ary i - = liftA2 (\ !b (STA m) -> STA $ \mary -> - write (MArray mary) i b >> m mary) - (f x) (go (i + 1)) - in runSTA len <$> go 0 -{-# INLINE [1] traverse' #-} - --- Traversing in ST, we don't need to get fancy; we --- can just do it directly. -traverseST :: (a -> ST s b) -> Array a -> ST s (Array b) -traverseST f = \ ary0 -> - let - !len = length ary0 - go k !mary - | k == len = return mary - | otherwise = do - x <- indexM ary0 k - y <- f x - write mary k y - go (k + 1) mary - in new_ len >>= (go 0 >=> unsafeFreeze) -{-# INLINE traverseST #-} - -traverseIO :: (a -> IO b) -> Array a -> IO (Array b) -traverseIO f = \ ary0 -> - let - !len = length ary0 - go k !mary - | k == len = return mary - | otherwise = do - x <- stToIO $ indexM ary0 k - y <- f x - stToIO $ write mary k y - go (k + 1) mary - in stToIO (new_ len) >>= (go 0 >=> stToIO . unsafeFreeze) -{-# INLINE traverseIO #-} - - --- Why don't we have similar RULES for traverse'? The efficient --- way to traverse strictly in IO or ST is to force results as --- they come in, which leads to different semantics. In particular, --- we need to ensure that --- --- traverse' (\x -> print x *> pure undefined) xs --- --- will actually print all the values and then return undefined. --- We could add a strict mapMWithIndex, operating in an arbitrary --- Monad, that supported such rules, but we don't have that right now. -{-# RULES -"traverse/ST" forall f. traverse f = traverseST f -"traverse/IO" forall f. traverse f = traverseIO f - #-} diff --git a/Data/HashMap/Base.hs b/Data/HashMap/Base.hs deleted file mode 100644 --- a/Data/HashMap/Base.hs +++ /dev/null @@ -1,2132 +0,0 @@ -{-# 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 #-} - -module Data.HashMap.Base - ( - HashMap(..) - , Leaf(..) - - -- * Construction - , empty - , singleton - - -- * Basic interface - , null - , size - , member - , lookup - , (!?) - , findWithDefault - , lookupDefault - , (!) - , insert - , insertWith - , unsafeInsert - , delete - , adjust - , update - , alter - , alterF - - -- * Combine - -- ** Union - , union - , unionWith - , unionWithKey - , unions - - -- * 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) -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#) -import Prelude hiding (filter, foldl, foldr, lookup, map, null, pred) -import Text.Read hiding (step) - -import qualified Data.HashMap.Array as A -import qualified Data.Hashable as H -import Data.Hashable (Hashable) -import Data.HashMap.Unsafe (runST) -import Data.HashMap.UnsafeShift (unsafeShiftL, unsafeShiftR) -import Data.HashMap.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.Base.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 m -{-# INLINABLE lookup# #-} - -#else - -lookup k m = lookupCont (\_ -> Nothing) (\v _i -> Just v) (hash k) k 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 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 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 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. -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 -> HashMap k v -> r -lookupCont absent present !h0 !k0 !m0 = go h0 k0 0 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.10, 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.Base.(!): 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 -> delete' h k m - 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 - - ------------------------------------------------------------------------- --- * 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 #-} - ------------------------------------------------------------------------- --- * 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 #-} - ------------------------------------------------------------------------- --- 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 = fromIntegral $ 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 diff --git a/Data/HashMap/Internal.hs b/Data/HashMap/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/HashMap/Internal.hs @@ -0,0 +1,2279 @@ +{-# 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 + + -- * 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 #-} + +------------------------------------------------------------------------ +-- * 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 diff --git a/Data/HashMap/Internal/Array.hs b/Data/HashMap/Internal/Array.hs new file mode 100644 --- /dev/null +++ b/Data/HashMap/Internal/Array.hs @@ -0,0 +1,623 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | = WARNING +-- +-- This module is considered __internal__. +-- +-- The Package Versioning Policy __does not apply__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +-- +-- Authors importing this module are expected to track development +-- closely. +-- +-- = Description +-- +-- Zero based arrays. +-- +-- Note that no bounds checking are performed. +module Data.HashMap.Internal.Array + ( Array + , MArray + + -- * Creation + , new + , new_ + , singleton + , singletonM + , pair + + -- * Basic interface + , length + , lengthM + , read + , write + , index + , indexM + , index# + , update + , updateWith' + , unsafeUpdateM + , insert + , insertM + , delete + , sameArray1 + , trim + + , unsafeFreeze + , unsafeThaw + , unsafeSameArray + , run + , copy + , copyM + + -- * Folds + , foldl + , foldl' + , foldr + , foldr' + , foldMap + , all + + , thaw + , map + , map' + , traverse + , traverse' + , toList + , fromList + ) 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#) + +#else +import GHC.Exts (Array#, newArray#, readArray#, writeArray#, + indexArray#, unsafeFreezeArray#, unsafeThawArray#, + MutableArray#, sizeofArray#, copyArray#, thawArray#, + sizeofMutableArray#, copyMutableArray#, cloneMutableArray#) +import Data.Monoid (Monoid (..)) +#endif + +#if defined(ASSERTS) +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! +# define CHECK_BOUNDS(_func_,_len_,_k_) \ +if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.HashMap.Internal.Array." ++ (_func_) ++ ": bounds error, offset " ++ show (_k_) ++ ", length " ++ show (_len_)) else +# define CHECK_OP(_func_,_op_,_lhs_,_rhs_) \ +if not ((_lhs_) _op_ (_rhs_)) then error ("Data.HashMap.Internal.Array." ++ (_func_) ++ ": Check failed: _lhs_ _op_ _rhs_ (" ++ show (_lhs_) ++ " vs. " ++ show (_rhs_) ++ ")") else +# define CHECK_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_GT(_func_,_lhs_,_rhs_) +# define CHECK_LE(_func_,_lhs_,_rhs_) +# define CHECK_EQ(_func_,_lhs_,_rhs_) +#endif + +data Array a = Array { + unArray :: !(Array# a) + } + +instance Show a => Show (Array a) where + show = show . toList + +-- Determines whether two arrays have the same memory address. +-- This is more reliable than testing pointer equality on the +-- Array wrappers, but it's still slightly bogus. +unsafeSameArray :: Array a -> Array b -> Bool +unsafeSameArray (Array xs) (Array ys) = + tagToEnum# (unsafeCoerce# reallyUnsafePtrEquality# xs ys) + +sameArray1 :: (a -> b -> Bool) -> Array a -> Array b -> Bool +sameArray1 eq !xs0 !ys0 + | lenxs /= lenys = False + | otherwise = go 0 xs0 ys0 + where + go !k !xs !ys + | k == lenxs = True + | (# x #) <- index# xs k + , (# y #) <- index# ys k + = eq x y && go (k + 1) xs ys + + !lenxs = length xs0 + !lenys = length ys0 + +length :: Array a -> Int +length ary = I# (sizeofArray# (unArray ary)) +{-# INLINE length #-} + +data MArray s a = MArray { + unMArray :: !(MutableArray# s a) + } + +lengthM :: MArray s a -> Int +lengthM mary = I# (sizeofMutableArray# (unMArray mary)) +{-# INLINE lengthM #-} + +------------------------------------------------------------------------ + +instance NFData a => NFData (Array a) where + rnf = rnfArray + +rnfArray :: NFData a => Array a -> () +rnfArray ary0 = go ary0 n0 0 + where + n0 = length ary0 + go !ary !n !i + | i >= n = () + | (# x #) <- index# ary i + = rnf x `seq` go ary n (i+1) +-- We use index# just in case GHC can't see that the +-- relevant rnf is strict, or in case it actually isn't. +{-# INLINE rnfArray #-} + +-- | 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)) + ST $ \s -> + case newArray# n# b s of + (# s', ary #) -> (# s', MArray ary #) +{-# INLINE new #-} + +new_ :: Int -> ST s (MArray s a) +new_ n = new n undefinedElem + +singleton :: a -> Array a +singleton x = runST (singletonM x) +{-# INLINE singleton #-} + +singletonM :: a -> ST s (Array a) +singletonM x = new 1 x >>= unsafeFreeze +{-# INLINE singletonM #-} + +pair :: a -> a -> Array a +pair x y = run $ do + ary <- new 2 x + write ary 1 y + return ary +{-# INLINE pair #-} + +read :: MArray s a -> Int -> ST s a +read ary _i@(I# i#) = ST $ \ s -> + CHECK_BOUNDS("read", lengthM ary, _i) + readArray# (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 + 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 #-} + +index# :: Array a -> Int -> (# a #) +index# ary _i@(I# i#) = + CHECK_BOUNDS("index#", length ary, _i) + indexArray# (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 +{-# INLINE indexM #-} + +unsafeFreeze :: MArray s a -> ST s (Array a) +unsafeFreeze mary + = ST $ \s -> case unsafeFreezeArray# (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 + (# s', mary #) -> (# s', MArray mary #) +{-# INLINE unsafeThaw #-} + +run :: (forall s . ST s (MArray s e)) -> Array e +run act = runST $ act >>= unsafeFreeze +{-# INLINE run #-} + +-- | Unsafely copy the elements of an array. Array bounds are not checked. +copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s () +copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = + CHECK_LE("copy", _sidx + _n, length src) + CHECK_LE("copy", _didx + _n, lengthM dst) + ST $ \ s# -> + case copyArray# (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) + ST $ \ s# -> + case copyMutableArray# (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) + ST $ \ s -> + case cloneMutableArray# mary# off# len# s of + (# s', mary'# #) -> (# s', MArray mary'# #) + +-- | Create a new array of the @n@ first elements of @mary@. +trim :: MArray s a -> Int -> ST s (Array a) +trim mary n = cloneM mary 0 n >>= unsafeFreeze +{-# INLINE trim #-} + +-- | /O(n)/ Insert an element at the given position in this array, +-- increasing its size by one. +insert :: Array e -> Int -> e -> Array e +insert ary idx b = runST (insertM ary idx b) +{-# INLINE insert #-} + +-- | /O(n)/ Insert an element at the given position in this array, +-- increasing its size by one. +insertM :: Array e -> Int -> e -> ST s (Array e) +insertM ary idx b = + CHECK_BOUNDS("insertM", count + 1, idx) + do mary <- new_ (count+1) + 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. +update :: Array e -> Int -> e -> Array e +update ary idx b = runST (updateM ary idx b) +{-# INLINE update #-} + +-- | /O(n)/ Update the element at the given position in this array. +updateM :: Array e -> Int -> e -> ST s (Array e) +updateM ary idx b = + CHECK_BOUNDS("updateM", count, idx) + do mary <- thaw ary 0 count + write mary idx b + unsafeFreeze mary + where !count = length ary +{-# INLINE updateM #-} + +-- | /O(n)/ Update the element at the given positio in this array, by +-- applying a function to it. Evaluates the element to WHNF before +-- inserting it into the array. +updateWith' :: Array e -> Int -> (e -> e) -> Array e +updateWith' ary idx f + | (# x #) <- index# ary idx + = update ary idx $! f x +{-# INLINE updateWith' #-} + +-- | /O(1)/ Update the element at the given position in this array, +-- without copying. +unsafeUpdateM :: Array e -> Int -> e -> ST s () +unsafeUpdateM ary idx b = + CHECK_BOUNDS("unsafeUpdateM", length ary, idx) + do mary <- unsafeThaw ary + write mary idx b + _ <- unsafeFreeze mary + return () +{-# INLINE unsafeUpdateM #-} + +foldl' :: (b -> a -> b) -> b -> Array a -> b +foldl' f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 + where + go ary n i !z + | i >= n = z + | otherwise + = case index# ary i of + (# x #) -> go ary n (i+1) (f z x) +{-# INLINE foldl' #-} + +foldr' :: (a -> b -> b) -> b -> Array a -> b +foldr' f = \ z0 ary0 -> go ary0 (length ary0 - 1) z0 + where + go !_ary (-1) z = z + go !ary i !z + | (# x #) <- index# ary i + = go ary (i - 1) (f x z) +{-# INLINE foldr' #-} + +foldr :: (a -> b -> b) -> b -> Array a -> b +foldr f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 + where + go ary n i z + | i >= n = z + | otherwise + = case index# ary i of + (# x #) -> f x (go ary n (i+1) z) +{-# INLINE foldr #-} + +foldl :: (b -> a -> b) -> b -> Array a -> b +foldl f = \ z0 ary0 -> go ary0 (length ary0 - 1) z0 + where + go _ary (-1) z = z + go ary i z + | (# x #) <- index# ary i + = f (go ary (i - 1) z) x +{-# INLINE foldl #-} + +-- We go to a bit of trouble here to avoid appending an extra mempty. +-- The below implementation is by Mateusz Kowalczyk, who indicates that +-- benchmarks show it to be faster than one that avoids lifting out +-- lst. +foldMap :: Monoid m => (a -> m) -> Array a -> m +foldMap f = \ary0 -> case length ary0 of + 0 -> mempty + len -> + let !lst = len - 1 + go i | (# x #) <- index# ary0 i, let fx = f x = + if i == lst then fx else fx `mappend` go (i + 1) + in go 0 +{-# INLINE foldMap #-} + +-- | Verifies that a predicate holds for all elements of an array. +all :: (a -> Bool) -> Array a -> Bool +all p = foldr (\a acc -> p a && acc) True +{-# INLINE all #-} + +undefinedElem :: a +undefinedElem = error "Data.HashMap.Internal.Array: Undefined element" +{-# NOINLINE undefinedElem #-} + +thaw :: Array e -> Int -> Int -> ST s (MArray s e) +thaw !ary !_o@(I# o#) (I# n#) = + CHECK_LE("thaw", _o + n, length ary) + ST $ \ s -> case thawArray# (unArray ary) o# n# s of + (# s2, mary# #) -> (# s2, MArray mary# #) +{-# INLINE thaw #-} + +-- | /O(n)/ Delete an element at the given position in this array, +-- decreasing its size by one. +delete :: Array e -> Int -> Array e +delete ary idx = runST (deleteM ary idx) +{-# INLINE delete #-} + +-- | /O(n)/ Delete an element at the given position in this array, +-- decreasing its size by one. +deleteM :: Array e -> Int -> ST s (Array e) +deleteM ary idx = do + CHECK_BOUNDS("deleteM", count, idx) + do mary <- new_ (count-1) + copy ary 0 mary 0 idx + copy ary (idx+1) mary idx (count-(idx+1)) + unsafeFreeze mary + where !count = length ary +{-# INLINE deleteM #-} + +map :: (a -> b) -> Array a -> Array b +map f = \ ary -> + let !n = length ary + in run $ do + mary <- new_ n + go ary mary 0 n + where + go ary mary i n + | i >= n = return mary + | otherwise = do + x <- indexM ary i + write mary i $ f x + go ary mary (i+1) n +{-# INLINE map #-} + +-- | Strict version of 'map'. +map' :: (a -> b) -> Array a -> Array b +map' f = \ ary -> + let !n = length ary + in run $ do + mary <- new_ n + go ary mary 0 n + where + go ary mary i n + | i >= n = return mary + | otherwise = do + x <- indexM ary i + write mary i $! f x + go ary mary (i+1) n +{-# INLINE map' #-} + +fromList :: Int -> [a] -> Array a +fromList n xs0 = + CHECK_EQ("fromList", n, Prelude.length xs0) + run $ do + mary <- new_ n + go xs0 mary 0 + where + go [] !mary !_ = return mary + go (x:xs) mary i = do write mary i x + go xs mary (i+1) + +toList :: Array a -> [a] +toList = foldr (:) [] + +newtype STA a = STA {_runSTA :: forall s. MutableArray# s a -> ST s (Array a)} + +runSTA :: Int -> STA a -> Array a +runSTA !n (STA m) = runST $ new_ n >>= \ (MArray ar) -> m ar + +traverse :: Applicative f => (a -> f b) -> Array a -> f (Array b) +traverse f = \ !ary -> + let + !len = length ary + go !i + | i == len = pure $ STA $ \mary -> unsafeFreeze (MArray mary) + | (# x #) <- index# ary i + = liftA2 (\b (STA m) -> STA $ \mary -> + write (MArray mary) i b >> m mary) + (f x) (go (i + 1)) + in runSTA len <$> go 0 +{-# INLINE [1] traverse #-} + +-- TODO: Would it be better to just use a lazy traversal +-- and then force the elements of the result? My guess is +-- yes. +traverse' :: Applicative f => (a -> f b) -> Array a -> f (Array b) +traverse' f = \ !ary -> + let + !len = length ary + go !i + | i == len = pure $ STA $ \mary -> unsafeFreeze (MArray mary) + | (# x #) <- index# ary i + = liftA2 (\ !b (STA m) -> STA $ \mary -> + write (MArray mary) i b >> m mary) + (f x) (go (i + 1)) + in runSTA len <$> go 0 +{-# INLINE [1] traverse' #-} + +-- Traversing in ST, we don't need to get fancy; we +-- can just do it directly. +traverseST :: (a -> ST s b) -> Array a -> ST s (Array b) +traverseST f = \ ary0 -> + let + !len = length ary0 + go k !mary + | k == len = return mary + | otherwise = do + x <- indexM ary0 k + y <- f x + write mary k y + go (k + 1) mary + in new_ len >>= (go 0 >=> unsafeFreeze) +{-# INLINE traverseST #-} + +traverseIO :: (a -> IO b) -> Array a -> IO (Array b) +traverseIO f = \ ary0 -> + let + !len = length ary0 + go k !mary + | k == len = return mary + | otherwise = do + x <- stToIO $ indexM ary0 k + y <- f x + stToIO $ write mary k y + go (k + 1) mary + in stToIO (new_ len) >>= (go 0 >=> stToIO . unsafeFreeze) +{-# INLINE traverseIO #-} + + +-- Why don't we have similar RULES for traverse'? The efficient +-- way to traverse strictly in IO or ST is to force results as +-- they come in, which leads to different semantics. In particular, +-- we need to ensure that +-- +-- traverse' (\x -> print x *> pure undefined) xs +-- +-- will actually print all the values and then return undefined. +-- We could add a strict mapMWithIndex, operating in an arbitrary +-- Monad, that supported such rules, but we don't have that right now. +{-# RULES +"traverse/ST" forall f. traverse f = traverseST f +"traverse/IO" forall f. traverse f = traverseIO f + #-} diff --git a/Data/HashMap/Internal/List.hs b/Data/HashMap/Internal/List.hs new file mode 100644 --- /dev/null +++ b/Data/HashMap/Internal/List.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | = WARNING +-- +-- This module is considered __internal__. +-- +-- The Package Versioning Policy __does not apply__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +-- +-- Authors importing this module are expected to track development +-- closely. +-- +-- = Description +-- +-- Extra list functions +-- +-- In separate module to aid testing. +module Data.HashMap.Internal.List + ( isPermutationBy + , deleteBy + , unorderedCompare + ) where + +import Data.Maybe (fromMaybe) +import Data.List (sortBy) +import Data.Monoid +import Prelude + +-- Note: previous implemenation isPermutation = null (as // bs) +-- was O(n^2) too. +-- +-- This assumes lists are of equal length +isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool +isPermutationBy f = go + where + f' = flip f + + go [] [] = True + go (x : xs) (y : ys) + | f x y = go xs ys + | otherwise = fromMaybe False $ do + xs' <- deleteBy f' y xs + ys' <- deleteBy f x ys + return (go xs' ys') + go [] (_ : _) = False + go (_ : _) [] = False + +-- The idea: +-- +-- Homogeonous version +-- +-- uc :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering +-- uc c as bs = compare (sortBy c as) (sortBy c bs) +-- +-- But as we have only (a -> b -> Ordering), we cannot directly compare +-- elements from the same list. +-- +-- So when comparing elements from the list, we count how many elements are +-- "less and greater" in the other list, and use the count as a metric. +-- +unorderedCompare :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering +unorderedCompare c as bs = go (sortBy cmpA as) (sortBy cmpB bs) + where + go [] [] = EQ + go [] (_ : _) = LT + go (_ : _) [] = GT + go (x : xs) (y : ys) = c x y `mappend` go xs ys + + cmpA a a' = compare (inB a) (inB a') + cmpB b b' = compare (inA b) (inA b') + + inB a = (length $ filter (\b -> c a b == GT) bs, negate $ length $ filter (\b -> c a b == LT) bs) + inA b = (length $ filter (\a -> c a b == LT) as, negate $ length $ filter (\a -> c a b == GT) as) + +-- Returns Nothing is nothing deleted +deleteBy :: (a -> b -> Bool) -> a -> [b] -> Maybe [b] +deleteBy _ _ [] = Nothing +deleteBy eq x (y:ys) = if x `eq` y then Just ys else fmap (y :) (deleteBy eq x ys) diff --git a/Data/HashMap/Internal/Strict.hs b/Data/HashMap/Internal/Strict.hs new file mode 100644 --- /dev/null +++ b/Data/HashMap/Internal/Strict.hs @@ -0,0 +1,754 @@ +{-# LANGUAGE BangPatterns, CPP, PatternGuards, MagicHash, UnboxedTuples #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_HADDOCK not-home #-} + +------------------------------------------------------------------------ +-- | +-- Module : Data.HashMap.Strict +-- Copyright : 2010-2012 Johan Tibell +-- License : BSD-style +-- Maintainer : johan.tibell@gmail.com +-- Portability : portable +-- +-- = WARNING +-- +-- This module is considered __internal__. +-- +-- The Package Versioning Policy __does not apply__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +-- +-- Authors importing this module are expected to track development +-- closely. +-- +-- = Description +-- +-- A map from /hashable/ keys to values. A map cannot contain +-- duplicate keys; each key can map to at most one value. A 'HashMap' +-- makes no guarantees as to the order of its elements. +-- +-- The implementation is based on /hash array mapped tries/. A +-- 'HashMap' is often faster than other tree-based set types, +-- especially when key comparison is expensive, as in the case of +-- strings. +-- +-- Many operations have a average-case complexity of /O(log n)/. The +-- implementation uses a large base (i.e. 16) so in practice these +-- operations are constant time. +module Data.HashMap.Internal.Strict + ( + -- * Strictness properties + -- $strictness + + HashMap + + -- * Construction + , empty + , singleton + + -- * Basic interface + , HM.null + , size + , HM.member + , HM.lookup + , (HM.!?) + , HM.findWithDefault + , lookupDefault + , (!) + , insert + , insertWith + , delete + , adjust + , update + , alter + , alterF + , isSubmapOf + , isSubmapOfBy + + -- * Combine + -- ** Union + , union + , unionWith + , unionWithKey + , unions + + -- * Transformations + , map + , mapWithKey + , traverseWithKey + + -- * Difference and intersection + , difference + , differenceWith + , intersection + , intersectionWith + , intersectionWithKey + + -- * Folds + , foldMapWithKey + , foldr' + , foldl' + , foldrWithKey' + , foldlWithKey' + , HM.foldr + , HM.foldl + , foldrWithKey + , foldlWithKey + + -- * Filter + , HM.filter + , filterWithKey + , mapMaybe + , mapMaybeWithKey + + -- * Conversions + , keys + , elems + + -- ** Lists + , 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 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 + +-- $strictness +-- +-- This module satisfies the following strictness properties: +-- +-- 1. Key arguments are evaluated to WHNF; +-- +-- 2. Keys and values are evaluated to WHNF before they are stored in +-- the map. + +------------------------------------------------------------------------ +-- * Construction + +-- | /O(1)/ Construct a map with a single element. +singleton :: (Hashable k) => k -> v -> HashMap k v +singleton k !v = HM.singleton k v + +------------------------------------------------------------------------ +-- * Basic interface + +-- | /O(log n)/ Associate the specified value with the specified +-- key in this map. If this map previously contained a mapping for +-- the key, the old value is replaced. +insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v +insert k !v = HM.insert k v +{-# INLINABLE insert #-} + +-- | /O(log n)/ Associate the value with the key in this map. If +-- this map previously contained a mapping for the key, the old value +-- is replaced by the result of applying the given function to the new +-- and old value. Example: +-- +-- > insertWith f k v map +-- > where f new old = new + old +insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v + -> HashMap k v +insertWith f k0 v0 m0 = go h0 k0 v0 0 m0 + where + h0 = hash k0 + go !h !k x !_ Empty = leaf h k x + go h k x s t@(Leaf hy l@(L ky y)) + | hy == h = if ky == k + then leaf h k (f x y) + else x `seq` (collision h l (L k x)) + | otherwise = x `seq` 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 k x + in 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' + 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' + where i = index h s + go h k x s t@(Collision hy v) + | h == hy = Collision h (updateOrSnocWith f k x v) + | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) +{-# INLINABLE insertWith #-} + +-- | In-place update version of insertWith +unsafeInsertWith :: (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 :: (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 !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 + 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' + | 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 f k x v) + | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) +{-# INLINABLE unsafeInsertWithKey #-} + +-- | /O(log n)/ Adjust the value tied to a given key in this map only +-- if it is present. Otherwise, leave the map alone. +adjust :: (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 = leaf h k (f 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 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' + go h k _ t@(Collision hy v) + | h == hy = Collision h (updateWith f k v) + | otherwise = t +{-# INLINABLE adjust #-} + +-- | /O(log n)/ The expression @('update' f k map)@ updates the value @x@ at @k@ +-- (if it is in the map). If @(f x)@ is 'Nothing', the element is deleted. +-- If it is @('Just' y)@, the key @k@ is bound to the new value @y@. +update :: (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 +alter f k m = + case f (HM.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) +-- Special care is taken to only calculate the hash once. When we rewrite +-- with RULES, we also ensure that we only compare the key for equality +-- once. We force the value of the map for consistency with the rewritten +-- version; otherwise someone could tell the difference using a lazy +-- @f@ and a functor that is similar to Const but not actually Const. +alterF f = \ !k !m -> + let !h = hash k + mv = 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 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" + +bogus# :: (# #) -> (# a #) +bogus# _ = error "Data.HashMap.alterF internal error: hit bogus#" + +impossibleAdjust :: a +impossibleAdjust = error "Data.HashMap.alterF internal error: impossible adjust" + +{-# RULES + +-- See detailed notes on alterF rules in Data.HashMap.Internal. + +"alterFWeird" forall f. alterF f = + alterFWeird (f Nothing) (f (Just test_bottom)) f + +"alterFconstant" forall (f :: Maybe a -> Identity (Maybe a)) x. + alterFWeird x x f = \ !k !m -> + Identity (case runIdentity x of {Nothing -> 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 #))) + +-- This rule is written a bit differently than the one for lazy +-- maps because the adjust here is strict. We could write it the +-- same general way anyway, but this seems simpler. +"alterFadjust" forall (f :: Maybe a -> Identity (Maybe a)) x. + alterFWeird (coerce Nothing) (coerce (Just x)) f = + coerce (adjust (\a -> case runIdentity (f (Just a)) of + Just a' -> a' + Nothing -> impossibleAdjust)) + +"alterFlookup" forall _ign1 _ign2 (f :: Maybe a -> Const r (Maybe a)) . + alterFWeird _ign1 _ign2 f = \ !k !m -> Const (getConst (f (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, no collision + 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, no hash collision + Present v collPos -> v' `seq` + 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 + +------------------------------------------------------------------------ +-- * Combine + +-- | /O(n+m)/ The union of two maps. If a key occurs in both maps, +-- the provided function (first argument) will be used to compute the result. +unionWith :: (Eq k, 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 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 f k1 v1 ls2) + | otherwise = goDifferentHash s h1 h2 t1 t2 + go s t1@(Collision h1 ls1) t2@(Leaf h2 (L k2 v2)) + | h1 == h2 = Collision h1 (updateOrSnocWithKey (flip . f) k2 v2 ls1) + | otherwise = goDifferentHash s h1 h2 t1 t2 + go s t1@(Collision h1 ls1) t2@(Collision h2 ls2) + | h1 == h2 = Collision h1 (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 #-} + +------------------------------------------------------------------------ +-- * Transformations + +-- | /O(n)/ Transform this map by applying a function to every value. +mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2 +mapWithKey f = go + where + go Empty = Empty + go (Leaf h (L k v)) = leaf h k (f k v) + go (BitmapIndexed b ary) = BitmapIndexed b $ A.map' go ary + go (Full ary) = Full $ A.map' go ary + go (Collision h ary) = + Collision h $ A.map' (\ (L k v) -> let !v' = f k v in L k v') ary +{-# INLINE mapWithKey #-} + +-- | /O(n)/ Transform this map by applying a function to every value. +map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2 +map f = mapWithKey (const f) +{-# INLINE map #-} + + +------------------------------------------------------------------------ +-- * Filter + +-- | /O(n)/ Transform this map by applying a function to every value +-- and retaining only some of them. +mapMaybeWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 +mapMaybeWithKey f = filterMapAux onLeaf onColl + where onLeaf (Leaf h (L k v)) | Just v' <- f k v = Just (leaf h k v') + onLeaf _ = Nothing + + onColl (L k v) | Just v' <- f k v = Just (L k v') + | otherwise = Nothing +{-# INLINE mapMaybeWithKey #-} + +-- | /O(n)/ Transform this map by applying a function to every value +-- and retaining only some of them. +mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 +mapMaybe f = mapMaybeWithKey (const f) +{-# INLINE mapMaybe #-} + +-- | /O(n)/ Perform an 'Applicative' action for each key-value pair +-- in a 'HashMap' and produce a 'HashMap' of all the results. Each 'HashMap' +-- will be strict in all its values. +-- +-- @ +-- traverseWithKey f = fmap ('map' id) . "Data.HashMap.Lazy".'Data.HashMap.Lazy.traverseWithKey' f +-- @ +-- +-- Note: the order in which the actions occur is unspecified. In particular, +-- when the map contains hash collisions, the order in which the actions +-- associated with the keys involved will depend in an unspecified way on +-- their insertion order. +traverseWithKey + :: Applicative f + => (k -> v1 -> f v2) + -> HashMap k v1 -> f (HashMap k v2) +traverseWithKey f = go + where + go Empty = pure Empty + go (Leaf h (L k v)) = leaf h k <$> f k v + go (BitmapIndexed b ary) = BitmapIndexed b <$> A.traverse' go ary + go (Full ary) = Full <$> A.traverse' go ary + go (Collision h ary) = + Collision h <$> A.traverse' (\ (L k v) -> (L k $!) <$> f k v) ary +{-# INLINE traverseWithKey #-} + +------------------------------------------------------------------------ +-- * Difference and intersection + +-- | /O(n*log m)/ Difference with a combining function. When two equal keys are +-- encountered, the combining function is applied to the values of these keys. +-- If it returns 'Nothing', the element is discarded (proper set difference). If +-- it returns (@'Just' y@), the element is updated with a new value @y@. +differenceWith :: (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 #-} + +-- | /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 + -> 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 +{-# INLINABLE intersectionWith #-} + +-- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps +-- the provided function is used to combine the values from the two +-- maps. +intersectionWithKey :: (Eq k, 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 HM.lookup k b of + Just w -> insert k (f k v w) m + _ -> m +{-# INLINABLE intersectionWithKey #-} + +------------------------------------------------------------------------ +-- ** Lists + +-- | /O(n*log n)/ Construct a map with the supplied mappings. If the +-- list contains duplicate mappings, the later mappings take +-- precedence. +fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v +fromList = L.foldl' (\ m (k, !v) -> HM.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 + +updateWith :: Eq k => (v -> v) -> k -> A.Array (Leaf k v) -> A.Array (Leaf k v) +updateWith f k0 ary0 = go k0 ary0 0 (A.length ary0) + where + go !k !ary !i !n + | i >= n = ary + | otherwise = case A.index ary i of + (L kx y) | k == kx -> let !v' = f y in A.update ary i (L k v') + | otherwise -> go k ary (i+1) n +{-# INLINABLE updateWith #-} + +-- | Append the given key and value to the array. If the key is +-- already present, instead update the value of the key by applying +-- the given function to the new and old value (in that order). The +-- value is always evaluated to WHNF before being inserted into the +-- array. +updateOrSnocWith :: Eq k => (v -> v -> v) -> k -> v -> A.Array (Leaf k v) + -> A.Array (Leaf k v) +updateOrSnocWith f = updateOrSnocWithKey (const f) +{-# INLINABLE updateOrSnocWith #-} + +-- | Append the given key and value to the array. If the key is +-- already present, instead update the value of the key by applying +-- the given function to the new and old value (in that order). The +-- value is always evaluated to WHNF before being inserted into the +-- array. +updateOrSnocWithKey :: Eq k => (k -> v -> v -> v) -> k -> v -> A.Array (Leaf k v) + -> A.Array (Leaf k v) +updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0) + where + go !k v !ary !i !n + | 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 +{-# INLINABLE updateOrSnocWithKey #-} + +------------------------------------------------------------------------ +-- Smart constructors +-- +-- These constructors make sure the value is in WHNF before it's +-- inserted into the constructor. + +leaf :: Hash -> k -> v -> HashMap k v +leaf h k = \ !v -> Leaf h (L k v) +{-# INLINE leaf #-} diff --git a/Data/HashMap/Internal/Unsafe.hs b/Data/HashMap/Internal/Unsafe.hs new file mode 100644 --- /dev/null +++ b/Data/HashMap/Internal/Unsafe.hs @@ -0,0 +1,55 @@ +{-# 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 @@ -49,6 +49,8 @@ , update , alter , alterF + , isSubmapOf + , isSubmapOfBy -- * Combine -- ** Union @@ -100,8 +102,8 @@ , HS.keysSet ) where -import Data.HashMap.Base as HM -import qualified Data.HashSet.Base as HS +import Data.HashMap.Internal as HM +import qualified Data.HashSet.Internal as HS import Prelude () -- $strictness diff --git a/Data/HashMap/List.hs b/Data/HashMap/List.hs deleted file mode 100644 --- a/Data/HashMap/List.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} --- | Extra list functions --- --- In separate module to aid testing. -module Data.HashMap.List - ( isPermutationBy - , deleteBy - , unorderedCompare - ) where - -import Data.Maybe (fromMaybe) -import Data.List (sortBy) -import Data.Monoid -import Prelude - --- Note: previous implemenation isPermutation = null (as // bs) --- was O(n^2) too. --- --- This assumes lists are of equal length -isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool -isPermutationBy f = go - where - f' = flip f - - go [] [] = True - go (x : xs) (y : ys) - | f x y = go xs ys - | otherwise = fromMaybe False $ do - xs' <- deleteBy f' y xs - ys' <- deleteBy f x ys - return (go xs' ys') - go [] (_ : _) = False - go (_ : _) [] = False - --- The idea: --- --- Homogeonous version --- --- uc :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering --- uc c as bs = compare (sortBy c as) (sortBy c bs) --- --- But as we have only (a -> b -> Ordering), we cannot directly compare --- elements from the same list. --- --- So when comparing elements from the list, we count how many elements are --- "less and greater" in the other list, and use the count as a metric. --- -unorderedCompare :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering -unorderedCompare c as bs = go (sortBy cmpA as) (sortBy cmpB bs) - where - go [] [] = EQ - go [] (_ : _) = LT - go (_ : _) [] = GT - go (x : xs) (y : ys) = c x y `mappend` go xs ys - - cmpA a a' = compare (inB a) (inB a') - cmpB b b' = compare (inA b) (inA b') - - inB a = (length $ filter (\b -> c a b == GT) bs, negate $ length $ filter (\b -> c a b == LT) bs) - inA b = (length $ filter (\a -> c a b == LT) as, negate $ length $ filter (\a -> c a b == GT) as) - --- Returns Nothing is nothing deleted -deleteBy :: (a -> b -> Bool) -> a -> [b] -> Maybe [b] -deleteBy _ _ [] = Nothing -deleteBy eq x (y:ys) = if x `eq` y then Just ys else fmap (y :) (deleteBy eq x ys) diff --git a/Data/HashMap/Strict.hs b/Data/HashMap/Strict.hs --- a/Data/HashMap/Strict.hs +++ b/Data/HashMap/Strict.hs @@ -48,6 +48,8 @@ , update , alter , alterF + , isSubmapOf + , isSubmapOfBy -- * Combine -- ** Union @@ -99,8 +101,8 @@ , HS.keysSet ) where -import Data.HashMap.Strict.Base as HM -import qualified Data.HashSet.Base as HS +import Data.HashMap.Internal.Strict as HM +import qualified Data.HashSet.Internal as HS import Prelude () -- $strictness diff --git a/Data/HashMap/Strict/Base.hs b/Data/HashMap/Strict/Base.hs deleted file mode 100644 --- a/Data/HashMap/Strict/Base.hs +++ /dev/null @@ -1,732 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, PatternGuards, MagicHash, UnboxedTuples #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------- --- | --- Module : Data.HashMap.Strict --- Copyright : 2010-2012 Johan Tibell --- License : BSD-style --- Maintainer : johan.tibell@gmail.com --- Stability : provisional --- Portability : portable --- --- A map from /hashable/ keys to values. A map cannot contain --- duplicate keys; each key can map to at most one value. A 'HashMap' --- makes no guarantees as to the order of its elements. --- --- The implementation is based on /hash array mapped tries/. A --- 'HashMap' is often faster than other tree-based set types, --- especially when key comparison is expensive, as in the case of --- strings. --- --- Many operations have a average-case complexity of /O(log n)/. The --- implementation uses a large base (i.e. 16) so in practice these --- operations are constant time. -module Data.HashMap.Strict.Base - ( - -- * Strictness properties - -- $strictness - - HashMap - - -- * Construction - , empty - , singleton - - -- * Basic interface - , HM.null - , size - , HM.member - , HM.lookup - , (HM.!?) - , HM.findWithDefault - , lookupDefault - , (!) - , insert - , insertWith - , delete - , adjust - , update - , alter - , alterF - - -- * Combine - -- ** Union - , union - , unionWith - , unionWithKey - , unions - - -- * Transformations - , map - , mapWithKey - , traverseWithKey - - -- * Difference and intersection - , difference - , differenceWith - , intersection - , intersectionWith - , intersectionWithKey - - -- * Folds - , foldMapWithKey - , foldr' - , foldl' - , foldrWithKey' - , foldlWithKey' - , HM.foldr - , HM.foldl - , foldrWithKey - , foldlWithKey - - -- * Filter - , HM.filter - , filterWithKey - , mapMaybe - , mapMaybeWithKey - - -- * Conversions - , keys - , elems - - -- ** Lists - , 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 qualified Data.HashMap.Array as A -import qualified Data.HashMap.Base as HM -import Data.HashMap.Base hiding ( - alter, alterF, adjust, fromList, fromListWith, fromListWithKey, - insert, insertWith, - differenceWith, intersectionWith, intersectionWithKey, map, mapWithKey, - mapMaybe, mapMaybeWithKey, singleton, update, unionWith, unionWithKey, - traverseWithKey) -import Data.HashMap.Unsafe (runST) -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity -#endif -import Control.Applicative (Const (..)) -import Data.Coerce - --- $strictness --- --- This module satisfies the following strictness properties: --- --- 1. Key arguments are evaluated to WHNF; --- --- 2. Keys and values are evaluated to WHNF before they are stored in --- the map. - ------------------------------------------------------------------------- --- * Construction - --- | /O(1)/ Construct a map with a single element. -singleton :: (Hashable k) => k -> v -> HashMap k v -singleton k !v = HM.singleton k v - ------------------------------------------------------------------------- --- * Basic interface - --- | /O(log n)/ Associate the specified value with the specified --- key in this map. If this map previously contained a mapping for --- the key, the old value is replaced. -insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v -insert k !v = HM.insert k v -{-# INLINABLE insert #-} - --- | /O(log n)/ Associate the value with the key in this map. If --- this map previously contained a mapping for the key, the old value --- is replaced by the result of applying the given function to the new --- and old value. Example: --- --- > insertWith f k v map --- > where f new old = new + old -insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v - -> HashMap k v -insertWith f k0 v0 m0 = go h0 k0 v0 0 m0 - where - h0 = hash k0 - go !h !k x !_ Empty = leaf h k x - go h k x s t@(Leaf hy l@(L ky y)) - | hy == h = if ky == k - then leaf h k (f x y) - else x `seq` (collision h l (L k x)) - | otherwise = x `seq` 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 k x - in 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' - 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' - where i = index h s - go h k x s t@(Collision hy v) - | h == hy = Collision h (updateOrSnocWith f k x v) - | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) -{-# INLINABLE insertWith #-} - --- | In-place update version of insertWith -unsafeInsertWith :: (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 :: (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 !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 - 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' - | 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 f k x v) - | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) -{-# INLINABLE unsafeInsertWithKey #-} - --- | /O(log n)/ Adjust the value tied to a given key in this map only --- if it is present. Otherwise, leave the map alone. -adjust :: (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 = leaf h k (f 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 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' - go h k _ t@(Collision hy v) - | h == hy = Collision h (updateWith f k v) - | otherwise = t -{-# INLINABLE adjust #-} - --- | /O(log n)/ The expression @('update' f k map)@ updates the value @x@ at @k@ --- (if it is in the map). If @(f x)@ is 'Nothing', the element is deleted. --- If it is @('Just' y)@, the key @k@ is bound to the new value @y@. -update :: (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 -alter f k m = - case f (HM.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) --- Special care is taken to only calculate the hash once. When we rewrite --- with RULES, we also ensure that we only compare the key for equality --- once. We force the value of the map for consistency with the rewritten --- version; otherwise someone could tell the difference using a lazy --- @f@ and a functor that is similar to Const but not actually Const. -alterF f = \ !k !m -> - let !h = hash k - mv = lookup' h k m - in (<$> f mv) $ \fres -> - case fres of - Nothing -> delete' h k m - Just !v' -> 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.Base -test_bottom :: a -test_bottom = error "Data.HashMap.alterF internal error: hit test_bottom" - -bogus# :: (# #) -> (# a #) -bogus# _ = error "Data.HashMap.alterF internal error: hit bogus#" - -impossibleAdjust :: a -impossibleAdjust = error "Data.HashMap.alterF internal error: impossible adjust" - -{-# RULES - --- See detailed notes on alterF rules in Data.HashMap.Base. - -"alterFWeird" forall f. alterF f = - alterFWeird (f Nothing) (f (Just test_bottom)) f - -"alterFconstant" forall (f :: Maybe a -> Identity (Maybe a)) x. - alterFWeird x x f = \ !k !m -> - Identity (case runIdentity x of {Nothing -> 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 #))) - --- This rule is written a bit differently than the one for lazy --- maps because the adjust here is strict. We could write it the --- same general way anyway, but this seems simpler. -"alterFadjust" forall (f :: Maybe a -> Identity (Maybe a)) x. - alterFWeird (coerce Nothing) (coerce (Just x)) f = - coerce (adjust (\a -> case runIdentity (f (Just a)) of - Just a' -> a' - Nothing -> impossibleAdjust)) - -"alterFlookup" forall _ign1 _ign2 (f :: Maybe a -> Const r (Maybe a)) . - alterFWeird _ign1 _ign2 f = \ !k !m -> Const (getConst (f (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, no collision - 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, no hash collision - Present v collPos -> v' `seq` - 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 - ------------------------------------------------------------------------- --- * Combine - --- | /O(n+m)/ The union of two maps. If a key occurs in both maps, --- the provided function (first argument) will be used to compute the result. -unionWith :: (Eq k, 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 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 f k1 v1 ls2) - | otherwise = goDifferentHash s h1 h2 t1 t2 - go s t1@(Collision h1 ls1) t2@(Leaf h2 (L k2 v2)) - | h1 == h2 = Collision h1 (updateOrSnocWithKey (flip . f) k2 v2 ls1) - | otherwise = goDifferentHash s h1 h2 t1 t2 - go s t1@(Collision h1 ls1) t2@(Collision h2 ls2) - | h1 == h2 = Collision h1 (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 #-} - ------------------------------------------------------------------------- --- * Transformations - --- | /O(n)/ Transform this map by applying a function to every value. -mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2 -mapWithKey f = go - where - go Empty = Empty - go (Leaf h (L k v)) = leaf h k (f k v) - go (BitmapIndexed b ary) = BitmapIndexed b $ A.map' go ary - go (Full ary) = Full $ A.map' go ary - go (Collision h ary) = - Collision h $ A.map' (\ (L k v) -> let !v' = f k v in L k v') ary -{-# INLINE mapWithKey #-} - --- | /O(n)/ Transform this map by applying a function to every value. -map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2 -map f = mapWithKey (const f) -{-# INLINE map #-} - - ------------------------------------------------------------------------- --- * Filter - --- | /O(n)/ Transform this map by applying a function to every value --- and retaining only some of them. -mapMaybeWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 -mapMaybeWithKey f = filterMapAux onLeaf onColl - where onLeaf (Leaf h (L k v)) | Just v' <- f k v = Just (leaf h k v') - onLeaf _ = Nothing - - onColl (L k v) | Just v' <- f k v = Just (L k v') - | otherwise = Nothing -{-# INLINE mapMaybeWithKey #-} - --- | /O(n)/ Transform this map by applying a function to every value --- and retaining only some of them. -mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 -mapMaybe f = mapMaybeWithKey (const f) -{-# INLINE mapMaybe #-} - --- | /O(n)/ Perform an 'Applicative' action for each key-value pair --- in a 'HashMap' and produce a 'HashMap' of all the results. Each 'HashMap' --- will be strict in all its values. --- --- @ --- traverseWithKey f = fmap ('map' id) . "Data.HashMap.Lazy".'Data.HashMap.Lazy.traverseWithKey' f --- @ --- --- Note: the order in which the actions occur is unspecified. In particular, --- when the map contains hash collisions, the order in which the actions --- associated with the keys involved will depend in an unspecified way on --- their insertion order. -traverseWithKey - :: Applicative f - => (k -> v1 -> f v2) - -> HashMap k v1 -> f (HashMap k v2) -traverseWithKey f = go - where - go Empty = pure Empty - go (Leaf h (L k v)) = leaf h k <$> f k v - go (BitmapIndexed b ary) = BitmapIndexed b <$> A.traverse' go ary - go (Full ary) = Full <$> A.traverse' go ary - go (Collision h ary) = - Collision h <$> A.traverse' (\ (L k v) -> (L k $!) <$> f k v) ary -{-# INLINE traverseWithKey #-} - ------------------------------------------------------------------------- --- * Difference and intersection - --- | /O(n*log m)/ Difference with a combining function. When two equal keys are --- encountered, the combining function is applied to the values of these keys. --- If it returns 'Nothing', the element is discarded (proper set difference). If --- it returns (@'Just' y@), the element is updated with a new value @y@. -differenceWith :: (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 #-} - --- | /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 - -> 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 -{-# INLINABLE intersectionWith #-} - --- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps --- the provided function is used to combine the values from the two --- maps. -intersectionWithKey :: (Eq k, 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 HM.lookup k b of - Just w -> insert k (f k v w) m - _ -> m -{-# INLINABLE intersectionWithKey #-} - ------------------------------------------------------------------------- --- ** Lists - --- | /O(n*log n)/ Construct a map with the supplied mappings. If the --- list contains duplicate mappings, the later mappings take --- precedence. -fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v -fromList = L.foldl' (\ m (k, !v) -> HM.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 - -updateWith :: Eq k => (v -> v) -> k -> A.Array (Leaf k v) -> A.Array (Leaf k v) -updateWith f k0 ary0 = go k0 ary0 0 (A.length ary0) - where - go !k !ary !i !n - | i >= n = ary - | otherwise = case A.index ary i of - (L kx y) | k == kx -> let !v' = f y in A.update ary i (L k v') - | otherwise -> go k ary (i+1) n -{-# INLINABLE updateWith #-} - --- | Append the given key and value to the array. If the key is --- already present, instead update the value of the key by applying --- the given function to the new and old value (in that order). The --- value is always evaluated to WHNF before being inserted into the --- array. -updateOrSnocWith :: Eq k => (v -> v -> v) -> k -> v -> A.Array (Leaf k v) - -> A.Array (Leaf k v) -updateOrSnocWith f = updateOrSnocWithKey (const f) -{-# INLINABLE updateOrSnocWith #-} - --- | Append the given key and value to the array. If the key is --- already present, instead update the value of the key by applying --- the given function to the new and old value (in that order). The --- value is always evaluated to WHNF before being inserted into the --- array. -updateOrSnocWithKey :: Eq k => (k -> v -> v -> v) -> k -> v -> A.Array (Leaf k v) - -> A.Array (Leaf k v) -updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0) - where - go !k v !ary !i !n - | 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 -{-# INLINABLE updateOrSnocWithKey #-} - ------------------------------------------------------------------------- --- Smart constructors --- --- These constructors make sure the value is in WHNF before it's --- inserted into the constructor. - -leaf :: Hash -> k -> v -> HashMap k v -leaf h k = \ !v -> Leaf h (L k v) -{-# INLINE leaf #-} diff --git a/Data/HashMap/Unsafe.hs b/Data/HashMap/Unsafe.hs deleted file mode 100644 --- a/Data/HashMap/Unsafe.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE CPP #-} - -#if !MIN_VERSION_base(4,9,0) -{-# LANGUAGE MagicHash, Rank2Types, UnboxedTuples #-} -#endif - --- | 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.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/UnsafeShift.hs b/Data/HashMap/UnsafeShift.hs deleted file mode 100644 --- a/Data/HashMap/UnsafeShift.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE MagicHash #-} - -module Data.HashMap.UnsafeShift - ( unsafeShiftL - , unsafeShiftR - ) where - -import GHC.Exts (Word(W#), Int(I#), uncheckedShiftL#, uncheckedShiftRL#) - -unsafeShiftL :: Word -> Int -> Word -unsafeShiftL (W# x#) (I# i#) = W# (x# `uncheckedShiftL#` i#) -{-# INLINE unsafeShiftL #-} - -unsafeShiftR :: Word -> Int -> Word -unsafeShiftR (W# x#) (I# i#) = W# (x# `uncheckedShiftRL#` i#) -{-# INLINE unsafeShiftR #-} diff --git a/Data/HashSet.hs b/Data/HashSet.hs --- a/Data/HashSet.hs +++ b/Data/HashSet.hs @@ -4,26 +4,95 @@ #endif ------------------------------------------------------------------------ --- | --- Module : Data.HashSet --- Copyright : 2011 Bryan O'Sullivan --- License : BSD-style --- Maintainer : johan.tibell@gmail.com --- Stability : provisional --- Portability : portable --- --- A set of /hashable/ values. A set cannot contain duplicate items. --- A 'HashSet' makes no guarantees as to the order of its elements. --- --- The implementation is based on /hash array mapped trie/. A --- 'HashSet' is often faster than other tree-based set types, --- especially when value comparison is expensive, as in the case of --- strings. --- --- Many operations have a average-case complexity of /O(log n)/. The --- implementation uses a large base (i.e. 16) so in practice these --- operations are constant time. +{-| +Module : Data.HashSet +Copyright : 2011 Bryan O'Sullivan +License : BSD-style +Maintainer : johan.tibell@gmail.com +Stability : provisional +Portability : portable += Introduction + +'HashSet' allows you to store /unique/ elements, providing efficient insertion, +lookups, and deletion. A 'HashSet' makes no guarantees as to the order of its +elements. + +If you are storing sets of "Data.Int"s consider using "Data.IntSet" from the + package. + + +== Examples + +All the examples below assume @HashSet@ is imported qualified, and uses the following @dataStructures@ set. + +>>> import qualified Data.HashSet as HashSet +>>> let dataStructures = HashSet.fromList ["Set", "Map", "Graph", "Sequence"] + +=== Basic Operations + +Check membership in a set: + +>>> -- Check if "Map" and "Trie" are in the set of data structures. +>>> HashSet.member "Map" dataStructures +True +>>> HashSet.member "Trie" dataStructures +False + +Add a new entry to the set: + +>>> let moreDataStructures = HashSet.insert "Trie" dataStructures +>>> HashSet.member "Trie" moreDataStructures +> True + +Remove the @\"Graph\"@ entry from the set of data structures. + +>>> let fewerDataStructures = HashSet.delete "Graph" dataStructures +>>> HashSet.toList fewerDataStructures +["Map","Set","Sequence"] + + +Create a new set and combine it with our original set. + +>>> let unorderedDataStructures = HashSet.fromList ["HashSet", "HashMap"] +>>> HashSet.union dataStructures unorderedDataStructures +fromList ["Map","HashSet","Graph","HashMap","Set","Sequence"] + +=== Using custom data with HashSet + +To create a @HashSet@ of your custom type, the type must have instances for +'Data.Eq.Eq' and 'Data.Hashable.Hashable'. The @Hashable@ typeclass is defined in the + package, see the +documentation for information on how to make your type an instance of +@Hashable@. + +We'll start by setting up our custom data type: + +>>> :set -XDeriveGeneric +>>> import GHC.Generics (Generic) +>>> import Data.Hashable +>>> data Person = Person { name :: String, likesDogs :: Bool } deriving (Show, Eq, Generic) +>>> instance Hashable Person + +And now we'll use it! + +>>> let people = HashSet.fromList [Person "Lana" True, Person "Joe" False, Person "Simon" True] +>>> HashSet.filter likesDogs people +fromList [Person {name = "Simon", likesDogs = True},Person {name = "Lana", likesDogs = True}] + + +== Performance + +The implementation is based on /hash array mapped tries/. A +'HashSet' is often faster than other 'Data.Ord.Ord'-based set types, +especially when value comparisons are expensive, as in the case of +strings. + +Many operations have a average-case complexity of /O(log n)/. The +implementation uses a large base (i.e. 16) so in practice these +operations are constant time. +-} + module Data.HashSet ( HashSet @@ -42,6 +111,7 @@ , member , insert , delete + , isSubsetOf -- * Transformations , map @@ -68,5 +138,5 @@ , fromMap ) where -import Data.HashSet.Base +import Data.HashSet.Internal import Prelude () diff --git a/Data/HashSet/Base.hs b/Data/HashSet/Base.hs deleted file mode 100644 --- a/Data/HashSet/Base.hs +++ /dev/null @@ -1,411 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable #-} -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeFamilies #-} -#endif -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif - ------------------------------------------------------------------------- --- | --- Module : Data.HashSet.Base --- Copyright : 2011 Bryan O'Sullivan --- License : BSD-style --- Maintainer : johan.tibell@gmail.com --- Stability : provisional --- Portability : portable --- --- A set of /hashable/ values. A set cannot contain duplicate items. --- A 'HashSet' makes no guarantees as to the order of its elements. --- --- The implementation is based on /hash array mapped trie/. A --- 'HashSet' is often faster than other tree-based set types, --- especially when value comparison is expensive, as in the case of --- strings. --- --- Many operations have a average-case complexity of /O(log n)/. The --- implementation uses a large base (i.e. 16) so in practice these --- operations are constant time. - -module Data.HashSet.Base - ( - HashSet - - -- * Construction - , empty - , singleton - - -- * Combine - , union - , unions - - -- * Basic interface - , null - , size - , member - , insert - , delete - - -- * Transformations - , map - - -- * Difference and intersection - , difference - , intersection - - -- * Folds - , foldr - , foldr' - , foldl - , foldl' - - -- * Filter - , filter - - -- * Conversions - - -- ** Lists - , toList - , fromList - - -- * HashMaps - , toMap - , fromMap - - -- Exported from Data.HashMap.{Strict, Lazy} - , keysSet - ) where - -import Control.DeepSeq (NFData(..)) -import Data.Data hiding (Typeable) -import Data.HashMap.Base - ( 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.Base 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 Data.Functor.Classes -#endif - -#if MIN_VERSION_hashable(1,2,5) -import qualified Data.Hashable.Lifted as H -#endif - -import Data.Functor ((<$)) - --- | 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 - -instance (NFData a) => NFData (HashSet a) where - rnf = rnf . asMap - {-# INLINE rnf #-} - --- | Note that, in the presence of hash collisions, equal @HashSet@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, B] --- >>> y = fromList [B, A] --- --- >>> x == y --- True --- >>> toList x --- [A,B] --- >>> toList y --- [B,A] --- --- 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 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 - foldr = foldr - {-# INLINE foldr #-} - foldl = foldl - {-# INLINE foldl #-} - foldl' = foldl' - {-# 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)/ --- --- To obtain good performance, the smaller set must be presented as --- the first argument. --- --- ==== __Examples__ --- --- >>> fromList [1,2] <> fromList [2,3] --- fromList [1,2,3] -instance (Hashable a, Eq a) => Semigroup (HashSet a) where - (<>) = union - {-# INLINE (<>) #-} -#endif - --- | 'mempty' = 'empty' --- --- 'mappend' = 'union' --- --- /O(n+m)/ --- --- To obtain good performance, the smaller set must be presented as --- the first argument. --- --- ==== __Examples__ --- --- >>> mappend (fromList [1,2]) (fromList [2,3]) --- fromList [1,2,3] -instance (Hashable a, Eq 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 - readPrec = parens $ prec 10 $ do - Ident "fromList" <- lexP - xs <- readPrec - return (fromList xs) - - 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 - gfoldl f z m = z fromList `f` toList m - toConstr _ = fromListConstr - gunfold k z c = case constrIndex c of - 1 -> k (z fromList) - _ -> error "gunfold" - dataTypeOf _ = hashSetDataType - dataCast1 f = gcast1 f - -#if MIN_VERSION_hashable(1,2,6) -instance H.Hashable1 HashSet where - liftHashWithSalt h s = H.liftHashWithSalt2 h hashWithSalt s . asMap -#endif - -instance (Hashable a) => Hashable (HashSet a) where - hashWithSalt salt = hashWithSalt salt . asMap - -fromListConstr :: Constr -fromListConstr = mkConstr hashSetDataType "fromList" [] Prefix - -hashSetDataType :: DataType -hashSetDataType = mkDataType "Data.HashSet.Base.HashSet" [fromListConstr] - --- | /O(1)/ Construct an empty set. -empty :: HashSet a -empty = HashSet H.empty - --- | /O(1)/ Construct a set with a single element. -singleton :: Hashable a => a -> HashSet a -singleton a = HashSet (H.singleton a ()) -{-# INLINABLE singleton #-} - --- | /O(1)/ Convert to the equivalent 'HashMap'. -toMap :: HashSet a -> HashMap a () -toMap = asMap - --- | /O(1)/ Convert from the equivalent 'HashMap'. -fromMap :: HashMap a () -> HashSet a -fromMap = HashSet - --- | /O(n)/ Produce a 'HashSet' of all the keys in the given 'HashMap'. --- --- @since 0.2.10.0 -keysSet :: HashMap k a -> HashSet k -keysSet m = fromMap (() <$ m) - --- | /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. --- --- ==== __Examples__ --- --- >>> union (fromList [1,2]) (fromList [2,3]) --- fromList [1,2,3] -union :: (Eq a, Hashable 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 = List.foldl' union empty -{-# INLINE unions #-} - --- | /O(1)/ Return 'True' if this set is empty, 'False' otherwise. -null :: HashSet a -> Bool -null = H.null . asMap -{-# INLINE null #-} - --- | /O(n)/ Return the number of elements in this set. -size :: HashSet a -> Int -size = H.size . asMap -{-# INLINE size #-} - --- | /O(log n)/ Return 'True' if the given value is present in this --- set, 'False' otherwise. -member :: (Eq a, Hashable a) => a -> HashSet a -> Bool -member a s = case H.lookup a (asMap s) of - Just _ -> True - _ -> False -{-# INLINABLE member #-} - --- | /O(log n)/ Add the specified value to this set. -insert :: (Eq a, 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. -delete :: (Eq a, 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. --- The resulting set may be smaller than the source. -map :: (Hashable b, Eq b) => (a -> b) -> HashSet a -> HashSet b -map f = fromList . List.map f . toList -{-# INLINE map #-} - --- | /O(n)/ Difference of two sets. Return elements of the first set --- not existing in the second. -difference :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a -difference (HashSet a) (HashSet b) = HashSet (H.difference a b) -{-# INLINABLE difference #-} - --- | /O(n)/ Intersection of two sets. Return elements present in both --- the first set and the second. -intersection :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a -intersection (HashSet a) (HashSet b) = HashSet (H.intersection a b) -{-# INLINABLE intersection #-} - --- | /O(n)/ Reduce this set by applying a binary operator to all --- elements, using the given starting value (typically the --- left-identity of the operator). Each application of the operator --- is evaluated before before using the result in the next --- application. This function is strict in the starting value. -foldl' :: (a -> b -> a) -> a -> HashSet b -> a -foldl' f z0 = H.foldlWithKey' g z0 . asMap - where g z k _ = f z k -{-# INLINE foldl' #-} - --- | /O(n)/ Reduce this set by applying a binary operator to all --- elements, using the given starting value (typically the --- right-identity of the operator). Each application of the operator --- is evaluated before before using the result in the next --- application. This function is strict in the starting value. -foldr' :: (b -> a -> a) -> a -> HashSet b -> a -foldr' f z0 = H.foldrWithKey' g z0 . asMap - where g k _ z = f k z -{-# INLINE foldr' #-} - --- | /O(n)/ Reduce this set by applying a binary operator to all --- elements, using the given starting value (typically the --- right-identity of the operator). -foldr :: (b -> a -> a) -> a -> HashSet b -> a -foldr f z0 = foldrWithKey g z0 . asMap - where g k _ z = f k z -{-# INLINE foldr #-} - --- | /O(n)/ Reduce this set by applying a binary operator to all --- elements, using the given starting value (typically the --- left-identity of the operator). -foldl :: (a -> b -> a) -> a -> HashSet b -> a -foldl f z0 = foldlWithKey g z0 . asMap - where g z k _ = f z k -{-# INLINE foldl #-} - --- | /O(n)/ Filter this set by retaining only elements satisfying a --- predicate. -filter :: (a -> Bool) -> HashSet a -> HashSet a -filter p = HashSet . H.filterWithKey q . asMap - where q k _ = p k -{-# INLINE filter #-} - --- | /O(n)/ Return a list of this set's elements. The list is --- produced lazily. -toList :: HashSet a -> [a] -toList t = 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 -{-# INLINE fromList #-} - -#if __GLASGOW_HASKELL__ >= 708 -instance (Eq a, Hashable a) => Exts.IsList (HashSet a) where - type Item (HashSet a) = a - fromList = fromList - toList = toList -#endif diff --git a/Data/HashSet/Internal.hs b/Data/HashSet/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/HashSet/Internal.hs @@ -0,0 +1,484 @@ +{-# LANGUAGE CPP, DeriveDataTypeable #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} +#endif +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Trustworthy #-} +#endif +{-# OPTIONS_HADDOCK not-home #-} + +------------------------------------------------------------------------ +-- | +-- Module : Data.HashSet.Internal +-- Copyright : 2011 Bryan O'Sullivan +-- License : BSD-style +-- Maintainer : johan.tibell@gmail.com +-- Portability : portable +-- +-- = WARNING +-- +-- This module is considered __internal__. +-- +-- The Package Versioning Policy __does not apply__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +-- +-- Authors importing this module are expected to track development +-- closely. +-- +-- = Description +-- +-- A set of /hashable/ values. A set cannot contain duplicate items. +-- A 'HashSet' makes no guarantees as to the order of its elements. +-- +-- The implementation is based on /hash array mapped tries/. A +-- 'HashSet' is often faster than other tree-based set types, +-- especially when value comparison is expensive, as in the case of +-- strings. +-- +-- Many operations have a average-case complexity of /O(log n)/. The +-- implementation uses a large base (i.e. 16) so in practice these +-- operations are constant time. + +module Data.HashSet.Internal + ( + HashSet + + -- * Construction + , empty + , singleton + + -- * Basic interface + , null + , size + , member + , insert + , delete + , isSubsetOf + + -- * Transformations + , map + + -- * Combine + , union + , unions + + -- * Difference and intersection + , difference + , intersection + + -- * Folds + , foldr + , foldr' + , foldl + , foldl' + + -- * Filter + , filter + + -- * Conversions + + -- ** Lists + , toList + , fromList + + -- * HashMaps + , toMap + , fromMap + + -- Exported from Data.HashMap.{Strict, Lazy} + , keysSet + ) where + +import Control.DeepSeq (NFData(..)) +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 Data.Functor.Classes +#endif + +#if MIN_VERSION_hashable(1,2,5) +import qualified Data.Hashable.Lifted as H +#endif + +import Data.Functor ((<$)) + +-- | 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 + +instance (NFData a) => NFData (HashSet a) where + rnf = rnf . asMap + {-# INLINE rnf #-} + +-- | Note that, in the presence of hash collisions, equal @HashSet@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, B] +-- >>> y = fromList [B, A] +-- +-- >>> x == y +-- True +-- >>> toList x +-- [A,B] +-- >>> toList y +-- [B,A] +-- +-- 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 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 + foldr = foldr + {-# INLINE foldr #-} + foldl = foldl + {-# INLINE foldl #-} + foldl' = foldl' + {-# 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)/ +-- +-- To obtain good performance, the smaller set must be presented as +-- the first argument. +-- +-- ==== __Examples__ +-- +-- >>> fromList [1,2] <> fromList [2,3] +-- fromList [1,2,3] +instance (Hashable a, Eq a) => Semigroup (HashSet a) where + (<>) = union + {-# INLINE (<>) #-} +#endif + +-- | 'mempty' = 'empty' +-- +-- 'mappend' = 'union' +-- +-- /O(n+m)/ +-- +-- To obtain good performance, the smaller set must be presented as +-- the first argument. +-- +-- ==== __Examples__ +-- +-- >>> mappend (fromList [1,2]) (fromList [2,3]) +-- fromList [1,2,3] +instance (Hashable a, Eq 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 + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- readPrec + return (fromList xs) + + 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 + gfoldl f z m = z fromList `f` toList m + toConstr _ = fromListConstr + gunfold k z c = case constrIndex c of + 1 -> k (z fromList) + _ -> error "gunfold" + dataTypeOf _ = hashSetDataType + dataCast1 f = gcast1 f + +#if MIN_VERSION_hashable(1,2,6) +instance H.Hashable1 HashSet where + liftHashWithSalt h s = H.liftHashWithSalt2 h hashWithSalt s . asMap +#endif + +instance (Hashable a) => Hashable (HashSet a) where + hashWithSalt salt = hashWithSalt salt . asMap + +fromListConstr :: Constr +fromListConstr = mkConstr hashSetDataType "fromList" [] Prefix + +hashSetDataType :: DataType +hashSetDataType = mkDataType "Data.HashSet.Internal.HashSet" [fromListConstr] + +-- | /O(1)/ Construct an empty set. +-- +-- >>> HashSet.empty +-- fromList [] +empty :: HashSet a +empty = HashSet H.empty + +-- | /O(1)/ Construct a set with a single element. +-- +-- >>> HashSet.singleton 1 +-- fromList [1] +singleton :: Hashable a => a -> HashSet a +singleton a = HashSet (H.singleton a ()) +{-# INLINABLE singleton #-} + +-- | /O(1)/ Convert to set to the equivalent 'HashMap' with @()@ values. +-- +-- >>> HashSet.toMap (HashSet.singleton 1) +-- fromList [(1,())] +toMap :: HashSet a -> HashMap a () +toMap = asMap + +-- | /O(1)/ Convert from the equivalent 'HashMap' with @()@ values. +-- +-- >>> HashSet.fromMap (HashMap.singleton 1 ()) +-- fromList [1] +fromMap :: HashMap a () -> HashSet a +fromMap = HashSet + +-- | /O(n)/ Produce a 'HashSet' of all the keys in the given 'HashMap'. +-- +-- >>> HashSet.keysSet (HashMap.fromList [(1, "a"), (2, "b")] +-- fromList [1,2] +-- +-- @since 0.2.10.0 +keysSet :: HashMap k a -> HashSet k +keysSet m = fromMap (() <$ m) + +-- | /O(n*log m)/ Inclusion of sets. +-- +-- ==== __Examples__ +-- +-- >>> fromList [1,3] `isSubsetOf` fromList [1,2,3] +-- True +-- +-- >>> fromList [1,2] `isSubsetOf` fromList [1,3] +-- False +-- +-- @since 0.2.12 +isSubsetOf :: (Eq a, Hashable a) => HashSet a -> HashSet a -> Bool +isSubsetOf s1 s2 = H.isSubmapOfBy (\_ _ -> True) (asMap s1) (asMap s2) + +-- | /O(n+m)/ Construct a set containing all elements from both sets. +-- +-- To obtain good performance, the smaller set must be presented as +-- the first argument. +-- +-- >>> union (fromList [1,2]) (fromList [2,3]) +-- fromList [1,2,3] +union :: (Eq a, Hashable 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 = List.foldl' union empty +{-# INLINE unions #-} + +-- | /O(1)/ Return 'True' if this set is empty, 'False' otherwise. +-- +-- >>> HashSet.null HashSet.empty +-- True +-- >>> HashSet.null (HashSet.singleton 1) +-- False +null :: HashSet a -> Bool +null = H.null . asMap +{-# INLINE null #-} + +-- | /O(n)/ Return the number of elements in this set. +-- +-- >>> HashSet.size HashSet.empty +-- 0 +-- >>> HashSet.size (HashSet.fromList [1,2,3]) +-- 3 +size :: HashSet a -> Int +size = H.size . asMap +{-# INLINE size #-} + +-- | /O(log n)/ Return 'True' if the given value is present in this +-- set, 'False' otherwise. +-- +-- >>> HashSet.member 1 (Hashset.fromList [1,2,3]) +-- True +-- >>> HashSet.member 1 (Hashset.fromList [4,5,6]) +-- False +member :: (Eq a, 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. +-- +-- >>> HashSet.insert 1 HashSet.empty +-- fromList [1] +insert :: (Eq a, Hashable a) => a -> HashSet a -> HashSet a +insert a = HashSet . H.insert a () . asMap +{-# INLINABLE insert #-} + +-- | /O(log n)/ Remove the specified value from this set if present. +-- +-- >>> HashSet.delete 1 (HashSet.fromList [1,2,3]) +-- fromList [2,3] +-- >>> HashSet.delete 1 (HashSet.fromList [4,5,6]) +-- fromList [4,5,6] +delete :: (Eq a, 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. +-- 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 f = fromList . List.map f . toList +{-# INLINE map #-} + +-- | /O(n)/ Difference of two sets. Return elements of the first set +-- not existing in the second. +-- +-- >>> 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 (HashSet a) (HashSet b) = HashSet (H.difference a b) +{-# INLINABLE difference #-} + +-- | /O(n)/ 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 (HashSet a) (HashSet b) = HashSet (H.intersection a b) +{-# INLINABLE intersection #-} + +-- | /O(n)/ Reduce this set by applying a binary operator to all +-- elements, using the given starting value (typically the +-- left-identity of the operator). Each application of the operator +-- is evaluated before before using the result in the next +-- application. This function is strict in the starting value. +foldl' :: (a -> b -> a) -> a -> HashSet b -> a +foldl' f z0 = H.foldlWithKey' g z0 . asMap + where g z k _ = f z k +{-# INLINE foldl' #-} + +-- | /O(n)/ Reduce this set by applying a binary operator to all +-- elements, using the given starting value (typically the +-- right-identity of the operator). Each application of the operator +-- is evaluated before before using the result in the next +-- application. This function is strict in the starting value. +foldr' :: (b -> a -> a) -> a -> HashSet b -> a +foldr' f z0 = H.foldrWithKey' g z0 . asMap + where g k _ z = f k z +{-# INLINE foldr' #-} + +-- | /O(n)/ Reduce this set by applying a binary operator to all +-- elements, using the given starting value (typically the +-- right-identity of the operator). +foldr :: (b -> a -> a) -> a -> HashSet b -> a +foldr f z0 = foldrWithKey g z0 . asMap + where g k _ z = f k z +{-# INLINE foldr #-} + +-- | /O(n)/ Reduce this set by applying a binary operator to all +-- elements, using the given starting value (typically the +-- left-identity of the operator). +foldl :: (a -> b -> a) -> a -> HashSet b -> a +foldl f z0 = foldlWithKey g z0 . asMap + where g z k _ = f z k +{-# INLINE foldl #-} + +-- | /O(n)/ Filter this set by retaining only elements satisfying a +-- predicate. +filter :: (a -> Bool) -> HashSet a -> HashSet a +filter p = HashSet . H.filterWithKey q . asMap + where q k _ = p k +{-# INLINE filter #-} + +-- | /O(n)/ Return a list of this set's elements. The list is +-- produced lazily. +toList :: HashSet a -> [a] +toList t = 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 +{-# INLINE fromList #-} + +#if __GLASGOW_HASKELL__ >= 708 +instance (Eq a, Hashable a) => Exts.IsList (HashSet a) where + type Item (HashSet a) = a + fromList = fromList + toList = toList +#endif diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs --- a/benchmarks/Benchmarks.hs +++ b/benchmarks/Benchmarks.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE CPP, DeriveGeneric, GADTs, PackageImports, RecordWildCards #-} +{-# LANGUAGE CPP, DeriveAnyClass, DeriveGeneric, GADTs, PackageImports, RecordWildCards #-} module Main where import Control.DeepSeq -import Control.DeepSeq.Generics (genericRnf) import Gauge (bench, bgroup, defaultMain, env, nf, whnf) import Data.Bits ((.&.)) import Data.Functor.Identity @@ -56,18 +55,24 @@ elemsDupBS :: ![(BS.ByteString, Int)], elemsDupI :: ![(Int, Int)], - hm :: !(HM.HashMap String Int), - hmbs :: !(HM.HashMap BS.ByteString Int), - hmi :: !(HM.HashMap Int Int), - hmi2 :: !(HM.HashMap Int Int), - m :: !(M.Map String Int), - mbs :: !(M.Map BS.ByteString Int), - im :: !(IM.IntMap Int), - ihm :: !(IHM.Map String Int), - ihmbs :: !(IHM.Map BS.ByteString Int) - } deriving Generic - -instance NFData Env where rnf = genericRnf + hm :: !(HM.HashMap String Int), + hmSubset :: !(HM.HashMap String Int), + hmbs :: !(HM.HashMap BS.ByteString Int), + hmbsSubset :: !(HM.HashMap BS.ByteString Int), + hmi :: !(HM.HashMap Int Int), + hmiSubset :: !(HM.HashMap Int Int), + hmi2 :: !(HM.HashMap Int Int), + m :: !(M.Map String Int), + mSubset :: !(M.Map String Int), + mbs :: !(M.Map BS.ByteString Int), + mbsSubset :: !(M.Map BS.ByteString Int), + im :: !(IM.IntMap Int), + imSubset :: !(IM.IntMap Int), + ihm :: !(IHM.Map String Int), + ihmSubset :: !(IHM.Map String Int), + ihmbs :: !(IHM.Map BS.ByteString Int), + ihmbsSubset :: !(IHM.Map BS.ByteString Int) + } deriving (Generic, NFData) setupEnv :: IO Env setupEnv = do @@ -92,16 +97,29 @@ elemsDupBS = zip keysDupBS [1..n] elemsDupI = zip keysDupI [1..n] - hm = HM.fromList elems - hmbs = HM.fromList elemsBS - hmi = HM.fromList elemsI - hmi2 = HM.fromList elemsI2 - m = M.fromList elems - mbs = M.fromList elemsBS - im = IM.fromList elemsI - ihm = IHM.fromList elems - ihmbs = IHM.fromList elemsBS + hm = HM.fromList elems + hmSubset = HM.fromList (takeSubset n elems) + hmbs = HM.fromList elemsBS + hmbsSubset = HM.fromList (takeSubset n elemsBS) + hmi = HM.fromList elemsI + hmiSubset = HM.fromList (takeSubset n elemsI) + hmi2 = HM.fromList elemsI2 + m = M.fromList elems + mSubset = M.fromList (takeSubset n elems) + mbs = M.fromList elemsBS + mbsSubset = M.fromList (takeSubset n elemsBS) + im = IM.fromList elemsI + imSubset = IM.fromList (takeSubset n elemsI) + ihm = IHM.fromList elems + ihmSubset = IHM.fromList (takeSubset n elems) + ihmbs = IHM.fromList elemsBS + ihmbsSubset = IHM.fromList (takeSubset n elemsBS) return Env{..} + where + takeSubset n elements = + -- use 50% of the elements for a subset check. + let subsetSize = round (fromIntegral n * 0.5 :: Double) :: Int + in take subsetSize elements main :: IO () main = do @@ -143,6 +161,10 @@ [ bench "String" $ whnf M.fromList elems , bench "ByteString" $ whnf M.fromList elemsBS ] + , bgroup "isSubmapOf" + [ bench "String" $ whnf (M.isSubmapOf mSubset) m + , bench "ByteString" $ whnf (M.isSubmapOf mbsSubset) mbs + ] ] -- ** Map from the hashmap package @@ -180,6 +202,10 @@ [ bench "String" $ whnf IHM.fromList elems , bench "ByteString" $ whnf IHM.fromList elemsBS ] + , bgroup "isSubmapOf" + [ bench "String" $ whnf (IHM.isSubmapOf ihmSubset) ihm + , bench "ByteString" $ whnf (IHM.isSubmapOf ihmbsSubset) ihmbs + ] , bgroup "hash" [ bench "String" $ whnf hash hm , bench "ByteString" $ whnf hash hmbs @@ -197,6 +223,7 @@ , bench "delete-miss" $ whnf (deleteIM keysI') im , bench "size" $ whnf IM.size im , bench "fromList" $ whnf IM.fromList elemsI + , bench "isSubmapOf" $ whnf (IM.isSubmapOf imSubset) im ] , env setupEnv $ \ ~(Env{..}) -> @@ -272,6 +299,16 @@ , bench "ByteString" $ whnf (alterFDelete keysBS') hmbs , bench "Int" $ whnf (alterFDelete keysI') hmi ] + , bgroup "isSubmapOf" + [ bench "String" $ whnf (HM.isSubmapOf hmSubset) hm + , bench "ByteString" $ whnf (HM.isSubmapOf hmbsSubset) hmbs + , bench "Int" $ whnf (HM.isSubmapOf hmiSubset) hmi + ] + , bgroup "isSubmapOfNaive" + [ bench "String" $ whnf (isSubmapOfNaive hmSubset) hm + , bench "ByteString" $ whnf (isSubmapOfNaive hmbsSubset) hmbs + , bench "Int" $ whnf (isSubmapOfNaive hmiSubset) hmi + ] -- Combine , bench "union" $ whnf (HM.union hmi) hmi2 @@ -398,6 +435,12 @@ -> HM.HashMap String Int #-} {-# 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 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 #-} ------------------------------------------------------------------------ -- * Map diff --git a/tests/HashMapProperties.hs b/tests/HashMapProperties.hs --- a/tests/HashMapProperties.hs +++ b/tests/HashMapProperties.hs @@ -1,4 +1,5 @@ {-# 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. @@ -15,13 +16,15 @@ 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, (==>), (===)) +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) @@ -38,6 +41,9 @@ 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 @@ -225,6 +231,44 @@ `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 @@ -439,6 +483,18 @@ , 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 diff --git a/tests/List.hs b/tests/List.hs --- a/tests/List.hs +++ b/tests/List.hs @@ -1,6 +1,6 @@ module Main (main) where -import Data.HashMap.List +import Data.HashMap.Internal.List import Data.List (nub, sort, sortBy) import Data.Ord (comparing) @@ -9,7 +9,7 @@ import Test.QuickCheck ((==>), (===), property, Property) tests :: Test -tests = testGroup "Data.HashMap.List" +tests = testGroup "Data.HashMap.Internal.List" [ testProperty "isPermutationBy" pIsPermutation , testProperty "isPermutationBy of different length" pIsPermutationDiffLength , testProperty "pUnorderedCompare" pUnorderedCompare 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.11.0 +version: 0.2.12.0 synopsis: Efficient hashing-based container types description: Efficient hashing-based container types. The containers have been @@ -37,17 +37,15 @@ library exposed-modules: + Data.HashMap.Internal + Data.HashMap.Internal.Array + Data.HashMap.Internal.List + Data.HashMap.Internal.Strict + Data.HashMap.Internal.Unsafe Data.HashMap.Lazy Data.HashMap.Strict Data.HashSet - other-modules: - Data.HashMap.Array - Data.HashMap.Base - Data.HashMap.Strict.Base - Data.HashMap.List - Data.HashMap.Unsafe - Data.HashMap.UnsafeShift - Data.HashSet.Base + Data.HashSet.Internal build-depends: base >= 4.7 && < 5, @@ -131,7 +129,7 @@ hs-source-dirs: tests . main-is: List.hs other-modules: - Data.HashMap.List + Data.HashMap.Internal.List type: exitcode-stdio-1.0 build-depends: @@ -199,8 +197,7 @@ bytestring, containers, gauge >= 0.2.5 && < 0.3, - deepseq >= 1.1, - deepseq-generics, + deepseq >= 1.4, hashable >= 1.0.1.1, hashmap, mtl,