unordered-containers 0.1.4.6 → 0.2.0.0
raw patch · 23 files changed
+2363/−2075 lines, 23 filesdep ~basedep ~containersdep ~hashablePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, containers, hashable, test-framework, test-framework-quickcheck2
API changes (from Hackage documentation)
- Data.HashMap.Lazy: union :: Eq k => HashMap k v -> HashMap k v -> HashMap k v
+ Data.HashMap.Lazy: union :: (Eq k, Hashable k) => HashMap k v -> HashMap k v -> HashMap k v
- Data.HashMap.Lazy: unionWith :: Eq k => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
+ Data.HashMap.Lazy: unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
- Data.HashMap.Strict: union :: Eq k => HashMap k v -> HashMap k v -> HashMap k v
+ Data.HashMap.Strict: union :: (Eq k, Hashable k) => HashMap k v -> HashMap k v -> HashMap k v
- Data.HashMap.Strict: unionWith :: Eq k => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
+ Data.HashMap.Strict: unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
Files
- Data/FullList/Lazy.hs +0/−353
- Data/FullList/Strict.hs +0/−132
- Data/HashMap/Array.hs +413/−0
- Data/HashMap/Base.hs +947/−0
- Data/HashMap/Common.hs +0/−338
- Data/HashMap/Lazy.hs +21/−298
- Data/HashMap/Lazy/Internal.hs +0/−48
- Data/HashMap/PopCount.hs +19/−0
- Data/HashMap/Strict.hs +226/−94
- Data/HashMap/Strict/Internal.hs +0/−19
- Data/HashMap/UnsafeShift.hs +16/−0
- Data/HashSet.hs +8/−9
- benchmarks/Benchmarks.hs +0/−232
- benchmarks/Makefile +0/−45
- benchmarks/Util/ByteString.hs +0/−29
- benchmarks/Util/Int.hs +0/−19
- benchmarks/Util/String.hs +0/−34
- cbits/popc.c +273/−0
- tests/HashMapProperties.hs +220/−0
- tests/HashSetProperties.hs +171/−0
- tests/MapProperties.hs +0/−222
- tests/SetProperties.hs +0/−171
- unordered-containers.cabal +49/−32
− Data/FullList/Lazy.hs
@@ -1,353 +0,0 @@-{-# LANGUAGE BangPatterns, CPP #-}----------------------------------------------------------------------------- |--- Module : Data.FullList.Lazy--- Copyright : 2010-2011 Johan Tibell--- License : BSD-style--- Maintainer : johan.tibell@gmail.com--- Stability : provisional--- Portability : portable------ Non-empty lists of key/value pairs. The lists are strict in the--- keys and lazy in the values.--module Data.FullList.Lazy- ( FullList(..)- , List(..)-- -- * Basic interface- , size- , singleton- , lookup- , insert- , delete- , insertWith- , adjust-- -- * Combine- -- * Union- , union- , unionWith-- -- * Transformations- , map- , traverseWithKey-- -- * Folds- , foldlWithKey'- , foldrWithKey-- -- * Filter- , filterWithKey- -- * For use by FL.Strict- , lookupL- , deleteL- ) where--import Control.Applicative-import Control.DeepSeq (NFData(rnf))-import Prelude hiding (lookup, map)----------------------------------------------------------------------------- * The 'FullList' type---- The 'FullList' type has two benefits:------ * it is guaranteed to be non-empty, and------ * it can be unpacked into a data constructor.---- Invariant: the same key only appears once in a 'FullList'.---- | A non-empty list of key/value pairs.-data FullList k v = FL !k v !(List k v)- deriving Show--instance (Eq k, Eq v) => Eq (FullList k v) where- (FL k1 v1 xs) == (FL k2 v2 ys) = k1 == k2 && v1 == v2 && xs == ys- (FL k1 v1 xs) /= (FL k2 v2 ys) = k1 /= k2 || v1 /= v2 || xs /= ys--instance (NFData k, NFData v) => NFData (FullList k v)--data List k v = Nil | Cons !k v !(List k v)- deriving Show--instance (Eq k, Eq v) => Eq (List k v) where- (Cons k1 v1 xs) == (Cons k2 v2 ys) = k1 == k2 && v1 == v2 && xs == ys- Nil == Nil = True- _ == _ = False-- (Cons k1 v1 xs) /= (Cons k2 v2 ys) = k1 /= k2 || v1 /= v2 || xs /= ys- Nil /= Nil = False- _ /= _ = True--instance (NFData k, NFData v) => NFData (List k v) where- rnf Nil = ()- rnf (Cons k v xs) = rnf k `seq` rnf v `seq` rnf xs---- TODO: Check if evaluation is forced.----------------------------------------------------------------------------- * FullList---- The 'List' functions are not inlined as they should be seldomly--- called in practice (i.e. we expect few collisions.)--size :: FullList k v -> Int-size (FL _ _ xs) = 1 + sizeL xs--sizeL :: List k v -> Int-sizeL Nil = 0-sizeL (Cons _ _ xs) = 1 + sizeL xs--singleton :: k -> v -> FullList k v-singleton k v = FL k v Nil--lookup :: Eq k => k -> FullList k v -> Maybe v-lookup !k (FL k' v xs)- | k == k' = Just v- | otherwise = lookupL k xs-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE lookup #-}-#endif--lookupL :: Eq k => k -> List k v -> Maybe v-lookupL = go- where- go !_ Nil = Nothing- go k (Cons k' v xs)- | k == k' = Just v- | otherwise = go k xs-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE lookupL #-}-#endif--member :: Eq k => k -> FullList k v -> Bool-member !k (FL k' _ xs)- | k == k' = True- | otherwise = memberL k xs-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE member #-}-#endif--memberL :: Eq k => k -> List k v -> Bool-memberL = go- where- go !_ Nil = False- go k (Cons k' _ xs)- | k == k' = True- | otherwise = go k xs-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE memberL #-}-#endif--insert :: Eq k => k -> v -> FullList k v -> FullList k v-insert !k v (FL k' v' xs)- | k == k' = FL k v xs- | otherwise = FL k' v' (insertL k v xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insert #-}-#endif---- | /O(n)/ Insert at the head of the list to avoid copying the whole--- list.-insertL :: Eq k => k -> v -> List k v -> List k v-insertL = go- where- go !k v Nil = Cons k v Nil- go k v (Cons k' v' xs)- | k == k' = Cons k v xs- | otherwise = Cons k' v' (go k v xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertL #-}-#endif--delete :: Eq k => k -> FullList k v -> Maybe (FullList k v)-delete !k (FL k' v xs)- | k == k' = case xs of- Nil -> Nothing- Cons k'' v' xs' -> Just $ FL k'' v' xs'- | otherwise = let ys = deleteL k xs- in ys `seq` Just (FL k' v ys)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE delete #-}-#endif--deleteL :: Eq k => k -> List k v -> List k v-deleteL = go- where- go !_ Nil = Nil- go k (Cons k' v xs)- | k == k' = xs- | otherwise = Cons k' v (go k xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE deleteL #-}-#endif--insertWith :: Eq k => (v -> v -> v) -> k -> v -> FullList k v -> FullList k v-insertWith f !k v (FL k' v' xs)- | k == k' = FL k (f v v') xs- | otherwise = FL k' v' (insertWithL f k v xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertWith #-}-#endif--insertWithL :: Eq k => (v -> v -> v) -> k -> v -> List k v -> List k v-insertWithL = go- where- go _ !k v Nil = Cons k v Nil- go f k v (Cons k' v' xs)- | k == k' = Cons k (f v v') xs- | otherwise = Cons k' v' (go f k v xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertWithL #-}-#endif--adjust :: Eq k => (v -> v) -> k -> FullList k v -> FullList k v-adjust f !k (FL k' v xs)- | k == k' = FL k' (f v) xs- | otherwise = FL k' v (adjustL f k xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE adjust #-}-#endif--adjustL :: Eq k => (v -> v) -> k -> List k v -> List k v-adjustL f = go- where- go !_ Nil = Nil- go k (Cons k' v xs)- | k == k' = Cons k' (f v) xs- | otherwise = Cons k' v (go k xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE adjustL #-}-#endif----------------------------------------------------------------------------- * Combine---- | /O(n^2)/ Left biased union.-union :: Eq k => FullList k v -> FullList k v -> FullList k v-union xs (FL k v ys)- | k `member` xs = unionL xs ys- | otherwise = case unionL xs ys of- FL k' v' zs -> FL k v $ Cons k' v' zs-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE union #-}-#endif--unionL :: Eq k => FullList k v -> List k v -> FullList k v-unionL xs@(FL k v zs) = FL k v . go- where- go Nil = zs- go (Cons k' v' ys)- | k' `member` xs = go ys- | otherwise = Cons k' v' $ go ys-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE unionL #-}-#endif--unionWith :: Eq k => (v -> v -> v) -> FullList k v -> FullList k v -> FullList k v-unionWith f xs (FL k vy ys) =- case lookup k xs of- Just vx ->- let flCon = FL k (f vx vy)- in case delete k xs of- Nothing -> flCon ys- Just xs' ->- case unionWithL f xs' ys of- FL k' v' zs -> flCon $ Cons k' v' zs- Nothing ->- case unionWithL f xs ys of- FL k' v' zs -> FL k vy $ Cons k' v' zs-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE unionWith #-}-#endif--unionWithL :: Eq k => (v -> v -> v) -> FullList k v -> List k v -> FullList k v-unionWithL f (FL k v zs) ys =- case lookupL k ys of - Just vy -> FL k (f v vy) $ go zs (deleteL k ys)- Nothing -> FL k v (go zs ys)- where- go ws Nil = ws- go ws (Cons k' vy ys') =- case lookupL k' ws of- Just vx -> Cons k' (f vx vy) $ go (deleteL k' ws) ys'- Nothing -> Cons k' vy $ go ws ys'-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE unionWithL #-}-#endif----------------------------------------------------------------------------- * Transformations--map :: (k1 -> v1 -> (k2, v2)) -> FullList k1 v1 -> FullList k2 v2-map f (FL k v xs) = let (k', v') = f k v- in FL k' v' (mapL f xs)-{-# INLINE map #-}--mapL :: (k1 -> v1 -> (k2, v2)) -> List k1 v1 -> List k2 v2-mapL f = go- where- go Nil = Nil- go (Cons k v xs) = let (k', v') = f k v- in Cons k' v' (go xs)-{-# INLINE mapL #-}--traverseWithKey :: Applicative m => (k -> v1 -> m v2) -> FullList k v1 -> m (FullList k v2)-traverseWithKey f (FL k v xs) = FL k <$> f k v <*> traverseWithKeyL f xs-{-# INLINE traverseWithKey #-}--traverseWithKeyL :: Applicative m => (k -> v1 -> m v2) -> List k v1 -> m (List k v2)-traverseWithKeyL f = go- where- go Nil = pure Nil- go (Cons k v xs) = Cons k <$> f k v <*> go xs-{-# INLINE traverseWithKeyL #-}----------------------------------------------------------------------------- * Folds--foldlWithKey' :: (a -> k -> v -> a) -> a -> FullList k v -> a-foldlWithKey' f !z (FL k v xs) = foldlWithKey'L f (f z k v) xs-{-# INLINE foldlWithKey' #-}--foldlWithKey'L :: (a -> k -> v -> a) -> a -> List k v -> a-foldlWithKey'L f = go- where- go !z Nil = z- go z (Cons k v xs) = go (f z k v) xs-{-# INLINE foldlWithKey'L #-}--foldrWithKey :: (k -> v -> a -> a) -> a -> FullList k v -> a-foldrWithKey f z (FL k v xs) = f k v (foldrWithKeyL f z xs)-{-# INLINE foldrWithKey #-}--foldrWithKeyL :: (k -> v -> a -> a) -> a -> List k v -> a-foldrWithKeyL f = go- where- go z Nil = z- go z (Cons k v xs) = f k v (go z xs)-{-# INLINE foldrWithKeyL #-}----------------------------------------------------------------------------- * Filter--filterWithKey :: (k -> v -> Bool) -> FullList k v -> Maybe (FullList k v)-filterWithKey p (FL k v xs)- | p k v = Just (FL k v ys)- | otherwise = case ys of- Nil -> Nothing- Cons k' v' zs -> Just $ FL k' v' zs- where !ys = filterWithKeyL p xs-{-# INLINE filterWithKey #-}--filterWithKeyL :: (k -> v -> Bool) -> List k v -> List k v-filterWithKeyL p = go- where- go Nil = Nil- go (Cons k v xs)- | p k v = Cons k v (go xs)- | otherwise = go xs-{-# INLINE filterWithKeyL #-}
− Data/FullList/Strict.hs
@@ -1,132 +0,0 @@-{-# LANGUAGE BangPatterns, CPP #-}----------------------------------------------------------------------------- |--- Module : Data.FullList.Strict--- Copyright : 2010-2011 Johan Tibell--- License : BSD-style--- Maintainer : johan.tibell@gmail.com--- Stability : provisional--- Portability : portable------ Non-empty lists of key/value pairs. The lists are strict in the--- keys and the values.--module Data.FullList.Strict- ( FullList-- -- * Basic interface- , size- , singleton- , lookup- , insert- , delete- , insertWith- , adjust-- -- * Combine- -- ** Union- , unionWith-- -- * Transformations- , map- , traverseWithKey-- -- * Folds- , foldlWithKey'- , foldrWithKey-- -- * Filter- , filterWithKey- ) where--import Prelude hiding (lookup, map)--import Data.FullList.Lazy hiding (insertWith, map, adjust, unionWith)--insertWith :: Eq k => (v -> v -> v) -> k -> v -> FullList k v -> FullList k v-insertWith f !k v (FL k' v' xs)- | k == k' = let v'' = f v v' in v'' `seq` FL k v'' xs- | otherwise = FL k' v' (insertWithL f k v xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertWith #-}-#endif--insertWithL :: Eq k => (v -> v -> v) -> k -> v -> List k v -> List k v-insertWithL = go- where- go _ !k v Nil = Cons k v Nil- go f k v (Cons k' v' xs)- | k == k' = let v'' = f v v' in v'' `seq` Cons k v'' xs- | otherwise = Cons k' v' (go f k v xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertWithL #-}-#endif--adjust :: Eq k => (v -> v) -> k -> FullList k v -> FullList k v-adjust f !k (FL k' v xs)- | k == k' = let v' = f v in v' `seq` FL k' v' xs- | otherwise = FL k' v (adjustL f k xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE adjust #-}-#endif--adjustL :: Eq k => (v -> v) -> k -> List k v -> List k v-adjustL f = go- where- go !_ Nil = Nil- go k (Cons k' v xs)- | k == k' = let v' = f v in v' `seq` Cons k' v' xs- | otherwise = Cons k' v (go k xs)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE adjustL #-}-#endif----------------------------------------------------------------------------- * Transformations--map :: (k1 -> v1 -> (k2, v2)) -> FullList k1 v1 -> FullList k2 v2-map f (FL k v xs) = let !(k', !v') = f k v- in FL k' v' (mapL f xs)-{-# INLINE map #-}--mapL :: (k1 -> v1 -> (k2, v2)) -> List k1 v1 -> List k2 v2-mapL f = go- where- go Nil = Nil- go (Cons k v xs) = let !(k', !v') = f k v- in Cons k' v' (go xs)-{-# INLINE mapL #-}--unionWith :: Eq k => (v -> v -> v) -> FullList k v -> FullList k v -> FullList k v-unionWith f xs (FL k vy ys) =- case lookup k xs of- Just vx ->- let !vFinal = f vx vy- flCon = FL k vFinal- in case delete k xs of- Nothing -> flCon ys- Just xs' ->- case unionWithL f xs' ys of- FL k' v' zs -> flCon $ Cons k' v' zs- Nothing ->- case unionWithL f xs ys of- FL k' v' zs -> FL k vy $ Cons k' v' zs-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE unionWith #-}-#endif--unionWithL :: Eq k => (v -> v -> v) -> FullList k v -> List k v -> FullList k v-unionWithL f (FL k v zs) ys =- case lookupL k ys of- Just vy -> let !vFinal = f v vy in FL k vFinal $ go zs (deleteL k ys)- Nothing -> FL k v (go zs ys)- where- go ws Nil = ws- go ws (Cons k' vy ys') =- case lookupL k' ws of- Just vx -> let !vFinal = f vx vy in Cons k' vFinal $ go (deleteL k' ws) ys'- Nothing -> Cons k' vy $ go ws ys'-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE unionWithL #-}-#endif
+ Data/HashMap/Array.hs view
@@ -0,0 +1,413 @@+{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++-- | Zero based arrays.+--+-- Note that no bounds checking are performed.+module Data.HashMap.Array+ ( Array+ , MArray++ -- * Creation+ , new+ , new_+ , singleton+ , singleton'+ , pair++ -- * Basic interface+ , length+ , lengthM+ , read+ , write+ , index+ , index_+ , indexM_+ , update+ , update'+ , updateWith+ , insert+ , insert'+ , delete+ , delete'++ , unsafeFreeze+ , run+ , run2+ , copy+ , copyM++ -- * Folds+ , foldl'+ , foldr++ , thaw+ , map+ , map'+ , traverse+ , filter+ ) where++import qualified Data.Traversable as Traversable+import Control.Applicative (Applicative)+import Control.DeepSeq+import Control.Monad.ST+import GHC.Exts+import GHC.ST (ST(..))+import Prelude hiding (filter, foldr, length, map, read)++------------------------------------------------------------------------++#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_)+#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_)+#endif++data Array a = Array {+ unArray :: !(Array# a)+#if __GLASGOW_HASKELL__ < 702+ , length :: !Int+#endif+ }++instance Show a => Show (Array a) where+ show = show . toList++#if __GLASGOW_HASKELL__ >= 702+length :: Array a -> Int+length ary = I# (sizeofArray# (unArray ary))+{-# INLINE length #-}+#endif++-- | Smart constructor+array :: Array# a -> Int -> Array a+#if __GLASGOW_HASKELL__ >= 702+array ary _n = Array ary+#else+array = Array+#endif+{-# INLINE array #-}++data MArray s a = MArray {+ unMArray :: !(MutableArray# s a)+#if __GLASGOW_HASKELL__ < 702+ , lengthM :: !Int+#endif+ }++#if __GLASGOW_HASKELL__ >= 702+lengthM :: MArray s a -> Int+lengthM mary = I# (sizeofMutableArray# (unMArray mary))+{-# INLINE lengthM #-}+#endif++-- | Smart constructor+marray :: MutableArray# s a -> Int -> MArray s a+#if __GLASGOW_HASKELL__ >= 702+marray mary _n = MArray mary+#else+marray = MArray+#endif+{-# 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 = ()+ | otherwise = rnf (index ary i) `seq` go ary n (i+1)+{-# 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 (singleton' x)+{-# INLINE singleton #-}++singleton' :: a -> ST s (Array a)+singleton' x = new 1 x >>= unsafeFreeze+{-# INLINE singleton' #-}++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 -> ST s a+index_ ary _i@(I# i#) =+ CHECK_BOUNDS("index_", length ary, _i)+ case indexArray# (unArray ary) i# of (# b #) -> return b+{-# INLINE index_ #-}++indexM_ :: MArray s a -> Int -> ST s a+indexM_ ary _i@(I# i#) =+ CHECK_BOUNDS("index_", lengthM ary, _i)+ ST $ \ s# -> readArray# (unMArray ary) i# s#+{-# 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 #-}++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 ()+#if __GLASGOW_HASKELL__ >= 702+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, () #)+#else+copy !src !sidx !dst !didx n =+ CHECK_LE("copy", sidx + n, length src)+ CHECK_LE("copy", didx + n, lengthM dst)+ copy_loop sidx didx 0+ where+ copy_loop !i !j !c+ | c >= n = return ()+ | otherwise = do b <- index_ src i+ write dst j b+ copy_loop (i+1) (j+1) (c+1)+#endif++-- | Unsafely copy the elements of an array. Array bounds are not checked.+copyM :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s ()+#if __GLASGOW_HASKELL__ >= 702+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, () #)+#else+copyM !src !sidx !dst !didx n =+ CHECK_BOUNDS("copyM: src", lengthM src, sidx + n - 1)+ CHECK_BOUNDS("copyM: dst", lengthM dst, didx + n - 1)+ copy_loop sidx didx 0+ where+ copy_loop !i !j !c+ | c >= n = return ()+ | otherwise = do b <- indexM_ src i+ write dst j b+ copy_loop (i+1) (j+1) (c+1)+#endif++-- | /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 (insert' ary idx b)+{-# INLINE insert #-}++-- | /O(n)/ Insert an element at the given position in this array,+-- increasing its size by one.+insert' :: Array e -> Int -> e -> ST s (Array e)+insert' ary idx b =+ CHECK_BOUNDS("insert'", 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 insert' #-}++-- | /O(n)/ Update the element at the given position in this array.+update :: Array e -> Int -> e -> Array e+update ary idx b = runST (update' ary idx b)+{-# INLINE update #-}++-- | /O(n)/ Update the element at the given position in this array.+update' :: Array e -> Int -> e -> ST s (Array e)+update' ary idx b =+ CHECK_BOUNDS("update'", count, idx)+ do mary <- thaw ary 0 count+ write mary idx b+ unsafeFreeze mary+ where !count = length ary+{-# INLINE update' #-}++-- | /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 = update ary idx $! f (index ary idx)+{-# INLINE updateWith #-}++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 = go ary n (i+1) (f z (index ary i))+{-# INLINE foldl' #-}++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 = f (index ary i) (go ary n (i+1) z)+{-# INLINE foldr #-}++undefinedElem :: a+undefinedElem = error "Data.HashMap.Array: Undefined element"+{-# NOINLINE undefinedElem #-}++thaw :: Array e -> Int -> Int -> ST s (MArray s e)+#if __GLASGOW_HASKELL__ >= 702+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 #)+#else+thaw !ary !o !n =+ CHECK_LE("thaw", o + n, length ary)+ do mary <- new_ n+ copy ary o mary 0 n+ return mary+#endif+{-# 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 (delete' ary idx)+{-# INLINE delete #-}++-- | /O(n)/ Delete an element at the given position in this array,+-- decreasing its size by one.+delete' :: Array e -> Int -> ST s (Array e)+delete' ary 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 delete' #-}++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+ write mary i $ f (index ary i)+ 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+ write mary i $! f (index ary i)+ go ary mary (i+1) n+{-# INLINE map' #-}++fromList :: Int -> [a] -> Array a+fromList n 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 (:) []++traverse :: Applicative f => (a -> f b) -> Array a -> f (Array b)+traverse f = \ ary -> fromList (length ary) `fmap`+ Traversable.traverse f (toList ary)+{-# INLINE traverse #-}++filter :: (a -> Bool) -> Array a -> Array a+filter p = \ ary ->+ let !n = length ary+ in run $ do+ mary <- new_ n+ go ary mary 0 0 n+ where+ go ary mary i j n+ | i >= n = if i == j+ then return mary+ else do mary2 <- new_ j+ copyM mary 0 mary2 0 j+ return mary2+ | p el = write mary j el >> go ary mary (i+1) (j+1) n+ | otherwise = go ary mary (i+1) j n+ where el = index ary i+{-# INLINE filter #-}
+ Data/HashMap/Base.hs view
@@ -0,0 +1,947 @@+{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, MagicHash #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++module Data.HashMap.Base+ (+ HashMap(..)+ , Leaf(..)++ -- * Construction+ , empty+ , singleton++ -- * Basic interface+ , null+ , size+ , lookup+ , lookupDefault+ , insert+ , insertWith+ , delete+ , adjust++ -- * Combine+ -- ** Union+ , union+ , unionWith++ -- * Transformations+ , map+ , traverseWithKey++ -- * Difference and intersection+ , difference+ , intersection++ -- * Folds+ , foldl'+ , foldlWithKey'+ , foldr+ , foldrWithKey++ -- * Filter+ , filter+ , filterWithKey++ -- * Conversions+ , keys+ , elems++ -- ** Lists+ , toList+ , fromList+ , fromListWith++ -- Internals used by the strict version+ , Bitmap+ , bitmapIndexedOrFull+ , collision+ , hash+ , mask+ , index+ , bitsPerSubkey+ , fullNodeMask+ , sparseIndex+ , two+ , unionArrayBy+ , update16+ , update16'+ , update16With+ , updateOrConcatWith+ ) where++import Control.Applicative ((<$>), Applicative(pure))+import Control.DeepSeq (NFData(rnf))+import Control.Monad.ST (ST, runST)+import Data.Bits ((.&.), (.|.), complement)+import qualified Data.Foldable as Foldable+import qualified Data.List as L+import Data.Monoid (Monoid(mempty, mappend))+import Data.Traversable (Traversable(..))+import Data.Word (Word)+import Prelude hiding (filter, foldr, lookup, map, null, pred)++import qualified Data.HashMap.Array as A+import qualified Data.Hashable as H+import Data.Hashable (Hashable)+import Data.HashMap.PopCount (popCount)+import Data.HashMap.UnsafeShift (unsafeShiftL, unsafeShiftR)+import Data.Typeable (Typeable)++#if defined(__GLASGOW_HASKELL__)+import GHC.Exts ((==#), build, reallyUnsafePtrEquality#)+#endif++------------------------------------------------------------------------++-- | 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++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)++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+ foldr f = foldrWithKey (const f)++instance (Eq k, Hashable k) => Monoid (HashMap k v) where+ mempty = empty+ {-# INLINE mempty #-}+ mappend = union+ {-# INLINE mappend #-}++type Hash = Word+type Bitmap = Word+type Shift = Int++instance (Show k, Show v) => Show (HashMap k v) where+ show m = "fromList " ++ show (toList m)++instance Traversable (HashMap k) where+ traverse f = traverseWithKey (const f)++-- NOTE: This is just a placeholder.+instance (Eq k, Eq v) => Eq (HashMap k v) where+ a == b = toList a == toList b++------------------------------------------------------------------------+-- * 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 the value to which the specified key is mapped,+-- or 'Nothing' if this map contains no mapping for the key.+lookup :: (Eq k, Hashable k) => k -> HashMap k v -> Maybe v+lookup k0 = go h0 k0 0+ where+ h0 = hash k0+ go !_ !_ !_ Empty = Nothing+ go h k _ (Leaf hx (L kx x))+ | h == hx && k == kx = Just x+ | otherwise = Nothing+ go h k s (BitmapIndexed b v)+ | b .&. m == 0 = Nothing+ | 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 = lookupInArray k v+ | otherwise = Nothing+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookup #-}+#endif++-- | /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.+lookupDefault :: (Eq k, Hashable k)+ => v -- ^ Default value to return.+ -> k -> HashMap k v -> v+lookupDefault def k t = case lookup k t of+ Just v -> v+ _ -> def+{-# INLINE lookupDefault #-}++-- | 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 #-}++-- TODO: Use ptrEq to check if the value being inserted is the same+-- and if so don't modify the tree at all.++-- | /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 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 ky y+ go h k x s (BitmapIndexed b ary)+ | b .&. m == 0 = do+ ary' <- A.insert' ary i $! Leaf h (L k x)+ return $! bitmapIndexedOrFull (b .|. m) ary'+ | otherwise = do+ st <- A.index_ ary i+ st' <- go h k x (s+bitsPerSubkey) st+ ary' <- A.update' ary i st'+ return $! BitmapIndexed b ary'+ where m = mask h s+ i = sparseIndex b m+ go h k x s (Full ary) = do+ st <- A.index_ ary i+ st' <- go h k x (s+bitsPerSubkey) st+ ary' <- update16' ary i st'+ return $! Full ary'+ where i = index h s+ go h k x s t@(Collision hy v)+ | h == hy = return $! Collision h (updateOrSnocWith const k x v)+ | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insert #-}+#endif++-- | Create a map from two key-value pairs which hashes don't collide.+two :: Shift -> Hash -> k -> v -> Hash -> k -> v -> ST s (HashMap k v)+two = go+ where+ go s h1 k1 v1 h2 k2 v2+ | bp1 == bp2 = do+ st <- go (s+bitsPerSubkey) h1 k1 v1 h2 k2 v2 + ary <- A.singleton' st+ return $! BitmapIndexed bp1 ary+ | otherwise = do+ mary <- A.new 2 $ Leaf h1 (L k1 v1)+ A.write mary idx2 $ Leaf h2 (L k2 v2)+ 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+insertWith f 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 (Leaf hy l@(L ky y))+ | hy == h = if ky == k+ then return $! Leaf h (L k (f x y))+ else return $! collision h l (L k x)+ | otherwise = two s h k x hy ky y+ go h k x s (BitmapIndexed b ary)+ | b .&. m == 0 = do+ ary' <- A.insert' ary i $! Leaf h (L k x)+ return $! bitmapIndexedOrFull (b .|. m) ary'+ | otherwise = do+ st <- A.index_ ary i+ st' <- go h k x (s+bitsPerSubkey) st+ ary' <- A.update' ary i st'+ return $! BitmapIndexed b ary'+ where m = mask h s+ i = sparseIndex b m+ go h k x s (Full ary) = do+ st <- A.index_ ary i+ st' <- go h k x (s+bitsPerSubkey) st+ ary' <- update16' ary i st'+ return $! Full ary'+ where i = index h s+ go h k x s t@(Collision hy v)+ | h == hy = return $! Collision h (updateOrSnocWith f k x v)+ | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertWith #-}+#endif++-- | /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 k0 m0 = runST (go h0 k0 0 m0)+ where+ h0 = hash k0+ go !_ !_ !_ Empty = return Empty+ go h k _ t@(Leaf hy (L ky _))+ | hy == h && ky == k = return Empty+ | otherwise = return t+ go h k s t@(BitmapIndexed b ary)+ | b .&. m == 0 = return t+ | otherwise = do+ let !st = A.index ary i+ !st' <- go h k (s+bitsPerSubkey) st+ if st' `ptrEq` st+ then return t+ else case st' of+ Empty | A.length ary == 1 -> return Empty+ | otherwise -> do+ ary' <- A.delete' ary i+ return $! BitmapIndexed (b .&. complement m) ary'+ _ -> do+ ary' <- A.update' ary i st'+ return $! BitmapIndexed b ary'+ where m = mask h s+ i = sparseIndex b m+ go h k s t@(Full ary) = do+ let !st = A.index ary i+ !st' <- go h k (s+bitsPerSubkey) st+ if st' `ptrEq` st+ then return t+ else case st' of+ Empty -> do+ ary' <- A.delete' ary i+ return $! BitmapIndexed (mask h s) ary'+ _ -> do+ ary' <- A.update' ary i st'+ return $! Full ary'+ 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 return $! Leaf h (A.index v 1)+ else return $! Leaf h (A.index v 0)+ | otherwise -> return $! Collision h (A.delete v i)+ Nothing -> return t+ | otherwise = return t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE delete #-}+#endif++-- | /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 = go h0 k0 0+ where+ h0 = hash k0+ go !_ !_ !_ Empty = Empty+ go h k _ t@(Leaf hy (L ky y))+ | hy == h && ky == k = Leaf h (L 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+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE adjust #-}+#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.+union :: (Eq k, Hashable k) => HashMap k v -> HashMap k v -> HashMap k v+union = unionWith const+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE union #-}+#endif++-- | /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 = 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 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 (updateOrSnocWith 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 (updateOrSnocWith (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 (updateOrConcatWith 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 unionWith #-}++-- | 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 hasBit b m = b .&. m /= 0+ go !i !i1 !i2 !m+ | m > b' = return ()+ | hasBit b1 m && hasBit b2 m = do+ A.write mary i $! f (A.index ary1 i1) (A.index ary2 i2)+ go (i+1) (i1+1) (i2+1) (m `unsafeShiftL` 1)+ | hasBit b1 m = do+ A.write mary i =<< A.index_ ary1 i1+ go (i+1) (i1+1) (i2 ) (m `unsafeShiftL` 1)+ | hasBit b2 m = do+ A.write mary i =<< A.index_ ary2 i2+ go (i+1) (i1 ) (i2+1) (m `unsafeShiftL` 1)+ | otherwise = go i i1 i2 (m `unsafeShiftL` 1)+ go 0 0 0 1+ 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 #-}++------------------------------------------------------------------------+-- * Transformations++-- | /O(n)/ Transform this map by applying a function to every value.+map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2+map f = go+ where+ go Empty = Empty+ go (Leaf h (L k v)) = Leaf h $ L k (f 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) -> L k (f v)) ary+{-# INLINE map #-}++-- | /O(n)/ Transform this map by accumulating an Applicative result+-- from every value.+traverseWithKey :: Applicative f => (k -> v1 -> f v2) -> HashMap k v1+ -> f (HashMap k v2)+traverseWithKey f = go+ where+ go 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+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+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE difference #-}+#endif++-- | /O(n+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+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE intersection #-}+#endif++------------------------------------------------------------------------+-- * Folds++-- | /O(n)/ Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- left-identity of the operator). Each application of the operator+-- is evaluated before before using the result in the next+-- application. This function is strict in the starting value.+foldl' :: (a -> v -> a) -> a -> HashMap k v -> a+foldl' f = foldlWithKey' (\ z _ v -> f z v)+{-# INLINE foldl' #-}++-- | /O(n)/ Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- left-identity of the operator). Each application of the operator+-- is evaluated before before using the result in the next+-- application. This function is strict in the starting value.+foldlWithKey' :: (a -> k -> v -> a) -> a -> HashMap k v -> a+foldlWithKey' f = go+ where+ go !z 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).+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+-- right-identity of the operator).+foldrWithKey :: (k -> v -> a -> a) -> a -> HashMap k v -> a+foldrWithKey f = go+ where+ go z Empty = z+ go z (Leaf _ (L k v)) = f k v z+ go z (BitmapIndexed _ ary) = A.foldr (flip go) z ary+ go z (Full ary) = A.foldr (flip go) z ary+ go z (Collision _ ary) = A.foldr (\ (L k v) z' -> f k v z') z ary+{-# INLINE foldrWithKey #-}++------------------------------------------------------------------------+-- * Filter++-- | Create a new array of the @n@ first elements of @mary@.+trim :: A.MArray s a -> Int -> ST s (A.Array a)+trim mary n = do+ mary2 <- A.new_ n+ A.copyM mary 0 mary2 0 n+ A.unsafeFreeze mary2+{-# INLINE trim #-}++-- | /O(n)/ Filter this map by retaining only elements satisfying a+-- predicate.+filterWithKey :: (k -> v -> Bool) -> HashMap k v -> HashMap k v+filterWithKey pred = go+ where+ go Empty = Empty+ go t@(Leaf _ (L k v))+ | pred k v = 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 !ary !mary !b i !j !bi n+ | i >= n = case j of+ 0 -> return Empty+ 1 -> A.read mary 0+ _ -> do+ ary2 <- 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 !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 <- trim mary j+ return $! Collision h ary2+ | pred k v = A.write mary j el >> step ary mary (i+1) (j+1) n+ | otherwise = step ary mary (i+1) j n+ where el@(L k v) = A.index ary i+{-# INLINE filterWithKey #-}++-- | /O(n)/ Filter this map by retaining only elements which values+-- satisfy a predicate.+filter :: (v -> Bool) -> HashMap k v -> HashMap k v+filter p = filterWithKey (\_ v -> p v)+{-# INLINE filter #-}++------------------------------------------------------------------------+-- * Conversions++-- 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.+toList :: HashMap k v -> [(k, v)]+#if defined(__GLASGOW_HASKELL__)+toList t = build (\ c z -> foldrWithKey (curry c) z t)+#else+toList = foldrWithKey (\ k v xs -> (k, v) : xs) []+#endif+{-# INLINE toList #-}++-- | /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) -> insert k v m) empty+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromList #-}+#endif++-- | /O(n*log n)/ Construct a map from a list of elements. Uses+-- the provided function to merge duplicate entries.+fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v+fromListWith f = L.foldl' (\ m (k, v) -> insertWith f k v m) empty+#if __GLASGOW_HASKELL__ >= 700+{-# INLINE fromListWith #-}+#endif++------------------------------------------------------------------------+-- Array operations++-- | /O(n)/ Lookup the value associated with the given key in this+-- array. Returns 'Nothing' if the key wasn't found.+lookupInArray :: Eq k => k -> A.Array (Leaf k v) -> Maybe v+lookupInArray 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 v)+ | k == kx -> Just v+ | otherwise -> go k ary (i+1) n+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookupInArray #-}+#endif++-- | /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+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE indexOf #-}+#endif++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 -> A.update ary i (L k (f y))+ | otherwise -> go k ary (i+1) n+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE updateWith #-}+#endif++updateOrSnocWith :: Eq k => (v -> v -> v) -> k -> v -> A.Array (Leaf k v)+ -> A.Array (Leaf k v)+updateOrSnocWith 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+ | otherwise = case A.index ary i of+ (L kx y) | k == kx -> A.update ary i (L k (f v y))+ | otherwise -> go k v ary (i+1) n+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE updateOrSnocWith #-}+#endif++updateOrConcatWith :: Eq k => (v -> v -> v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -> A.Array (Leaf k v)+updateOrConcatWith f ary1 ary2 = A.run $ do+ -- 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.index_ ary1 i1+ L _ v2 <- A.index_ ary2 i2+ A.write mary i1 (L k (f v1 v2))+ go iEnd (i2+1)+ Nothing -> do -- key is only in ary2, append to end+ A.write mary iEnd =<< A.index_ ary2 i2+ go (iEnd+1) (i2+1)+ go n1 0+ return mary+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE updateOrConcatWith #-}+#endif++------------------------------------------------------------------------+-- 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 (update16' ary idx b)+{-# INLINE update16 #-}++-- | /O(n)/ Update the element at the given position in this array.+update16' :: A.Array e -> Int -> e -> ST s (A.Array e)+update16' ary idx b = do+ mary <- clone16 ary+ A.write mary idx b+ A.unsafeFreeze mary+{-# INLINE update16' #-}++-- | /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 = update16 ary idx $! f (A.index ary idx)+{-# 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 =+#if __GLASGOW_HASKELL__ >= 702+ A.thaw ary 0 16+#else+ do mary <- A.new_ 16+ A.index_ ary 0 >>= A.write mary 0+ A.index_ ary 1 >>= A.write mary 1+ A.index_ ary 2 >>= A.write mary 2+ A.index_ ary 3 >>= A.write mary 3+ A.index_ ary 4 >>= A.write mary 4+ A.index_ ary 5 >>= A.write mary 5+ A.index_ ary 6 >>= A.write mary 6+ A.index_ ary 7 >>= A.write mary 7+ A.index_ ary 8 >>= A.write mary 8+ A.index_ ary 9 >>= A.write mary 9+ A.index_ ary 10 >>= A.write mary 10+ A.index_ ary 11 >>= A.write mary 11+ A.index_ ary 12 >>= A.write mary 12+ A.index_ ary 13 >>= A.write mary 13+ A.index_ ary 14 >>= A.write mary 14+ A.index_ ary 15 >>= A.write mary 15+ return mary+#endif++------------------------------------------------------------------------+-- 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`+ fromIntegral (1 `unsafeShiftL` bitsPerSubkey))+{-# 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+#if defined(__GLASGOW_HASKELL__)+ptrEq x y = reallyUnsafePtrEquality# x y ==# 1#+#else+ptrEq _ _ = False+#endif+{-# INLINE ptrEq #-}
− Data/HashMap/Common.hs
@@ -1,338 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable #-}---- | Code shared between the lazy and strict versions.--module Data.HashMap.Common- (- -- * Types- HashMap(..)-- -- * Helpers- , join- , bin- , zero- , nomatch-- -- * Construction- , empty-- -- * Combine- , union-- -- * Transformations- , toList- , filterMapWithKey- , traverseWithKey-- -- * Folds- , foldrWithKey-- -- * Helpers- , shorter- , insertCollidingWith- ) where--#include "MachDeps.h"--import Control.Applicative (Applicative((<*>), pure), (<$>))-import Control.DeepSeq (NFData(rnf))-import Data.Bits (Bits(..), (.&.), xor)-import qualified Data.Foldable as Foldable-import Data.Monoid (Monoid(mempty, mappend))-import Data.Traversable (Traversable(..))-import Data.Typeable (Typeable)-import Data.Word (Word)-import Prelude hiding (foldr, map)--#if defined(__GLASGOW_HASKELL__)-import GHC.Exts (build)-#endif--import qualified Data.FullList.Lazy as FL----------------------------------------------------------------------------- * The 'HashMap' type---- | A map from keys to values. A map cannot contain duplicate keys;--- each key can map to at most one value.-data HashMap k v- = Bin {-# UNPACK #-} !SuffixMask- !(HashMap k v)- !(HashMap k v)- | Tip {-# UNPACK #-} !Hash- {-# UNPACK #-} !(FL.FullList k v)- | Nil- deriving (Typeable)--type Suffix = Int-type Hash = Int---- | A SuffixMask stores a path to a Bin node in the hash map. The--- uppermost set bit, the Mask, indicates the bit used to distinguish--- hashes in the left and right subtrees. The lower-order bits (below--- the highest set bit), the Suffix, are set the same way in all the--- hashes contained in this subtree of the map. Thus, hashes in the--- right subtree will match all the bits in the SuffixMask, but may--- have set bits above the Mask. Hashes in the left subtree will not--- match the Mask bit, but will match all the Suffix bits.-type SuffixMask = Int----------------------------------------------------------------------------- * Instances---- Since both the lazy and the strict API shares one data type we can--- only provide one set of instances. We provide the lazy ones.--instance (Eq k, Eq v) => Eq (HashMap k v) where- t1 == t2 = equal t1 t2- t1 /= t2 = nequal t1 t2---- | /O(n)/ Return a list of this map's elements. The list is--- produced lazily.-toList :: HashMap k v -> [(k, v)]-#if defined(__GLASGOW_HASKELL__)-toList t = build (\ c z -> foldrWithKey (curry c) z t)-#else-toList = foldrWithKey (\ k v xs -> (k, v) : xs) []-#endif-{-# INLINE toList #-}--equal :: (Eq k, Eq v) => HashMap k v -> HashMap k v -> Bool-equal (Bin sm1 l1 r1) (Bin sm2 l2 r2) =- (sm1 == sm2) && (equal l1 l2) && (equal r1 r2)-equal (Tip h1 l1) (Tip h2 l2) = (h1 == h2) && (l1 == l2)-equal Nil Nil = True-equal _ _ = False--nequal :: (Eq k, Eq v) => HashMap k v -> HashMap k v -> Bool-nequal (Bin sm1 l1 r1) (Bin sm2 l2 r2) =- (sm1 /= sm2) || (nequal l1 l2) || (nequal r1 r2)-nequal (Tip h1 l1) (Tip h2 l2) = (h1 /= h2) || (l1 /= l2)-nequal Nil Nil = False-nequal _ _ = True--instance (NFData k, NFData v) => NFData (HashMap k v) where- rnf Nil = ()- rnf (Tip _ xs) = rnf xs- rnf (Bin _ l r) = rnf l `seq` rnf r--instance Functor (HashMap k) where- fmap = map--instance (Show k, Show v) => Show (HashMap k v) where- showsPrec d m = showParen (d > 10) $- showString "fromList " . shows (toList m)---- | /O(n)/ Transform this map by applying a function to every value.-map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2-map f = go- where- go (Bin sm l r) = Bin sm (go l) (go r)- go (Tip h l) = Tip h (FL.map f' l)- go Nil = Nil- f' k v = (k, f v)-{-# INLINE map #-}--instance Foldable.Foldable (HashMap k) where- foldr f = foldrWithKey (const f)---- | /O(n)/ Reduce this map by applying a binary operator to all--- elements, using the given starting value (typically the--- right-identity of the operator).-foldrWithKey :: (k -> v -> a -> a) -> a -> HashMap k v -> a-foldrWithKey f = go- where- go z (Bin _ l r) = go (go z r) l- go z (Tip _ l) = FL.foldrWithKey f z l- go z Nil = z-{-# INLINE foldrWithKey #-}--instance Eq k => Monoid (HashMap k v) where- mempty = empty- {-# INLINE mempty #-}- mappend = union- {-# INLINE mappend #-}---- | /O(1)/ Construct an empty map.-empty :: HashMap k v-empty = Nil---- | /O(n+m)/ The union of two maps. If a key occurs in both maps,--- the mapping from the first will be the mapping in the result.-union :: Eq k => HashMap k v -> HashMap k v -> HashMap k v-union t1@(Bin sm1 l1 r1) t2@(Bin sm2 l2 r2)- | sm1 == sm2 = Bin sm1 (union l1 l2) (union r1 r2)- | shorter sm1 sm2 = union1- | shorter sm2 sm1 = union2- | otherwise = join sm1 t1 sm2 t2- where- union1 | nomatch sm2 sm1 = join sm1 t1 sm2 t2- | zero sm2 sm1 = Bin sm1 (union l1 t2) r1- | otherwise = Bin sm1 l1 (union r1 t2)-- union2 | nomatch sm1 sm2 = join sm1 t1 sm2 t2- | zero sm1 sm2 = Bin sm2 (union t1 l2) r2- | otherwise = Bin sm2 l2 (union t1 r2)-union (Tip h l) t = insertCollidingL h l t-union t (Tip h l) = insertCollidingR h l t -- right bias-union Nil t = t-union t Nil = t-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE union #-}-#endif---- | Insert a list of key-value pairs which keys all hash to the same--- hash value. Prefer key-value pairs in the list to key-value pairs--- already in the map.-insertCollidingL :: Eq k => Hash -> FL.FullList k v -> HashMap k v -> HashMap k v-insertCollidingL = insertCollidingWith FL.union-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertCollidingL #-}-#endif---- | Insert a list of key-value pairs which keys all hash to the same--- hash value. Prefer key-value pairs already in the map to key-value--- pairs in the list.-insertCollidingR :: Eq k => Hash -> FL.FullList k v -> HashMap k v -> HashMap k v-insertCollidingR = insertCollidingWith (flip FL.union)-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertCollidingR #-}-#endif---- | Insert a list of key-value pairs which keys all hash to the same--- hash value. Merge the list of key-value pairs to be inserted @xs@--- with any existing key-values pairs @ys@ by applying @f xs ys@.-insertCollidingWith :: Eq k- => (FL.FullList k v -> FL.FullList k v -> FL.FullList k v)- -> Hash -> FL.FullList k v- -> HashMap k v -> HashMap k v-insertCollidingWith f h0 l0 t0 = go h0 l0 t0- where- go !h !xs t@(Bin sm l r)- | nomatch h sm = join h (Tip h xs) sm t- | zero h sm = Bin sm (go h xs l) r- | otherwise = Bin sm l (go h xs r)- go h xs t@(Tip h' l)- | h == h' = Tip h $ f xs l- | otherwise = join h (Tip h xs) h' t- go h xs Nil = Tip h xs-{-# INLINE insertCollidingWith #-}--instance Traversable (HashMap k) where- traverse f = traverseWithKey (const f)---- | /O(n)/ Transform this map by applying a function to every value;--- when f k v returns Just x, keep an entry mapping k to x, otherwise--- do not include k in the result.-filterMapWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2-filterMapWithKey f = go- where- go (Bin sm l r) = bin sm (go l) (go r)- go (Tip h vs) =- case FL.foldrWithKey ff FL.Nil vs of- FL.Nil -> Nil- FL.Cons k v xs -> Tip h (FL.FL k v xs)- go Nil = Nil- ff k v xs =- case f k v of- Nothing -> xs- Just x -> FL.Cons k x xs-{-# INLINE filterMapWithKey #-}---- | /O(n)/ Transform this map by accumulating an Applicative result--- from every value.-traverseWithKey :: Applicative f => (k -> v1 -> f v2) -> HashMap k v1- -> f (HashMap k v2)-traverseWithKey f = go- where- go (Bin sm l r) = Bin sm <$> go l <*> go r- go (Tip h l) = Tip h <$> FL.traverseWithKey f l- go Nil = pure Nil-{-# INLINE traverseWithKey #-}----------------------------------------------------------------------------- Helpers--join :: Suffix -> HashMap k v -> Suffix -> HashMap k v -> HashMap k v-join s1 t1 s2 t2- | zero s1 sm = Bin sm t1 t2- | otherwise = Bin sm t2 t1- where- sm = branchSuffixMask s1 s2-{-# INLINE join #-}---- | @bin@ assures that we never have empty trees within a tree.-bin :: SuffixMask -> HashMap k v -> HashMap k v -> HashMap k v-bin _ l Nil = l-bin _ Nil r = r-bin sm l r = Bin sm l r-{-# INLINE bin #-}----------------------------------------------------------------------------- Endian independent bit twiddling---- Actually detects if every set bit of sm is set in i (and returns--- false if so). In most cases, the Suffix will already match, and--- this just tests the Mask. For lookup it can send us down the wrong--- path, but that's OK; we'll detect this when we reach a Tip and--- don't match. We could have checked (i .|. fromIntegral sm) /= i--- instead.-zero :: Hash -> SuffixMask -> Bool-zero i sm = (i .&. smi) /= smi- where smi = fromIntegral sm-{-# INLINE zero #-}---- We want to detect Suffix bits in the Hash that differ from--- SuffixMask. To do this, we find the first bit that differs between--- Hash and SuffixMask, then check if that bit is smaller than the--- Mask bit. We do this by observing that if we set this bit and all--- bits to its right, we'll obtain a number >= the suffixmask if all--- bits are the same (cb == 0, setting all bits) or if the first bit of--- difference is >= the Mask. Note: this comparison must be unsigned.-nomatch :: Hash -> SuffixMask -> Bool-nomatch i sm = (cb + cb - 1) < fromIntegral sm- where cb = differentBit i (fromIntegral sm)-{-# INLINE nomatch #-}----------------------------------------------------------------------------- Big endian operations---- | Compute the first (lowest-order) bit at which h1 and h2 differ.--- This is the mask that distinguishes them.-differentBit :: Hash -> Hash -> Word-differentBit h1 h2 =- fromIntegral (critBit (fromIntegral h1 `xor` fromIntegral h2))---- | Given mask bit m expressed as a word, compute the suffix bits of--- hash i, also expressed as a word.-suffixW :: Word -> Word -> Word-suffixW i m = i .&. (m-1)-{-# INLINE suffixW #-}---- | Given two hashes and/or SuffixMasks for which nomatch p1 p2 &&--- nomatch p2 p1, compute SuffixMask that differentiates them, by--- first computing the mask m and then using that to derive a suffix--- from one of them (it won't matter which, as those bits are the--- same).-branchSuffixMask :: Suffix -> Suffix -> SuffixMask-branchSuffixMask p1 p2 =- fromIntegral (m + suffixW w1 m)- where m = differentBit p1 p2- w1 = fromIntegral p1-{-# INLINE branchSuffixMask #-}---- | Is the mask of sm1 closer to the root of the tree (lower order)--- than the mask of sm2? This is actually approximate, and returns--- junk when both sm1 and sm2 are at the same tree level. This must--- be disambiguated by first checking sm1==sm2, and subsequently by--- checking nomatch in the appropriate direction (which will need to--- happen anyway to determine if insertion or branching is--- appropriate).-shorter :: SuffixMask -> SuffixMask -> Bool-shorter sm1 sm2 = (fromIntegral sm1 :: Word) < (fromIntegral sm2 :: Word)-{-# INLINE shorter #-}---- | Return a 'Word' whose single set bit corresponds to the lowest set bit of w.-critBit :: Word -> Word-critBit w = w .&. (negate w)-{-# INLINE critBit #-}
Data/HashMap/Lazy.hs view
@@ -1,9 +1,13 @@-{-# LANGUAGE BangPatterns, CPP #-}+{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+ ------------------------------------------------------------------------ -- | -- Module : Data.HashMap.Lazy--- Copyright : 2010-2011 Johan Tibell+-- Copyright : 2010-2012 Johan Tibell -- License : BSD-style -- Maintainer : johan.tibell@gmail.com -- Stability : provisional@@ -17,16 +21,14 @@ -- evaluated to /weak head normal form/ before they are added to the -- map. ----- The implementation is based on /big-endian patricia trees/, keyed--- by a hash of the original key. A 'HashMap' is often faster than--- other tree-based maps, especially when key comparison is expensive,--- as in the case of strings.+-- The implementation is based on /hash array mapped tries/. A+-- 'HashMap' is often faster than other tree-based set types,+-- especially when key comparison is expensive, as in the case of+-- strings. ----- Many operations have a worst-case complexity of /O(min(n,W))/.--- This means that the operation can become linear in the number of--- elements with a maximum of /W/ -- the number of bits in an 'Int'--- (32 or 64).-+-- Many operations have a average-case complexity of /O(log n)/. The+-- implementation uses a large base (i.e. 16) so in practice these+-- operations are constant time. module Data.HashMap.Lazy ( HashMap@@ -36,13 +38,13 @@ , singleton -- * Basic interface- , null+ , HM.null , size- , lookup+ , HM.lookup , lookupDefault , insert- , delete , insertWith+ , delete , adjust -- * Combine@@ -51,7 +53,7 @@ , unionWith -- * Transformations- , map+ , HM.map , traverseWithKey -- * Difference and intersection@@ -61,16 +63,16 @@ -- * Folds , foldl' , foldlWithKey'- , foldr+ , HM.foldr , foldrWithKey -- * Filter- , filter+ , HM.filter , filterWithKey -- * Conversions- , elems , keys+ , elems -- ** Lists , toList@@ -78,283 +80,4 @@ , fromListWith ) where -import qualified Data.FullList.Lazy as FL-import Data.Hashable (Hashable(hash))-import qualified Data.List as List-import Prelude hiding (filter, foldr, lookup, map, null, pred)--import Data.HashMap.Common----------------------------------------------------------------------------- * Basic interface---- | /O(1)/ Return 'True' if this map is empty, 'False' otherwise.-null :: HashMap k v -> Bool-null Nil = True-null _ = False---- | /O(n)/ Return the number of key-value mappings in this map.-size :: HashMap k v -> Int-size t = go t 0- where- go (Bin _ l r) !sz = go r (go l sz)- go (Tip _ l) !sz = sz + FL.size l- go Nil !sz = sz---- | /O(min(n,W))/ Return the value to which the specified key is--- mapped, or 'Nothing' if this map contains no mapping for the key.-lookup :: (Eq k, Hashable k) => k -> HashMap k v -> Maybe v-lookup k0 t = go h0 k0 t- where- h0 = hash k0- go !h !k (Bin sm l r)- | zero h sm = go h k l- | otherwise = go h k r- go h k (Tip h' l)- | h == h' = FL.lookup k l- | otherwise = Nothing- go _ _ Nil = Nothing-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE lookup #-}-#endif---- | /O(min(n,W))/ Return the value to which the specified key is--- mapped, or the default value if this map contains no mapping for--- the key.-lookupDefault :: (Eq k, Hashable k)- => v -- ^ Default value to return.- -> k -> HashMap k v -> v-lookupDefault def k t = case lookup k t of- Just v -> v- _ -> def-{-# INLINABLE lookupDefault #-}---- | /O(1)/ Construct a map with a single element.-singleton :: Hashable k => k -> v -> HashMap k v-singleton k v = Tip h $ FL.singleton k v- where h = hash k-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE singleton #-}-#endif---- | /O(min(n,W))/ Associate the specified value with the specified--- key in this map. If this map previously contained a mapping for--- the key, the old value is replaced.-insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v-insert k0 v0 t0 = go h0 k0 v0 t0- where- h0 = hash k0- go !h !k v t@(Bin sm l r)- | nomatch h sm = join h (Tip h $ FL.singleton k v) sm t- | zero h sm = Bin sm (go h k v l) r- | otherwise = Bin sm l (go h k v r)- go h k v t@(Tip h' l)- | h == h' = Tip h $ FL.insert k v l- | otherwise = join h (Tip h $ FL.singleton k v) h' t- go h k v Nil = Tip h $ FL.singleton k v-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insert #-}-#endif---- | /O(min(n,W))/ Remove the mapping for the specified key from this--- map if present.-delete :: (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v-delete k0 = go h0 k0- where- h0 = hash k0- go !h !k t@(Bin sm l r)- | nomatch h sm = t- | zero h sm = bin sm (go h k l) r- | otherwise = bin sm l (go h k r)- go h k t@(Tip h' l)- | h == h' = case FL.delete k l of- Nothing -> Nil- Just l' -> Tip h' l'- | otherwise = t- go _ _ Nil = Nil-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE delete #-}-#endif---- | /O(min(n,W))/ Associate the value with the key in this map. If--- this map previously contained a mapping for the key, the old value--- is replaced by the result of applying the given function to the new--- and old value. Example:------ > insertWith f k v map--- > where f new old = new + old-insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v- -> HashMap k v-insertWith f k0 v0 t0 = go h0 k0 v0 t0- where- h0 = hash k0- go !h !k v t@(Bin sm l r)- | nomatch h sm = join h (Tip h $ FL.singleton k v) sm t- | zero h sm = Bin sm (go h k v l) r- | otherwise = Bin sm l (go h k v r)- go h k v t@(Tip h' l)- | h == h' = Tip h $ FL.insertWith f k v l- | otherwise = join h (Tip h $ FL.singleton k v) h' t- go h k v Nil = Tip h $ FL.singleton k v-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE insertWith #-}-#endif---- | /O(min(n,W)/ Adjust the value tied to a given key in this map--- only if it is present. Otherwise, leave the map alone.-adjust :: (Eq k, Hashable k) => (v -> v) -> k -> HashMap k v -> HashMap k v-adjust f k0 t0 = go h0 k0 t0- where- h0 = hash k0- go !h !k t@(Bin sm l r)- | nomatch h sm = t- | zero h sm = Bin sm (go h k l) r- | otherwise = Bin sm l (go h k r)- go h k t@(Tip h' l)- | h == h' = Tip h $ FL.adjust f k l- | otherwise = t- go _ _ Nil = Nil-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE adjust #-}-#endif----------------------------------------------------------------------------- * Transformations---- | /O(n)/ Transform this map by applying a function to every value.-map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2-map f = go- where- go (Bin sm l r) = Bin sm (go l) (go r)- go (Tip h l) = Tip h (FL.map f' l)- go Nil = Nil- f' k v = (k, f v)-{-# INLINE map #-}---- | /O(n+m)/ The union of two maps. If a key occurs in both maps,--- the provided function (first argument) will be used to compute the result.-unionWith :: Eq k => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v-unionWith f t1@(Bin sm1 l1 r1) t2@(Bin sm2 l2 r2)- | sm1 == sm2 = Bin sm1 (unionWith f l1 l2) (unionWith f r1 r2)- | shorter sm1 sm2 = union1- | shorter sm2 sm1 = union2- | otherwise = join sm1 t1 sm2 t2- where- union1 | nomatch sm2 sm1 = join sm1 t1 sm2 t2- | zero sm2 sm1 = Bin sm1 (unionWith f l1 t2) r1- | otherwise = Bin sm1 l1 (unionWith f r1 t2)-- union2 | nomatch sm1 sm2 = join sm1 t1 sm2 t2- | zero sm1 sm2 = Bin sm2 (unionWith f t1 l2) r2- | otherwise = Bin sm2 l2 (unionWith f t1 r2)-unionWith f (Tip h l) t = insertCollidingWith (FL.unionWith f) h l t-unionWith f t (Tip h l) = insertCollidingWith (flip (FL.unionWith f)) h l t -- right bias-unionWith _ Nil t = t-unionWith _ t Nil = t-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE unionWith #-}-#endif---- | /O(n)/ Difference of two maps. Return elements of the first map--- not existing in the second.-difference :: (Eq k, Hashable k) => HashMap k v -> HashMap k w -> HashMap k v-difference a b = foldlWithKey' go empty a- where- go m k v = case lookup k b of- Nothing -> insert k v m- _ -> m-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE difference #-}-#endif---- | /O(n)/ Intersection of two maps. Return elements of the first map--- for keys existing in the second.-intersection :: (Eq k, Hashable k) => HashMap k v -> HashMap k w -> HashMap k v-intersection a b = foldlWithKey' go empty a- where- go m k v = case lookup k b of- Just _ -> insert k v m- _ -> m-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE intersection #-}-#endif----------------------------------------------------------------------------- * Folds---- | /O(n)/ Reduce this map by applying a binary operator to all--- elements, using the given starting value (typically the--- right-identity of the operator).-foldr :: (v -> a -> a) -> a -> HashMap k v -> a-foldr f = foldrWithKey (const f)-{-# INLINE foldr #-}---- | /O(n)/ Reduce this map by applying a binary operator to all--- elements, using the given starting value (typically the--- left-identity of the operator). Each application of the operator--- is evaluated before before using the result in the next--- application. This function is strict in the starting value.-foldl' :: (a -> v -> a) -> a -> HashMap k v -> a-foldl' f = foldlWithKey' (\ z _ v -> f z v)-{-# INLINE foldl' #-}---- | /O(n)/ Reduce this map by applying a binary operator to all--- elements, using the given starting value (typically the--- left-identity of the operator). Each application of the operator--- is evaluated before before using the result in the next--- application. This function is strict in the starting value.-foldlWithKey' :: (a -> k -> v -> a) -> a -> HashMap k v -> a-foldlWithKey' f = go- where- go !z (Bin _ l r) = let z' = go z l- in z' `seq` go z' r- go z (Tip _ l) = FL.foldlWithKey' f z l- go z Nil = z-{-# INLINE foldlWithKey' #-}----------------------------------------------------------------------------- * Filter---- | /O(n)/ Filter this map by retaining only elements satisfying a--- predicate.-filterWithKey :: (k -> v -> Bool) -> HashMap k v -> HashMap k v-filterWithKey pred = go- where- go (Bin sm l r) = bin sm (go l) (go r)- go (Tip h l) = case FL.filterWithKey pred l of- Just l' -> Tip h l'- Nothing -> Nil- go Nil = Nil-{-# INLINE filterWithKey #-}---- | /O(n)/ Filter this map by retaining only elements which values--- satisfy a predicate.-filter :: (v -> Bool) -> HashMap k v -> HashMap k v-filter p = filterWithKey (\_ v -> p v)-{-# INLINE filter #-}----------------------------------------------------------------------------- Conversions---- | /O(n*min(W, n))/ Construct a map from a list of elements.-fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v-fromList = List.foldl' (\ m (k, v) -> insert k v m) empty-{-# INLINE fromList #-}---- | /O(n*min(W, n))/ Construct a map from a list of elements. Uses--- the provided function to merge duplicate entries.-fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v-fromListWith f = List.foldl' (\ m (k, v) -> insertWith f k v m) empty-{-# INLINE fromListWith #-}---- | /O(n)/ Return a list of this map's keys. The list is produced--- lazily.-keys :: HashMap k v -> [k]-keys = List.map fst . toList-{-# INLINE keys #-}---- | /O(n)/ Return a list of this map's values. The list is produced--- lazily.-elems :: HashMap k v -> [v]-elems = List.map snd . toList-{-# INLINE elems #-}+import Data.HashMap.Base as HM
− Data/HashMap/Lazy/Internal.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE BangPatterns #-}----------------------------------------------------------------------------- |--- Module : Data.HashMap.Lazy.Internal--- Copyright : 2010-2011 Johan Tibell--- License : BSD-style--- Maintainer : johan.tibell@gmail.com--- Stability : provisional--- Portability : portable------ Semi-public internals.--module Data.HashMap.Lazy.Internal- ( collisions- , collisionHistogram- ) where--import Prelude hiding (lookup)--import qualified Data.FullList.Lazy as FL-import Data.HashMap.Common (HashMap(..))-import Data.HashMap.Lazy (insert, lookup)------------------------------------------------------------------------ Metadata about map behavior---- | /O(n)/ Return the number of hash collisions in this map.-collisions :: HashMap k v -> Int-collisions t = go t 0- where- go (Bin _ l r) !sz = go r (go l sz)- go (Tip _ l) !sz- | fl_sz <= 1 = sz- | otherwise = sz + fl_sz- where fl_sz = FL.size l- go Nil !sz = sz---- | /O(n)/ Return histogram of hash collisions in this map.--- Keys are number of entries in bucket, values are number of buckets--- of that size.-collisionHistogram :: HashMap k v -> HashMap Int Int-collisionHistogram t = go t Nil- where- go (Bin _ l r) h = go r (go l h)- go (Tip _ l) h = (insert sz $! maybe 1 (1+) (lookup sz h)) h- where sz = FL.size l- go Nil h = h
+ Data/HashMap/PopCount.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module Data.HashMap.PopCount+ ( popCount+ ) where++#if __GLASGOW_HASKELL__ >= 704+import Data.Bits (popCount)+#else+import Data.Word (Word)+import Foreign.C (CUInt)+#endif++#if __GLASGOW_HASKELL__ < 704+foreign import ccall unsafe "popc.h popcount" c_popcount :: CUInt -> CUInt++popCount :: Word -> Int+popCount w = fromIntegral (c_popcount (fromIntegral w))+#endif
Data/HashMap/Strict.hs view
@@ -1,9 +1,13 @@ {-# LANGUAGE BangPatterns, CPP #-} +#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+ ------------------------------------------------------------------------ -- | -- Module : Data.HashMap.Strict--- Copyright : 2010-2011 Johan Tibell+-- Copyright : 2010-2012 Johan Tibell -- License : BSD-style -- Maintainer : johan.tibell@gmail.com -- Stability : provisional@@ -18,16 +22,14 @@ -- the map. Exception: the provided instances are the same as for the -- lazy version of this module. ----- The implementation is based on /big-endian patricia trees/, keyed--- by a hash of the original key. A 'HashMap' is often faster than--- other tree-based maps, especially when key comparison is expensive,--- as in the case of strings.+-- The implementation is based on /hash array mapped tries/. A+-- 'HashMap' is often faster than other tree-based set types,+-- especially when key comparison is expensive, as in the case of+-- strings. ----- Many operations have a worst-case complexity of /O(min(n,W))/.--- This means that the operation can become linear in the number of--- elements with a maximum of /W/ -- the number of bits in an 'Int'--- (32 or 64).-+-- Many operations have a average-case complexity of /O(log n)/. The+-- implementation uses a large base (i.e. 16) so in practice these+-- operations are constant time. module Data.HashMap.Strict ( HashMap@@ -37,13 +39,13 @@ , singleton -- * Basic interface- , null+ , HM.null , size- , lookup+ , HM.lookup , lookupDefault , insert- , delete , insertWith+ , delete , adjust -- * Combine@@ -62,16 +64,16 @@ -- * Folds , foldl' , foldlWithKey'- , foldr+ , HM.foldr , foldrWithKey -- * Filter- , filter+ , HM.filter , filterWithKey -- * Conversions- , elems , keys+ , elems -- ** Lists , toList@@ -79,44 +81,38 @@ , fromListWith ) where -import Data.Hashable (Hashable(hash))-import Prelude hiding (filter, foldr, lookup, map, null)+import Control.Monad.ST (runST)+import Data.Bits ((.&.), (.|.))+import qualified Data.List as L+import Data.Hashable (Hashable)+import Prelude hiding (map) -import qualified Data.FullList.Strict as FL-import Data.HashMap.Common-import Data.HashMap.Lazy hiding (fromList, fromListWith, insert, insertWith,- adjust, map, singleton, unionWith)-import qualified Data.HashMap.Lazy as L-import qualified Data.List as List+import qualified Data.HashMap.Array as A+import qualified Data.HashMap.Base as HM+import Data.HashMap.Base hiding (+ adjust, fromList, fromListWith, insert, insertWith, map, singleton,+ unionWith) --------------------------------------------------------------------------- * Basic interface+-- * Construction -- | /O(1)/ Construct a map with a single element.-singleton :: Hashable k => k -> v -> HashMap k v-singleton k !v = L.singleton k v-{-# INLINE singleton #-}+singleton :: (Hashable k) => k -> v -> HashMap k v+singleton k !v = HM.singleton k v --- | /O(min(n,W))/ Associate the specified value with the specified+------------------------------------------------------------------------+-- * 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 k0 !v0 t0 = go h0 k0 v0 t0- where- h0 = hash k0- go !h !k v t@(Bin sm l r)- | nomatch h sm = join h (Tip h $ FL.singleton k v) sm t- | zero h sm = Bin sm (go h k v l) r- | otherwise = Bin sm l (go h k v r)- go h k v t@(Tip h' l)- | h == h' = Tip h $ FL.insert k v l- | otherwise = join h (Tip h $ FL.singleton k v) h' t- go h k v Nil = Tip h $ FL.singleton k v+insert k !v = HM.insert k v #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insert #-} #endif --- | /O(min(n,W))/ Associate the value with the key in this map. If+-- | /O(log n)/ Associate the value with the key in this map. If -- this map previously contained a mapping for the key, the old value -- is replaced by the result of applying the given function to the new -- and old value. Example:@@ -125,40 +121,159 @@ -- > where f new old = new + old insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v-insertWith f k0 !v0 t0 = go h0 k0 v0 t0+insertWith f k0 !v0 m0 = runST (go h0 k0 v0 0 m0) where h0 = hash k0- go !h !k v t@(Bin sm l r)- | nomatch h sm = join h (Tip h $ FL.singleton k v) sm t- | zero h sm = Bin sm (go h k v l) r- | otherwise = Bin sm l (go h k v r)- go h k v t@(Tip h' l)- | h == h' = Tip h $ FL.insertWith f k v l- | otherwise = join h (Tip h $ FL.singleton k v) h' t- go h k v Nil = Tip h $ FL.singleton k v+ go !h !k x !_ Empty = return $ Leaf h (L k x)+ go h k x s (Leaf hy l@(L ky y))+ | hy == h = if ky == k+ then let !v' = f x y in return $! Leaf h (L k v')+ else return $! collision h l (L k x)+ | otherwise = two s h k x hy ky y+ go h k x s (BitmapIndexed b ary)+ | b .&. m == 0 = do+ ary' <- A.insert' ary i $! Leaf h (L k x)+ return $! bitmapIndexedOrFull (b .|. m) ary'+ | otherwise = do+ st <- A.index_ ary i+ st' <- go h k x (s+bitsPerSubkey) st+ ary' <- A.update' ary i st'+ return $! BitmapIndexed b ary'+ where m = mask h s+ i = sparseIndex b m+ go h k x s (Full ary) = do+ st <- A.index_ ary i+ st' <- go h k x (s+bitsPerSubkey) st+ ary' <- update16' ary i st'+ return $! Full ary'+ where i = index h s+ go h k x s t@(Collision hy v)+ | h == hy = return $! Collision h (updateOrSnocWith f k x v)+ | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insertWith #-} #endif --- | /O(min(n,W)/ Adjust the value tied to a given key in this map--- only if it is present. Otherwise, leave the map alone.+-- | /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 t0 = go h0 k0 t0+adjust f k0 = go h0 k0 0 where h0 = hash k0- go !h !k t@(Bin sm l r)- | nomatch h sm = t- | zero h sm = Bin sm (go h k l) r- | otherwise = Bin sm l (go h k r)- go h k t@(Tip h' l)- | h == h' = Tip h $ FL.adjust f k l- | otherwise = t- go _ _ Nil = Nil+ go !_ !_ !_ Empty = Empty+ go h k _ t@(Leaf hy (L ky y))+ | hy == h && ky == k = let !v' = f y in Leaf h (L k v')+ | 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 #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE adjust #-} #endif +------------------------------------------------------------------------+-- * Combine +-- | /O(n*log 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 = 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 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 (updateOrSnocWith 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 (updateOrSnocWith (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 (updateOrConcatWith 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 unionWith #-}+ ------------------------------------------------------------------------ -- * Transformations @@ -166,46 +281,63 @@ map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2 map f = go where- go (Bin sm l r) = Bin sm (go l) (go r)- go (Tip h l) = Tip h (FL.map f' l)- go Nil = Nil- f' k v = (k, f v)+ go Empty = Empty+ go (Leaf h (L k v)) = let !v' = f v in Leaf h $ L 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 v in L k v') ary {-# INLINE map #-} --- | /O(n+m)/ The union of two maps. If a key occurs in both maps,--- the provided function (first argument) will be used to compute the result.-unionWith :: Eq k => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v-unionWith f t1@(Bin sm1 l1 r1) t2@(Bin sm2 l2 r2)- | sm1 == sm2 = Bin sm1 (unionWith f l1 l2) (unionWith f r1 r2)- | shorter sm1 sm2 = union1- | shorter sm2 sm1 = union2- | otherwise = join sm1 t1 sm2 t2- where- union1 | nomatch sm2 sm1 = join sm1 t1 sm2 t2- | zero sm2 sm1 = Bin sm1 (unionWith f l1 t2) r1- | otherwise = Bin sm1 l1 (unionWith f r1 t2)-- union2 | nomatch sm1 sm2 = join sm1 t1 sm2 t2- | zero sm1 sm2 = Bin sm2 (unionWith f t1 l2) r2- | otherwise = Bin sm2 l2 (unionWith f t1 r2)-unionWith f (Tip h l) t = insertCollidingWith (FL.unionWith f) h l t-unionWith f t (Tip h l) = insertCollidingWith (flip (FL.unionWith f)) h l t -- right bias-unionWith _ Nil t = t-unionWith _ t Nil = t-#if __GLASGOW_HASKELL__ >= 700-{-# INLINABLE unionWith #-}-#endif+-- TODO: Should we add a strict traverseWithKey? --------------------------------------------------------------------------- Conversions+-- ** Lists --- | /O(n*min(W, n))/ Construct a map from a list of elements.+-- | /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 = List.foldl' (\ m (k, v) -> insert k v m) empty-{-# INLINE fromList #-}+fromList = L.foldl' (\ m (k, v) -> insert k v m) empty+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromList #-}+#endif --- | /O(n*min(W, n))/ Construct a map from a list of elements. Uses+-- | /O(n*log n)/ Construct a map from a list of elements. Uses -- the provided function to merge duplicate entries. fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v-fromListWith f = List.foldl' (\ m (k, v) -> insertWith f k v m) empty+fromListWith f = L.foldl' (\ m (k, v) -> insertWith f k v m) empty {-# INLINE fromListWith #-}++------------------------------------------------------------------------+-- 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+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE updateWith #-}+#endif++updateOrSnocWith :: Eq k => (v -> v -> v) -> k -> v -> A.Array (Leaf k v)+ -> A.Array (Leaf k v)+updateOrSnocWith 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+ | otherwise = case A.index ary i of+ (L kx y) | k == kx -> let !v' = f v y in A.update ary i (L k v')+ | otherwise -> go k v ary (i+1) n+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE updateOrSnocWith #-}+#endif
− Data/HashMap/Strict/Internal.hs
@@ -1,19 +0,0 @@-{-# LANGUAGE BangPatterns #-}----------------------------------------------------------------------------- |--- Module : Data.HashMap.Strict.Internal--- Copyright : 2010-2011 Johan Tibell--- License : BSD-style--- Maintainer : johan.tibell@gmail.com--- Stability : provisional--- Portability : portable------ Semi-public internals.--module Data.HashMap.Strict.Internal- ( collisions- , collisionHistogram- ) where--import Data.HashMap.Lazy.Internal
+ Data/HashMap/UnsafeShift.hs view
@@ -0,0 +1,16 @@+{-# 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 #-}
Data/HashSet.hs view
@@ -12,15 +12,14 @@ -- A set of /hashable/ values. A set cannot contain duplicate items. -- A 'HashSet' makes no guarantees as to the order of its elements. ----- The implementation is based on /big-endian patricia trees/, indexed--- by a hash of the original value. A 'HashSet' is often faster than--- other tree-based set types, especially when value comparison is--- expensive, as in the case of strings.+-- 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 worst-case complexity of /O(min(n,W))/.--- This means that the operation can become linear in the number of--- elements with a maximum of /W/ -- the number of bits in an 'Int'--- (32 or 64).+-- Many operations have a average-case complexity of /O(log n)/. The+-- implementation uses a large base (i.e. 16) so in practice these+-- operations are constant time. module Data.HashSet (@@ -60,7 +59,7 @@ ) where import Control.DeepSeq (NFData(..))-import Data.HashMap.Common (HashMap, foldrWithKey)+import Data.HashMap.Base (HashMap, foldrWithKey) import Data.Hashable (Hashable) import Data.Monoid (Monoid(..)) import Prelude hiding (filter, foldr, map, null)
− benchmarks/Benchmarks.hs
@@ -1,232 +0,0 @@-{-# LANGUAGE GADTs #-}--module Main where--import Control.DeepSeq-import Control.Exception (evaluate)-import Control.Monad.Trans (liftIO)-import Criterion.Config-import Criterion.Main-import Data.Bits ((.&.))-import Data.Hashable (Hashable)-import qualified Data.ByteString as BS-import qualified Data.HashMap.Strict as HM-import qualified Data.IntMap as IM-import qualified Data.Map as M-import Data.List (foldl')-import Data.Maybe (fromMaybe)-import Prelude hiding (lookup)--import qualified Util.ByteString as UBS-import qualified Util.Int as UI-import qualified Util.String as US--instance NFData BS.ByteString--data B where- B :: NFData a => a -> B--instance NFData B where- rnf (B b) = rnf b--main :: IO ()-main = do- let hm = HM.fromList elems :: HM.HashMap String Int- hmbs = HM.fromList elemsBS :: HM.HashMap BS.ByteString Int- hmi = HM.fromList elemsI :: HM.HashMap Int Int- hmi2 = HM.fromList elemsI2 :: HM.HashMap Int Int- m = M.fromList elems :: M.Map String Int- mbs = M.fromList elemsBS :: M.Map BS.ByteString Int- im = IM.fromList elemsI :: IM.IntMap Int- defaultMainWith defaultConfig- (liftIO . evaluate $ rnf [B m, B mbs, B hm, B hmbs, B hmi, B im])- [- -- * Comparison to other data structures- -- ** Map- bgroup "Map"- [ bgroup "lookup"- [ bench "String" $ whnf (lookupM keys) m- , bench "ByteString" $ whnf (lookupM keysBS) mbs- ]- , bgroup "lookup-miss"- [ bench "String" $ whnf (lookupM keys') m- , bench "ByteString" $ whnf (lookupM keysBS') mbs- ]- , bgroup "insert"- [ bench "String" $ whnf (insertM elems) M.empty- , bench "ByteStringString" $ whnf (insertM elemsBS) M.empty- ]- , bgroup "insert-dup"- [ bench "String" $ whnf (insertM elems) m- , bench "ByteStringString" $ whnf (insertM elemsBS) mbs- ]- , bgroup "delete"- [ bench "String" $ whnf (deleteM keys) m- , bench "ByteString" $ whnf (deleteM keysBS) mbs- ]- , bgroup "delete-miss"- [ bench "String" $ whnf (deleteM keys') m- , bench "ByteString" $ whnf (deleteM keysBS') mbs- ]- , bgroup "size"- [ bench "String" $ whnf M.size m- , bench "ByteString" $ whnf M.size mbs- ]- , bgroup "fromList"- [ bench "String" $ whnf M.fromList elems- , bench "ByteString" $ whnf M.fromList elemsBS- ]- ]-- -- ** IntMap- , bgroup "IntMap"- [ bench "lookup" $ whnf (lookupIM keysI) im- , bench "lookup-miss" $ whnf (lookupIM keysI') im- , bench "insert" $ whnf (insertIM elemsI) IM.empty- , bench "insert-dup" $ whnf (insertIM elemsI) im- , bench "delete" $ whnf (deleteIM keysI) im- , bench "delete-miss" $ whnf (deleteIM keysI') im- , bench "size" $ whnf IM.size im- , bench "fromList" $ whnf IM.fromList elemsI- ]-- -- * Basic interface- , bgroup "lookup"- [ bench "String" $ whnf (lookup keys) hm- , bench "ByteString" $ whnf (lookup keysBS) hmbs- , bench "Int" $ whnf (lookup keysI) hmi- ]- , bgroup "lookup-miss"- [ bench "String" $ whnf (lookup keys') hm- , bench "ByteString" $ whnf (lookup keysBS') hmbs- , bench "Int" $ whnf (lookup keysI') hmi- ]- , bgroup "insert"- [ bench "String" $ whnf (insert elems) HM.empty- , bench "ByteString" $ whnf (insert elemsBS) HM.empty- , bench "Int" $ whnf (insert elemsI) HM.empty- ]- , bgroup "insert-dup"- [ bench "String" $ whnf (insert elems) hm- , bench "ByteString" $ whnf (insert elemsBS) hmbs- , bench "Int" $ whnf (insert elemsI) hmi- ]- , bgroup "delete"- [ bench "String" $ whnf (delete keys) hm- , bench "ByteString" $ whnf (delete keysBS) hmbs- , bench "Int" $ whnf (delete keysI) hmi- ]- , bgroup "delete-miss"- [ bench "String" $ whnf (delete keys') hm- , bench "ByteString" $ whnf (delete keysBS') hmbs- , bench "Int" $ whnf (delete keysI') hmi- ]-- -- Combine- , bench "union" $ whnf (HM.union hmi) hmi2-- -- Transformations- , bench "map" $ whnf (HM.map (\ v -> v + 1)) hmi-- -- * Difference and intersection- , bench "difference" $ whnf (HM.difference hmi) hmi2- , bench "intersection" $ whnf (HM.intersection hmi) hmi2-- -- Folds- , bench "foldl'" $ whnf (HM.foldl' (+) 0) hmi- , bench "foldr" $ whnf (HM.foldr (:) []) hmi-- -- Filter- , bench "filter" $ whnf (HM.filter (\ v -> v .&. 1 == 0)) hmi- , bench "filterWithKey" $ whnf (HM.filterWithKey (\ k _ -> k .&. 1 == 0)) hmi-- -- Size- , bgroup "size"- [ bench "String" $ whnf HM.size hm- , bench "ByteString" $ whnf HM.size hmbs- , bench "Int" $ whnf HM.size hmi- ]-- -- fromList- , bgroup "fromList"- [ bench "String" $ whnf HM.fromList elems- , bench "ByteString" $ whnf HM.fromList elemsBS- , bench "Int" $ whnf HM.fromList elemsI- ]- ]- where- n :: Int- n = 2^(12 :: Int)-- elems = zip keys [1..n]- keys = US.rnd 8 n- elemsBS = zip keysBS [1..n]- keysBS = UBS.rnd 8 n- elemsI = zip keysI [1..n]- keysI = UI.rnd (n+n) n- elemsI2 = zip [n `div` 2..n + (n `div` 2)] [1..n] -- for union-- keys' = US.rnd' 8 n- keysBS' = UBS.rnd' 8 n- keysI' = UI.rnd' (n+n) n----------------------------------------------------------------------------- * HashMap--lookup :: (Eq k, Hashable k) => [k] -> HM.HashMap k Int -> Int-lookup xs m = foldl' (\z k -> fromMaybe z (HM.lookup k m)) 0 xs-{-# SPECIALIZE lookup :: [Int] -> HM.HashMap Int Int -> Int #-}-{-# SPECIALIZE lookup :: [String] -> HM.HashMap String Int -> Int #-}-{-# SPECIALIZE lookup :: [BS.ByteString] -> HM.HashMap BS.ByteString Int- -> Int #-}--insert :: (Eq k, Hashable k) => [(k, Int)] -> HM.HashMap k Int- -> HM.HashMap k Int-insert xs m0 = foldl' (\m (k, v) -> HM.insert k v m) m0 xs-{-# SPECIALIZE insert :: [(Int, Int)] -> HM.HashMap Int Int- -> HM.HashMap Int Int #-}-{-# SPECIALIZE insert :: [(String, Int)] -> HM.HashMap String Int- -> HM.HashMap String Int #-}-{-# SPECIALIZE insert :: [(BS.ByteString, Int)] -> HM.HashMap BS.ByteString Int- -> HM.HashMap BS.ByteString Int #-}--delete :: (Eq k, Hashable k) => [k] -> HM.HashMap k Int -> HM.HashMap k Int-delete xs m0 = foldl' (\m k -> HM.delete k m) m0 xs-{-# SPECIALIZE delete :: [Int] -> HM.HashMap Int Int -> HM.HashMap Int Int #-}-{-# SPECIALIZE delete :: [String] -> HM.HashMap String Int- -> HM.HashMap String Int #-}-{-# SPECIALIZE delete :: [BS.ByteString] -> HM.HashMap BS.ByteString Int- -> HM.HashMap BS.ByteString Int #-}----------------------------------------------------------------------------- * Map--lookupM :: Ord k => [k] -> M.Map k Int -> Int-lookupM xs m = foldl' (\z k -> fromMaybe z (M.lookup k m)) 0 xs-{-# SPECIALIZE lookupM :: [String] -> M.Map String Int -> Int #-}-{-# SPECIALIZE lookupM :: [BS.ByteString] -> M.Map BS.ByteString Int -> Int #-}--insertM :: Ord k => [(k, Int)] -> M.Map k Int -> M.Map k Int-insertM xs m0 = foldl' (\m (k, v) -> M.insert k v m) m0 xs-{-# SPECIALIZE insertM :: [(String, Int)] -> M.Map String Int- -> M.Map String Int #-}-{-# SPECIALIZE insertM :: [(BS.ByteString, Int)] -> M.Map BS.ByteString Int- -> M.Map BS.ByteString Int #-}--deleteM :: Ord k => [k] -> M.Map k Int -> M.Map k Int-deleteM xs m0 = foldl' (\m k -> M.delete k m) m0 xs-{-# SPECIALIZE deleteM :: [String] -> M.Map String Int -> M.Map String Int #-}-{-# SPECIALIZE deleteM :: [BS.ByteString] -> M.Map BS.ByteString Int- -> M.Map BS.ByteString Int #-}----------------------------------------------------------------------------- * IntMap--lookupIM :: [Int] -> IM.IntMap Int -> Int-lookupIM xs m = foldl' (\z k -> fromMaybe z (IM.lookup k m)) 0 xs--insertIM :: [(Int, Int)] -> IM.IntMap Int -> IM.IntMap Int-insertIM xs m0 = foldl' (\m (k, v) -> IM.insert k v m) m0 xs--deleteIM :: [Int] -> IM.IntMap Int -> IM.IntMap Int-deleteIM xs m0 = foldl' (\m k -> IM.delete k m) m0 xs
− benchmarks/Makefile
@@ -1,45 +0,0 @@-ghc-prof-flags :=-ifdef ENABLE_PROFILING- ghc-prof-flags += -prof -hisuf p_hi -osuf p_o- lib-suffix := _p-else- lib-suffix :=-endif--ghc := ghc-extra-ghc-flags :=--package := unordered-containers-version := $(shell awk '/^version:/{print $$2}' ../$(package).cabal)-lib := ../dist/build/libHS$(package)-$(version)$(lib-suffix).a-ghc-flags := -Wall -O2 -hide-all-packages \- -package-conf ../dist/package.conf.inplace -package base -package mtl \- -package unordered-containers -package containers -package criterion \- -package deepseq -package hashable -package random -package bytestring \- $(ghc-prof-flags) -rtsopts-ghc-flags += $(extra-ghc-flags)-criterion-flags :=--%.o: %.hs- $(ghc) $(ghc-flags) -c -o $@ $<--programs := bench--.PHONY: all-all: $(programs)--bench: $(lib) Benchmarks.o Util/Int.o Util/ByteString.o Util/String.o- ranlib $(lib)- $(ghc) $(ghc-flags) -threaded -o $@ $(filter %.o,$^) $(lib)--.PHONY: bench-all-bench-all: bench- ./bench $(criterion-flags) +RTS -H -RTS `./bench -l | sed 's/ *\(.*\)/\1/' | grep -v "Benchmarks:\|IntMap\|Map"`--.PHONY: clean-clean:- -find . \( -name '*.o' -o -name '*.hi' \) -exec rm {} \;- -rm -f $(programs)--Benchmarks.o: Util/Int.o Util/ByteString.o Util/String.o-Util/ByteString.o: Util/String.o
− benchmarks/Util/ByteString.hs
@@ -1,29 +0,0 @@--- | Benchmarking utilities. For example, functions for generating--- random 'ByteString's.-module Util.ByteString where--import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as C--import Util.String as String---- | Generate a number of fixed length 'ByteString's where the content--- of the strings are letters in ascending order.-asc :: Int -- ^ Length of each string- -> Int -- ^ Number of strings- -> [S.ByteString]-asc strlen num = map C.pack $ String.asc strlen num---- | Generate a number of fixed length 'ByteString's where the content--- of the strings are letters in random order.-rnd :: Int -- ^ Length of each string- -> Int -- ^ Number of strings- -> [S.ByteString]-rnd strlen num = map C.pack $ String.rnd strlen num---- | Generate a number of fixed length 'ByteString's where the content--- of the strings are letters in random order, different from @rnd@.-rnd' :: Int -- ^ Length of each string- -> Int -- ^ Number of strings- -> [S.ByteString]-rnd' strlen num = map C.pack $ String.rnd' strlen num
− benchmarks/Util/Int.hs
@@ -1,19 +0,0 @@--- | Benchmarking utilities. For example, functions for generating--- random integers.-module Util.Int where--import System.Random (mkStdGen, randomRs)---- | Generate a number of uniform random integers in the interval--- @[0..upper]@.-rnd :: Int -- ^ Upper bound (inclusive)- -> Int -- ^ Number of integers- -> [Int]-rnd upper num = take num $ randomRs (0, upper) $ mkStdGen 1234---- | Generate a number of uniform random integers in the interval--- @[0..upper]@ different from @rnd@.-rnd' :: Int -- ^ Upper bound (inclusive)- -> Int -- ^ Number of integers- -> [Int]-rnd' upper num = take num $ randomRs (0, upper) $ mkStdGen 5678
− benchmarks/Util/String.hs
@@ -1,34 +0,0 @@--- | Benchmarking utilities. For example, functions for generating--- random strings.-module Util.String where--import System.Random (mkStdGen, randomRs)---- | Generate a number of fixed length strings where the content of--- the strings are letters in ascending order.-asc :: Int -- ^ Length of each string- -> Int -- ^ Number of strings- -> [String]-asc strlen num = take num $ iterate (snd . inc) $ replicate strlen 'a'- where inc [] = (True, [])- inc (c:cs) = case inc cs of (True, cs') | c == 'z' -> (True, 'a' : cs')- | otherwise -> (False, succ c : cs')- (False, cs') -> (False, c : cs')---- | Generate a number of fixed length strings where the content of--- the strings are letters in random order.-rnd :: Int -- ^ Length of each string- -> Int -- ^ Number of strings- -> [String]-rnd strlen num = take num $ split $ randomRs ('a', 'z') $ mkStdGen 1234- where- split cs = case splitAt strlen cs of (str, cs') -> str : split cs'---- | Generate a number of fixed length strings where the content of--- the strings are letters in random order, different from rnd-rnd' :: Int -- ^ Length of each string- -> Int -- ^ Number of strings- -> [String]-rnd' strlen num = take num $ split $ randomRs ('a', 'z') $ mkStdGen 5678- where- split cs = case splitAt strlen cs of (str, cs') -> str : split cs'
+ cbits/popc.c view
@@ -0,0 +1,273 @@+#include <inttypes.h>++/* Cribbed from http://wiki.cs.pdx.edu/forge/popcount.html */+static char popcount_table_8[256] = {+ /*0*/ 0,+ /*1*/ 1,+ /*2*/ 1,+ /*3*/ 2,+ /*4*/ 1,+ /*5*/ 2,+ /*6*/ 2,+ /*7*/ 3,+ /*8*/ 1,+ /*9*/ 2,+ /*10*/ 2,+ /*11*/ 3,+ /*12*/ 2,+ /*13*/ 3,+ /*14*/ 3,+ /*15*/ 4,+ /*16*/ 1,+ /*17*/ 2,+ /*18*/ 2,+ /*19*/ 3,+ /*20*/ 2,+ /*21*/ 3,+ /*22*/ 3,+ /*23*/ 4,+ /*24*/ 2,+ /*25*/ 3,+ /*26*/ 3,+ /*27*/ 4,+ /*28*/ 3,+ /*29*/ 4,+ /*30*/ 4,+ /*31*/ 5,+ /*32*/ 1,+ /*33*/ 2,+ /*34*/ 2,+ /*35*/ 3,+ /*36*/ 2,+ /*37*/ 3,+ /*38*/ 3,+ /*39*/ 4,+ /*40*/ 2,+ /*41*/ 3,+ /*42*/ 3,+ /*43*/ 4,+ /*44*/ 3,+ /*45*/ 4,+ /*46*/ 4,+ /*47*/ 5,+ /*48*/ 2,+ /*49*/ 3,+ /*50*/ 3,+ /*51*/ 4,+ /*52*/ 3,+ /*53*/ 4,+ /*54*/ 4,+ /*55*/ 5,+ /*56*/ 3,+ /*57*/ 4,+ /*58*/ 4,+ /*59*/ 5,+ /*60*/ 4,+ /*61*/ 5,+ /*62*/ 5,+ /*63*/ 6,+ /*64*/ 1,+ /*65*/ 2,+ /*66*/ 2,+ /*67*/ 3,+ /*68*/ 2,+ /*69*/ 3,+ /*70*/ 3,+ /*71*/ 4,+ /*72*/ 2,+ /*73*/ 3,+ /*74*/ 3,+ /*75*/ 4,+ /*76*/ 3,+ /*77*/ 4,+ /*78*/ 4,+ /*79*/ 5,+ /*80*/ 2,+ /*81*/ 3,+ /*82*/ 3,+ /*83*/ 4,+ /*84*/ 3,+ /*85*/ 4,+ /*86*/ 4,+ /*87*/ 5,+ /*88*/ 3,+ /*89*/ 4,+ /*90*/ 4,+ /*91*/ 5,+ /*92*/ 4,+ /*93*/ 5,+ /*94*/ 5,+ /*95*/ 6,+ /*96*/ 2,+ /*97*/ 3,+ /*98*/ 3,+ /*99*/ 4,+ /*100*/ 3,+ /*101*/ 4,+ /*102*/ 4,+ /*103*/ 5,+ /*104*/ 3,+ /*105*/ 4,+ /*106*/ 4,+ /*107*/ 5,+ /*108*/ 4,+ /*109*/ 5,+ /*110*/ 5,+ /*111*/ 6,+ /*112*/ 3,+ /*113*/ 4,+ /*114*/ 4,+ /*115*/ 5,+ /*116*/ 4,+ /*117*/ 5,+ /*118*/ 5,+ /*119*/ 6,+ /*120*/ 4,+ /*121*/ 5,+ /*122*/ 5,+ /*123*/ 6,+ /*124*/ 5,+ /*125*/ 6,+ /*126*/ 6,+ /*127*/ 7,+ /*128*/ 1,+ /*129*/ 2,+ /*130*/ 2,+ /*131*/ 3,+ /*132*/ 2,+ /*133*/ 3,+ /*134*/ 3,+ /*135*/ 4,+ /*136*/ 2,+ /*137*/ 3,+ /*138*/ 3,+ /*139*/ 4,+ /*140*/ 3,+ /*141*/ 4,+ /*142*/ 4,+ /*143*/ 5,+ /*144*/ 2,+ /*145*/ 3,+ /*146*/ 3,+ /*147*/ 4,+ /*148*/ 3,+ /*149*/ 4,+ /*150*/ 4,+ /*151*/ 5,+ /*152*/ 3,+ /*153*/ 4,+ /*154*/ 4,+ /*155*/ 5,+ /*156*/ 4,+ /*157*/ 5,+ /*158*/ 5,+ /*159*/ 6,+ /*160*/ 2,+ /*161*/ 3,+ /*162*/ 3,+ /*163*/ 4,+ /*164*/ 3,+ /*165*/ 4,+ /*166*/ 4,+ /*167*/ 5,+ /*168*/ 3,+ /*169*/ 4,+ /*170*/ 4,+ /*171*/ 5,+ /*172*/ 4,+ /*173*/ 5,+ /*174*/ 5,+ /*175*/ 6,+ /*176*/ 3,+ /*177*/ 4,+ /*178*/ 4,+ /*179*/ 5,+ /*180*/ 4,+ /*181*/ 5,+ /*182*/ 5,+ /*183*/ 6,+ /*184*/ 4,+ /*185*/ 5,+ /*186*/ 5,+ /*187*/ 6,+ /*188*/ 5,+ /*189*/ 6,+ /*190*/ 6,+ /*191*/ 7,+ /*192*/ 2,+ /*193*/ 3,+ /*194*/ 3,+ /*195*/ 4,+ /*196*/ 3,+ /*197*/ 4,+ /*198*/ 4,+ /*199*/ 5,+ /*200*/ 3,+ /*201*/ 4,+ /*202*/ 4,+ /*203*/ 5,+ /*204*/ 4,+ /*205*/ 5,+ /*206*/ 5,+ /*207*/ 6,+ /*208*/ 3,+ /*209*/ 4,+ /*210*/ 4,+ /*211*/ 5,+ /*212*/ 4,+ /*213*/ 5,+ /*214*/ 5,+ /*215*/ 6,+ /*216*/ 4,+ /*217*/ 5,+ /*218*/ 5,+ /*219*/ 6,+ /*220*/ 5,+ /*221*/ 6,+ /*222*/ 6,+ /*223*/ 7,+ /*224*/ 3,+ /*225*/ 4,+ /*226*/ 4,+ /*227*/ 5,+ /*228*/ 4,+ /*229*/ 5,+ /*230*/ 5,+ /*231*/ 6,+ /*232*/ 4,+ /*233*/ 5,+ /*234*/ 5,+ /*235*/ 6,+ /*236*/ 5,+ /*237*/ 6,+ /*238*/ 6,+ /*239*/ 7,+ /*240*/ 4,+ /*241*/ 5,+ /*242*/ 5,+ /*243*/ 6,+ /*244*/ 5,+ /*245*/ 6,+ /*246*/ 6,+ /*247*/ 7,+ /*248*/ 5,+ /*249*/ 6,+ /*250*/ 6,+ /*251*/ 7,+ /*252*/ 6,+ /*253*/ 7,+ /*254*/ 7,+ /*255*/ 8,+};+/* Table-driven popcount, with 8-bit tables */+/* 6 ops plus 4 casts and 4 lookups, 0 long immediates, 4 stages */+inline uint32_t+popcount(uint32_t x)+{+ return popcount_table_8[(uint8_t)x] ++ popcount_table_8[(uint8_t)(x >> 8)] ++ popcount_table_8[(uint8_t)(x >> 16)] ++ popcount_table_8[(uint8_t)(x >> 24)];+}++/* TODO: Add a 16-bit variant */
+ tests/HashMapProperties.hs view
@@ -0,0 +1,220 @@+ {-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}++-- | Tests for the 'Data.HashMap.Lazy' module. We test functions by+-- comparing them to a simpler model, an association list.++module Main (main) where++import qualified Data.Foldable as Foldable+import Data.Function (on)+import Data.Hashable (Hashable(hash))+import qualified Data.List as L+#if defined(STRICT)+import qualified Data.HashMap.Strict as HM+#else+import qualified Data.HashMap.Lazy as HM+#endif+import qualified Data.Map as M+import Test.QuickCheck (Arbitrary)+import Test.Framework (Test, defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)++-- Key type that generates more hash collisions.+newtype Key = K { unK :: Int }+ deriving (Arbitrary, Eq, Ord, Show)++instance Hashable Key where+ hash k = hash (unK k) `mod` 20++------------------------------------------------------------------------+-- * Properties++------------------------------------------------------------------------+-- ** Instances++pEq :: [(Key, Int)] -> [(Key, Int)] -> Bool+pEq xs ys = (M.fromList xs ==) `eq` (HM.fromList xs ==) $ ys++pNeq :: [(Key, Int)] -> [(Key, Int)] -> Bool+pNeq xs = (M.fromList xs /=) `eq` (HM.fromList xs /=)++pFunctor :: [(Key, Int)] -> Bool+pFunctor = fmap (+ 1) `eq_` fmap (+ 1)++pFoldable :: [(Int, Int)] -> Bool+pFoldable = (L.sort . Foldable.foldr (:) []) `eq`+ (L.sort . Foldable.foldr (:) [])++------------------------------------------------------------------------+-- ** Basic interface++pSize :: [(Key, Int)] -> Bool+pSize = M.size `eq` HM.size++pLookup :: Key -> [(Key, Int)] -> Bool+pLookup k = M.lookup k `eq` HM.lookup k++pInsert :: Key -> Int -> [(Key, Int)] -> Bool+pInsert k v = M.insert k v `eq_` HM.insert k v++pDelete :: Key -> [(Key, Int)] -> Bool+pDelete k = M.delete k `eq_` HM.delete k++pInsertWith :: Key -> [(Key, Int)] -> Bool+pInsertWith k = M.insertWith (+) k 1 `eq_` HM.insertWith (+) k 1++pAdjust :: Key -> [(Key, Int)] -> Bool+pAdjust k = M.adjust succ k `eq_` HM.adjust succ k++------------------------------------------------------------------------+-- ** Combine++pUnion :: [(Key, Int)] -> [(Key, Int)] -> Bool+pUnion xs ys = M.union (M.fromList xs) `eq_` HM.union (HM.fromList xs) $ ys++pUnionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool+pUnionWith xs ys = M.unionWith (-) (M.fromList xs) `eq_`+ HM.unionWith (-) (HM.fromList xs) $ ys++------------------------------------------------------------------------+-- ** Transformations++pMap :: [(Key, Int)] -> Bool+pMap = M.map (+1 ) `eq_` HM.map (+ 1)++------------------------------------------------------------------------+-- ** Difference and intersection++pDifference :: [(Key, Int)] -> [(Key, Int)] -> Bool+pDifference xs ys = M.difference (M.fromList xs) `eq_`+ HM.difference (HM.fromList xs) $ ys++pIntersection :: [(Key, Int)] -> [(Key, Int)] -> Bool+pIntersection xs ys = M.intersection (M.fromList xs) `eq_`+ HM.intersection (HM.fromList xs) $ ys++------------------------------------------------------------------------+-- ** Folds++pFoldr :: [(Int, Int)] -> Bool+pFoldr = (L.sort . M.fold (:) []) `eq` (L.sort . HM.foldr (:) [])++pFoldrWithKey :: [(Int, Int)] -> Bool+pFoldrWithKey = (sortByKey . M.foldrWithKey f []) `eq`+ (sortByKey . HM.foldrWithKey f [])+ where f k v z = (k, v) : z++pFoldl' :: Int -> [(Int, Int)] -> Bool+pFoldl' z0 = M.foldlWithKey' (\ z _ v -> v + z) z0 `eq` HM.foldl' (+) z0++------------------------------------------------------------------------+-- ** Filter++pFilter :: [(Key, Int)] -> Bool+pFilter = M.filter odd `eq_` HM.filter odd++pFilterWithKey :: [(Key, Int)] -> Bool+pFilterWithKey = M.filterWithKey p `eq_` HM.filterWithKey p+ where p k v = odd (unK k + v)++------------------------------------------------------------------------+-- ** Conversions++pToList :: [(Key, Int)] -> Bool+pToList = M.toAscList `eq` toAscList++pElems :: [(Key, Int)] -> Bool+pElems = (L.sort . M.elems) `eq` (L.sort . HM.elems)++pKeys :: [(Key, Int)] -> Bool+pKeys = (L.sort . M.keys) `eq` (L.sort . HM.keys)++------------------------------------------------------------------------+-- * Test list++tests :: [Test]+tests =+ [+ -- Instances+ testGroup "instances"+ [ testProperty "==" pEq+ , testProperty "/=" pNeq+ , testProperty "Functor" pFunctor+ , testProperty "Foldable" pFoldable+ ]+ -- Basic interface+ , testGroup "basic interface"+ [ testProperty "size" pSize+ , testProperty "lookup" pLookup+ , testProperty "insert" pInsert+ , testProperty "delete" pDelete+ , testProperty "insertWith" pInsertWith+ , testProperty "adjust" pAdjust+ ]+ -- Combine+ , testProperty "union" pUnion+ , testProperty "unionWith" pUnionWith+ -- Transformations+ , testProperty "map" pMap+ -- Folds+ , testGroup "folds"+ [ testProperty "foldr" pFoldr+ , testProperty "foldrWithKey" pFoldrWithKey+ , testProperty "foldl'" pFoldl'+ ]+ , testGroup "difference and intersection"+ [ testProperty "difference" pDifference+ , testProperty "intersection" pIntersection+ ]+ -- Filter+ , testGroup "filter"+ [ testProperty "filter" pFilter+ , testProperty "filterWithKey" pFilterWithKey+ ]+ -- Conversions+ , testGroup "conversions"+ [ testProperty "elems" pElems+ , testProperty "keys" pKeys+ , testProperty "toList" pToList+ ]+ ]++------------------------------------------------------------------------+-- * Model++type Model k v = M.Map k v++-- | Check that a function operating on a 'HashMap' is equivalent to+-- one operating on a 'Model'.+eq :: (Eq a, Eq k, Hashable k, Ord k)+ => (Model k v -> a) -- ^ Function that modifies a 'Model'+ -> (HM.HashMap k v -> a) -- ^ Function that modified a 'HashMap' in the same+ -- way+ -> [(k, v)] -- ^ Initial content of the 'HashMap' and 'Model'+ -> Bool -- ^ True if the functions are equivalent+eq f g xs = g (HM.fromList xs) == f (M.fromList xs)++eq_ :: (Eq k, Eq v, Hashable k, Ord k)+ => (Model k v -> Model k v) -- ^ Function that modifies a 'Model'+ -> (HM.HashMap k v -> HM.HashMap k v) -- ^ Function that modified a+ -- 'HashMap' in the same way+ -> [(k, v)] -- ^ Initial content of the 'HashMap'+ -- and 'Model'+ -> Bool -- ^ True if the functions are+ -- equivalent+eq_ f g = (M.toAscList . f) `eq` (toAscList . g)++------------------------------------------------------------------------+-- * Test harness++main :: IO ()+main = defaultMain tests++------------------------------------------------------------------------+-- * Helpers++sortByKey :: Ord k => [(k, v)] -> [(k, v)]+sortByKey = L.sortBy (compare `on` fst)++toAscList :: Ord k => HM.HashMap k v -> [(k, v)]+toAscList = L.sortBy (compare `on` fst) . HM.toList
+ tests/HashSetProperties.hs view
@@ -0,0 +1,171 @@+ {-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Tests for the 'Data.HashSet' module. We test functions by+-- comparing them to a simpler model, a list.++module Main (main) where++import qualified Data.Foldable as Foldable+import Data.Hashable (Hashable(hash))+import qualified Data.List as L+import qualified Data.HashSet as S+import qualified Data.Set as Set+import Test.QuickCheck (Arbitrary)+import Test.Framework (Test, defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)++-- Key type that generates more hash collisions.+newtype Key = K { unK :: Int }+ deriving (Arbitrary, Eq, Ord, Show)++instance Hashable Key where+ hash k = hash (unK k) `mod` 20++------------------------------------------------------------------------+-- * Properties++------------------------------------------------------------------------+-- ** Instances++pEq :: [Key] -> [Key] -> Bool+pEq xs = (unique xs ==) `eq` (S.fromList xs ==)++pNeq :: [Key] -> [Key] -> Bool+pNeq xs = (unique xs /=) `eq` (S.fromList xs /=)++pFoldable :: [Int] -> Bool+pFoldable = (L.sort . Foldable.foldr (:) []) `eq`+ (L.sort . Foldable.foldr (:) [])++------------------------------------------------------------------------+-- ** Basic interface++pSize :: [Key] -> Bool+pSize = length `eq` S.size++pMember :: Key -> [Key] -> Bool+pMember k = L.elem k `eq` S.member k++pInsert :: Key -> [Key] -> Bool+pInsert a = insert a `eq` (toAscList . S.insert a)++pDelete :: Key -> [Key] -> Bool+pDelete a = delete a `eq` (toAscList . S.delete a)++------------------------------------------------------------------------+-- ** Combine++pUnion :: [Key] -> [Key] -> Bool+pUnion xs ys = L.sort (L.union as bs) ==+ toAscList (S.union (S.fromList as) (S.fromList bs))+ where+ as = fromList xs+ bs = fromList ys++------------------------------------------------------------------------+-- ** Transformations++pMap :: [Key] -> Bool+pMap = map f `eq` (toAscList . S.map f)+ where f (K k) = K (k + 1)++------------------------------------------------------------------------+-- ** Folds++pFoldr :: [Int] -> Bool+pFoldr = (L.sort . L.foldr (:) []) `eq`+ (L.sort . S.foldr (:) [])++pFoldl' :: Int -> [Int] -> Bool+pFoldl' z0 = L.foldl' (+) z0 `eq` S.foldl' (+) z0++------------------------------------------------------------------------+-- ** Conversions++pToList :: [Key] -> Bool+pToList = id `eq` toAscList++------------------------------------------------------------------------+-- * Test list++tests :: [Test]+tests =+ [+ -- Instances+ testGroup "instances"+ [ testProperty "==" pEq+ , testProperty "/=" pNeq+ , testProperty "Foldable" pFoldable+ ]+ -- Basic interface+ , testGroup "basic interface"+ [ testProperty "size" pSize+ , testProperty "member" pMember+ , testProperty "insert" pInsert+ , testProperty "delete" pDelete+ ]+ -- Combine+ , testProperty "union" pUnion+ -- Transformations+ , testProperty "map" pMap+ -- Folds+ , testGroup "folds"+ [ testProperty "foldr" pFoldr+ , testProperty "foldl'" pFoldl'+ ]+ -- Conversions+ , testGroup "conversions"+ [ testProperty "toList" pToList+ ]+ ]++------------------------------------------------------------------------+-- * Model++-- Invariant: the list is sorted in ascending order, by key.+type Model a = [a]++-- | Check that a function operating on a 'HashMap' is equivalent to+-- one operating on a 'Model'.+eq :: (Eq a, Hashable a, Ord a, Eq b)+ => (Model a -> b) -- ^ Function that modifies a 'Model' in the same+ -- way+ -> (S.HashSet a -> b) -- ^ Function that modified a 'HashSet'+ -> [a] -- ^ Initial content of the 'HashSet' and 'Model'+ -> Bool -- ^ True if the functions are equivalent+eq f g xs = g (S.fromList ys) == f ys+ where ys = fromList xs++insert :: Ord a => a -> Model a -> Model a+insert x [] = [x]+insert x (y:xs)+ | x == y = x : xs+ | x > y = y : insert x xs+ | otherwise = x : y : xs++delete :: Ord a => a -> Model a -> Model a+delete _ [] = []+delete k ys@(y:xs)+ | k == y = xs+ | k > y = y : delete k xs+ | otherwise = ys++-- | Create a model from a list of key-value pairs. If the input+-- contains multiple entries for the same key, the latter one is used.+fromList :: Ord a => [a] -> Model a+fromList = L.foldl' (\ m p -> insert p m) []++------------------------------------------------------------------------+-- * Test harness++main :: IO ()+main = defaultMain tests++------------------------------------------------------------------------+-- * Helpers++toAscList :: Ord a => S.HashSet a -> [a]+toAscList = L.sort . S.toList++unique :: (Eq a, Ord a) => [a] -> [a]+unique = Set.toList . Set.fromList
− tests/MapProperties.hs
@@ -1,222 +0,0 @@- {-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | Tests for the 'Data.HashMap.Lazy' module. We test functions by--- comparing them to a simpler model, an association list.--module Main (main) where--import qualified Data.Foldable as Foldable-import Data.Function (on)-import Data.Hashable (Hashable(hash))-import qualified Data.List as L-import qualified Data.HashMap.Lazy as M-import Test.QuickCheck (Arbitrary)-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)---- Key type that generates more hash collisions.-newtype Key = K { unK :: Int }- deriving (Arbitrary, Eq, Ord, Show)--instance Hashable Key where- hash k = hash (unK k) `mod` 20----------------------------------------------------------------------------- * Properties----------------------------------------------------------------------------- ** Instances--pEq :: [(Key, Int)] -> [(Key, Int)] -> Bool-pEq xs ys = (as ==) `eq` (M.fromList as ==) $ bs- where as = fromList xs- bs = fromList ys--pNeq :: [(Key, Int)] -> [(Key, Int)] -> Bool-pNeq xs = (xs /=) `eq` (M.fromList xs /=)--pFunctor :: [(Key, Int)] -> Bool-pFunctor = fmap (\ (k, v) -> (k, v + 1)) `eq` (toAscList . fmap (+ 1))--pFoldable :: [(Int, Int)] -> Bool-pFoldable = (L.sort . Foldable.foldr (\ (_, v) z -> v:z) []) `eq`- (L.sort . Foldable.foldr (:) [])----------------------------------------------------------------------------- ** Basic interface--pSize :: [(Key, Int)] -> Bool-pSize = length `eq` M.size--pLookup :: Key -> [(Key, Int)] -> Bool-pLookup k = L.lookup k `eq` M.lookup k--pInsert :: Key -> Int -> [(Key, Int)] -> Bool-pInsert k v = insert (k, v) `eq` (toAscList . M.insert k v)--pDelete :: Key -> [(Key, Int)] -> Bool-pDelete k = delete k `eq` (toAscList . M.delete k)--pInsertWith :: Key -> [(Key, Int)] -> Bool-pInsertWith k = insertWith (+) (k, 1) `eq`- (toAscList . M.insertWith (+) k 1)----------------------------------------------------------------------------- ** Combine--pUnion :: [(Key, Int)] -> [(Key, Int)] -> Bool-pUnion xs ys = L.sort (unionByKey as bs) == - toAscList (M.union (M.fromList as) (M.fromList bs))- where- as = fromList xs- bs = fromList ys--pUnionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool-pUnionWith xs ys = L.sort (unionByKeyWith (-) as bs) ==- toAscList (M.unionWith (-) (M.fromList as) (M.fromList bs))- where- as = fromList xs- bs = fromList ys----------------------------------------------------------------------------- ** Transformations--pMap :: [(Key, Int)] -> Bool-pMap = map (\ (k, v) -> (k, v + 1)) `eq` (toAscList . M.map (+ 1))----------------------------------------------------------------------------- ** Folds--pFoldr :: [(Int, Int)] -> Bool-pFoldr = (L.sort . L.foldr (\ (_, v) z -> v:z) []) `eq`- (L.sort . M.foldr (:) [])--pFoldrWithKey :: [(Int, Int)] -> Bool-pFoldrWithKey = (sortByKey . L.foldr (:) []) `eq`- (sortByKey . M.foldrWithKey f [])- where f k v z = (k, v) : z--pFoldl' :: Int -> [(Int, Int)] -> Bool-pFoldl' z0 = L.foldl' (\ z (_, v) -> z + v) z0 `eq` M.foldl' (+) z0----------------------------------------------------------------------------- ** Conversions--pToList :: [(Key, Int)] -> Bool-pToList = id `eq` toAscList--pElems :: [(Key, Int)] -> Bool-pElems = (L.sort . map snd) `eq` (L.sort . M.elems)--pKeys :: [(Key, Int)] -> Bool-pKeys = map fst `eq` (L.sort . M.keys)----------------------------------------------------------------------------- * Test list--tests :: [Test]-tests =- [- -- Instances- testGroup "instances"- [ testProperty "==" pEq- , testProperty "/=" pNeq- , testProperty "Functor" pFunctor- , testProperty "Foldable" pFoldable- ]- -- Basic interface- , testGroup "basic interface"- [ testProperty "size" pSize- , testProperty "lookup" pLookup- , testProperty "insert" pInsert- , testProperty "delete" pDelete- , testProperty "insertWith" pInsertWith- ]- -- Combine- , testProperty "union" pUnion- , testProperty "unionWith" pUnionWith- -- Transformations- , testProperty "map" pMap- -- Folds- , testGroup "folds"- [ testProperty "foldr" pFoldr- , testProperty "foldrWithKey" pFoldrWithKey- , testProperty "foldl'" pFoldl'- ]- -- Conversions- , testGroup "conversions"- [ testProperty "elems" pElems- , testProperty "keys" pKeys- , testProperty "toList" pToList- ]- ]----------------------------------------------------------------------------- * Model---- Invariant: the list is sorted in ascending order, by key.-type Model k v = [(k, v)]---- | Check that a function operating on a 'HashMap' is equivalent to--- one operating on a 'Model'.-eq :: (Eq a, Eq k, Hashable k, Ord k)- => (Model k v -> a) -- ^ Function that modifies a 'Model' in the same- -- way- -> (M.HashMap k v -> a) -- ^ Function that modified a 'HashMap'- -> [(k, v)] -- ^ Initial content of the 'HashMap' and 'Model'- -> Bool -- ^ True if the functions are equivalent-eq f g xs = g (M.fromList ys) == f ys- where ys = fromList xs--insert :: Ord k => (k, v) -> Model k v -> Model k v-insert x [] = [x]-insert x@(k, _) (y@(k', _):xs)- | k == k' = x : xs- | k > k' = y : insert x xs- | otherwise = x : y : xs--delete :: Ord k => k -> Model k v -> Model k v-delete _ [] = []-delete k ys@(y@(k', _):xs)- | k == k' = xs- | k > k' = y : delete k xs- | otherwise = ys--insertWith :: Ord k => (v -> v -> v) -> (k, v) -> Model k v -> Model k v-insertWith _ x [] = [x]-insertWith f x@(k, v) (y@(k', v'):xs)- | k == k' = (k', f v v') : xs- | k > k' = y : insertWith f x xs- | otherwise = x : y : xs---- | Create a model from a list of key-value pairs. If the input--- contains multiple entries for the same key, the latter one is used.-fromList :: Ord k => [(k, v)] -> Model k v-fromList = L.foldl' (\ m p -> insert p m) []----------------------------------------------------------------------------- * Test harness--main :: IO ()-main = defaultMain tests----------------------------------------------------------------------------- * Helpers--sortByKey :: Ord k => [(k, v)] -> [(k, v)]-sortByKey = L.sortBy (compare `on` fst)--unionByKey :: (Eq k, Eq v) => [(k, v)] -> [(k, v)] -> [(k, v)]-unionByKey = L.unionBy ((==) `on` fst)--unionByKeyWith :: (Eq k, Eq v) => (v -> v -> v) -> [(k,v)] -> [(k,v)] -> [(k,v)]-unionByKeyWith f a b = go a b- where- go [] ys = ys- go (x:xs) ys =- case L.lookup (fst x) ys of- Just z -> (fst x, f (snd x) z) : go xs (filter ((/= fst x) . fst) ys)- Nothing -> x : go xs ys--toAscList :: (Ord k, Ord v) => M.HashMap k v -> [(k, v)]-toAscList = L.sort . M.toList
− tests/SetProperties.hs
@@ -1,171 +0,0 @@- {-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | Tests for the 'Data.HashSet' module. We test functions by--- comparing them to a simpler model, a list.--module Main (main) where--import qualified Data.Foldable as Foldable-import Data.Hashable (Hashable(hash))-import qualified Data.List as L-import qualified Data.HashSet as S-import qualified Data.Set as Set-import Test.QuickCheck (Arbitrary)-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)---- Key type that generates more hash collisions.-newtype Key = K { unK :: Int }- deriving (Arbitrary, Eq, Ord, Show)--instance Hashable Key where- hash k = hash (unK k) `mod` 20----------------------------------------------------------------------------- * Properties----------------------------------------------------------------------------- ** Instances--pEq :: [Key] -> [Key] -> Bool-pEq xs = (unique xs ==) `eq` (S.fromList xs ==)--pNeq :: [Key] -> [Key] -> Bool-pNeq xs = (unique xs /=) `eq` (S.fromList xs /=)--pFoldable :: [Int] -> Bool-pFoldable = (L.sort . Foldable.foldr (:) []) `eq`- (L.sort . Foldable.foldr (:) [])----------------------------------------------------------------------------- ** Basic interface--pSize :: [Key] -> Bool-pSize = length `eq` S.size--pMember :: Key -> [Key] -> Bool-pMember k = L.elem k `eq` S.member k--pInsert :: Key -> [Key] -> Bool-pInsert a = insert a `eq` (toAscList . S.insert a)--pDelete :: Key -> [Key] -> Bool-pDelete a = delete a `eq` (toAscList . S.delete a)----------------------------------------------------------------------------- ** Combine--pUnion :: [Key] -> [Key] -> Bool-pUnion xs ys = L.sort (L.union as bs) ==- toAscList (S.union (S.fromList as) (S.fromList bs))- where- as = fromList xs- bs = fromList ys----------------------------------------------------------------------------- ** Transformations--pMap :: [Key] -> Bool-pMap = map f `eq` (toAscList . S.map f)- where f (K k) = K (k + 1)----------------------------------------------------------------------------- ** Folds--pFoldr :: [Int] -> Bool-pFoldr = (L.sort . L.foldr (:) []) `eq`- (L.sort . S.foldr (:) [])--pFoldl' :: Int -> [Int] -> Bool-pFoldl' z0 = L.foldl' (+) z0 `eq` S.foldl' (+) z0----------------------------------------------------------------------------- ** Conversions--pToList :: [Key] -> Bool-pToList = id `eq` toAscList----------------------------------------------------------------------------- * Test list--tests :: [Test]-tests =- [- -- Instances- testGroup "instances"- [ testProperty "==" pEq- , testProperty "/=" pNeq- , testProperty "Foldable" pFoldable- ]- -- Basic interface- , testGroup "basic interface"- [ testProperty "size" pSize- , testProperty "member" pMember- , testProperty "insert" pInsert- , testProperty "delete" pDelete- ]- -- Combine- , testProperty "union" pUnion- -- Transformations- , testProperty "map" pMap- -- Folds- , testGroup "folds"- [ testProperty "foldr" pFoldr- , testProperty "foldl'" pFoldl'- ]- -- Conversions- , testGroup "conversions"- [ testProperty "toList" pToList- ]- ]----------------------------------------------------------------------------- * Model---- Invariant: the list is sorted in ascending order, by key.-type Model a = [a]---- | Check that a function operating on a 'HashMap' is equivalent to--- one operating on a 'Model'.-eq :: (Eq a, Hashable a, Ord a, Eq b)- => (Model a -> b) -- ^ Function that modifies a 'Model' in the same- -- way- -> (S.HashSet a -> b) -- ^ Function that modified a 'HashSet'- -> [a] -- ^ Initial content of the 'HashSet' and 'Model'- -> Bool -- ^ True if the functions are equivalent-eq f g xs = g (S.fromList ys) == f ys- where ys = fromList xs--insert :: Ord a => a -> Model a -> Model a-insert x [] = [x]-insert x (y:xs)- | x == y = x : xs- | x > y = y : insert x xs- | otherwise = x : y : xs--delete :: Ord a => a -> Model a -> Model a-delete _ [] = []-delete k ys@(y:xs)- | k == y = xs- | k > y = y : delete k xs- | otherwise = ys---- | Create a model from a list of key-value pairs. If the input--- contains multiple entries for the same key, the latter one is used.-fromList :: Ord a => [a] -> Model a-fromList = L.foldl' (\ m p -> insert p m) []----------------------------------------------------------------------------- * Test harness--main :: IO ()-main = defaultMain tests----------------------------------------------------------------------------- * Helpers--toAscList :: Ord a => S.HashSet a -> [a]-toAscList = L.sort . S.toList--unique :: (Eq a, Ord a) => [a] -> [a]-unique = Set.toList . Set.fromList
unordered-containers.cabal view
@@ -1,5 +1,5 @@ name: unordered-containers-version: 0.1.4.6+version: 0.2.0.0 synopsis: Efficient hashing-based container types description: Efficient hashing-based container types. The containers have been@@ -10,79 +10,96 @@ amortized, but remains valid even if structures are shared. license: BSD3 license-file: LICENSE-author: Johan Tibell <johan.tibell@gmail.com>+author: Johan Tibell maintainer: johan.tibell@gmail.com bug-reports: https://github.com/tibbe/unordered-containers/issues-copyright: (c) Daan Leijen 2002- (c) Andriy Palamarchuk 2008- (c) 2010-2011 Johan Tibell+copyright: 2010-2012 Johan Tibell+ 2010 Edward Z. Yang category: Data build-type: Simple cabal-version: >=1.8--- The test files shouldn't have to go here, but the source files for--- the test-suite stanzas don't get picked up by `cabal sdist`.-Extra-source-files:- tests/MapProperties.hs- tests/SetProperties.hs- benchmarks/Benchmarks.hs- benchmarks/Makefile- benchmarks/Util/*.hs +flag debug+ description: Enable debug support+ default: False+ library exposed-modules: Data.HashMap.Lazy Data.HashMap.Strict Data.HashSet+ other-modules:+ Data.HashMap.Array+ Data.HashMap.Base+ Data.HashMap.PopCount+ Data.HashMap.UnsafeShift build-depends: base >= 4 && < 4.6, deepseq >= 1.1 && < 1.4, hashable >= 1.0.1.1 && < 1.2 - other-modules:- Data.FullList.Lazy- Data.FullList.Strict- Data.HashMap.Common- Data.HashMap.Lazy.Internal- Data.HashMap.Strict.Internal+ if impl(ghc < 7.4)+ c-sources: cbits/popc.c ghc-options: -Wall -O2 if impl(ghc >= 6.8) ghc-options: -fwarn-tabs if impl(ghc > 6.10) ghc-options: -fregs-graph+ if flag(debug)+ cpp-options: -DASSERTS -test-suite map-properties+test-suite hashmap-lazy-properties hs-source-dirs: tests- main-is: MapProperties.hs+ main-is: HashMapProperties.hs type: exitcode-stdio-1.0 build-depends:- base >= 4,- hashable >= 1.0.1.1,+ base,+ containers >= 0.4.1 && < 0.5,+ hashable >= 1.0.1.1 && < 1.2, QuickCheck >= 2.4.0.1,- test-framework >= 0.3.3,- test-framework-quickcheck2 >= 0.2.9,+ test-framework >= 0.3.3 && < 0.6,+ test-framework-quickcheck2 >= 0.2.9 && < 0.3, unordered-containers ghc-options: -Wall+ cpp-options: -DASSERTS +test-suite hashmap-strict-properties+ hs-source-dirs: tests+ main-is: HashMapProperties.hs+ type: exitcode-stdio-1.0 -test-suite set-properties+ build-depends:+ base,+ containers >= 0.4.1 && < 0.5,+ hashable >= 1.0.1.1 && < 1.2,+ QuickCheck >= 2.4.0.1,+ test-framework >= 0.3.3 && < 0.6,+ test-framework-quickcheck2 >= 0.2.9 && < 0.3,+ unordered-containers++ ghc-options: -Wall+ cpp-options: -DASSERTS -DSTRICT++test-suite hashset-properties hs-source-dirs: tests- main-is: SetProperties.hs+ main-is: HashSetProperties.hs type: exitcode-stdio-1.0 build-depends:- base >= 4,- containers,- hashable >= 1.0.1.1,+ base,+ containers >= 0.4.1 && < 0.5,+ hashable >= 1.0.1.1 && < 1.2, QuickCheck >= 2.4.0.1,- test-framework >= 0.3.3,- test-framework-quickcheck2 >= 0.2.9,+ test-framework >= 0.3.3 && < 0.6,+ test-framework-quickcheck2 >= 0.2.9 && < 0.3, unordered-containers ghc-options: -Wall+ cpp-options: -DASSERTS source-repository head type: git