unordered-containers 0.2.11.0 → 0.2.12.0

raw patch · 21 files changed

+4531/−4077 lines, 21 filesdep −deepseq-genericsdep ~deepseqPVP ok

version bump matches the API change (PVP)

Dependencies removed: deepseq-generics

Dependency ranges changed: deepseq

API changes (from Hackage documentation)

Files

• CHANGES.md +22/−0
• Data/HashMap/Array.hs +0/−619
• Data/HashMap/Base.hs +0/−2132
• Data/HashMap/Internal.hs +2279/−0
• Data/HashMap/Internal/Array.hs +623/−0
• Data/HashMap/Internal/List.hs +82/−0
• Data/HashMap/Internal/Strict.hs +754/−0
• Data/HashMap/Internal/Unsafe.hs +55/−0
• Data/HashMap/Lazy.hs +4/−2
• Data/HashMap/List.hs +0/−66
• Data/HashMap/Strict.hs +4/−2
• Data/HashMap/Strict/Base.hs +0/−732
• Data/HashMap/Unsafe.hs +0/−39
• Data/HashMap/UnsafeShift.hs +0/−16
• Data/HashSet.hs +90/−20
• Data/HashSet/Base.hs +0/−411
• Data/HashSet/Internal.hs +484/−0
• benchmarks/Benchmarks.hs +66/−23
• tests/HashMapProperties.hs +57/−1
• tests/List.hs +2/−2
• unordered-containers.cabal +9/−12

@@ -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`).

@@ -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- #-}

@@ -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--- <https://hackage.haskell.org/package/lens-4.15.4/docs/Control-Lens-At.html#v:at Control.Lens.At>.------ @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

@@ -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+-- <https://hackage.haskell.org/package/lens/docs/Control-Lens-At.html#v:at Control.Lens.At>.+--+-- @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

@@ -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+ #-}

@@ -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)

@@ -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+-- <https://hackage.haskell.org/package/lens/docs/Control-Lens-At.html#v:at Control.Lens.At>.+--+-- @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 #-}

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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--- <https://hackage.haskell.org/package/lens-4.15.4/docs/Control-Lens-At.html#v:at Control.Lens.At>.------ @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 #-}

@@ -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

@@ -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 #-}

@@ -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+<https://hackage.haskell.org/package/containers containers> package.+++== Examples++All the examples below assume @HashSet@ is imported qualified, and uses the following @dataStructures@ set.++>>> import qualified Data.HashSet as HashSet+>>> let dataStructures = HashSet.fromList ["Set", "Map", "Graph", "Sequence"]++=== Basic Operations++Check membership in a set:++>>> -- Check if "Map" and "Trie" are in the set of data structures.+>>> HashSet.member "Map" dataStructures+True+>>> HashSet.member "Trie" dataStructures+False++Add a new entry to the set:++>>> let moreDataStructures = HashSet.insert "Trie" dataStructures+>>> HashSet.member "Trie" moreDataStructures+> True++Remove the @\"Graph\"@ entry from the set of data structures.++>>> let fewerDataStructures = HashSet.delete "Graph" dataStructures+>>> HashSet.toList fewerDataStructures+["Map","Set","Sequence"]+++Create a new set and combine it with our original set.++>>> let unorderedDataStructures = HashSet.fromList ["HashSet", "HashMap"]+>>> HashSet.union dataStructures unorderedDataStructures+fromList ["Map","HashSet","Graph","HashMap","Set","Sequence"]++=== Using custom data with HashSet++To create a @HashSet@ of your custom type, the type must have instances for+'Data.Eq.Eq' and 'Data.Hashable.Hashable'. The @Hashable@ typeclass is defined in the+<https://hackage.haskell.org/package/hashable hashable> package, see the+documentation for information on how to make your type an instance of+@Hashable@.++We'll start by setting up our custom data type:++>>> :set -XDeriveGeneric+>>> import GHC.Generics (Generic)+>>> import Data.Hashable+>>> data Person = Person { name :: String, likesDogs :: Bool } deriving (Show, Eq, Generic)+>>> instance Hashable Person++And now we'll use it!++>>> let people = HashSet.fromList [Person "Lana" True, Person "Joe" False, Person "Simon" True]+>>> HashSet.filter likesDogs people+fromList [Person {name = "Simon", likesDogs = True},Person {name = "Lana", likesDogs = True}]+++== Performance++The implementation is based on /hash array mapped tries/.  A+'HashSet' is often faster than other 'Data.Ord.Ord'-based set types,+especially when value comparisons are expensive, as in the case of+strings.++Many operations have a average-case complexity of /O(log n)/.  The+implementation uses a large base (i.e. 16) 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 ()

@@ -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