unordered-containers-0.2.7.1/0000755000000000000000000000000012726130613014200 5ustar0000000000000000unordered-containers-0.2.7.1/LICENSE0000644000000000000000000000276212726130613015214 0ustar0000000000000000Copyright (c) 2010, Johan Tibell All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Johan Tibell nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. unordered-containers-0.2.7.1/CHANGES.md0000644000000000000000000000076112726130613015576 0ustar0000000000000000## 0.2.7.1 * Fix linker error related to popcnt. * Haddock improvements. * Fix benchmark compilation when downloaded from Hackage. ## 0.2.7.0 * Support criterion 1.1 * Add unionWithKey for hash maps. ## 0.2.6.0 * Mark several modules as Trustworthy. * Add Hashable instances for HashMap and HashSet. * Add mapMaybe, mapMaybeWithKey, update, alter, and intersectionWithKey. * Add roles. * Add Hashable and Semigroup instances. ## 0.2.5.1 (2014-10-11) * Support base-4.8 unordered-containers-0.2.7.1/Setup.hs0000644000000000000000000000005612726130613015635 0ustar0000000000000000import Distribution.Simple main = defaultMain unordered-containers-0.2.7.1/unordered-containers.cabal0000644000000000000000000001011112726130613021310 0ustar0000000000000000name: unordered-containers version: 0.2.7.1 synopsis: Efficient hashing-based container types description: Efficient hashing-based container types. The containers have been optimized for performance critical use, both in terms of large data quantities and high speed. . The declared cost of each operation is either worst-case or amortized, but remains valid even if structures are shared. license: BSD3 license-file: LICENSE author: Johan Tibell maintainer: johan.tibell@gmail.com Homepage: https://github.com/tibbe/unordered-containers bug-reports: https://github.com/tibbe/unordered-containers/issues copyright: 2010-2014 Johan Tibell 2010 Edward Z. Yang category: Data build-type: Simple cabal-version: >=1.8 extra-source-files: CHANGES.md tested-with: GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 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.Unsafe Data.HashMap.UnsafeShift build-depends: base >= 4 && < 5, deepseq >= 1.1, hashable >= 1.0.1.1 && < 1.3 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 hashmap-lazy-properties hs-source-dirs: tests main-is: HashMapProperties.hs type: exitcode-stdio-1.0 build-depends: base, containers >= 0.4, hashable >= 1.0.1.1, QuickCheck >= 2.4.0.1, test-framework >= 0.3.3, test-framework-quickcheck2 >= 0.2.9, unordered-containers ghc-options: -Wall cpp-options: -DASSERTS test-suite hashmap-strict-properties hs-source-dirs: tests main-is: HashMapProperties.hs type: exitcode-stdio-1.0 build-depends: base, containers >= 0.4, hashable >= 1.0.1.1, QuickCheck >= 2.4.0.1, test-framework >= 0.3.3, test-framework-quickcheck2 >= 0.2.9, unordered-containers ghc-options: -Wall cpp-options: -DASSERTS -DSTRICT test-suite hashset-properties hs-source-dirs: tests main-is: HashSetProperties.hs type: exitcode-stdio-1.0 build-depends: base, containers >= 0.4, hashable >= 1.0.1.1, QuickCheck >= 2.4.0.1, test-framework >= 0.3.3, test-framework-quickcheck2 >= 0.2.9, unordered-containers ghc-options: -Wall cpp-options: -DASSERTS test-suite regressions hs-source-dirs: tests main-is: Regressions.hs type: exitcode-stdio-1.0 build-depends: base, hashable >= 1.0.1.1, HUnit, QuickCheck >= 2.4.0.1, test-framework >= 0.3.3, test-framework-hunit, test-framework-quickcheck2, unordered-containers ghc-options: -Wall cpp-options: -DASSERTS test-suite strictness-properties hs-source-dirs: tests main-is: Strictness.hs type: exitcode-stdio-1.0 build-depends: base, ChasingBottoms, containers >= 0.4.2, hashable >= 1.0.1.1, QuickCheck >= 2.4.0.1, test-framework >= 0.3.3, test-framework-quickcheck2 >= 0.2.9, unordered-containers ghc-options: -Wall cpp-options: -DASSERTS benchmark benchmarks -- We cannot depend on the unordered-containers library directly as -- that creates a dependency cycle. hs-source-dirs: . benchmarks main-is: Benchmarks.hs type: exitcode-stdio-1.0 other-modules: Util.ByteString Util.Int Util.String build-depends: base, bytestring, containers, criterion >= 1.0 && < 1.2, deepseq >= 1.1, deepseq-generics, hashable >= 1.0.1.1, hashmap, mtl, random if impl(ghc < 7.4) c-sources: cbits/popc.c ghc-options: -Wall -O2 -rtsopts if impl(ghc >= 6.8) ghc-options: -fwarn-tabs if impl(ghc > 6.10) ghc-options: -fregs-graph if flag(debug) cpp-options: -DASSERTS source-repository head type: git location: https://github.com/tibbe/unordered-containers.git unordered-containers-0.2.7.1/Data/0000755000000000000000000000000012726130613015051 5ustar0000000000000000unordered-containers-0.2.7.1/Data/HashSet.hs0000644000000000000000000002021312726130613016742 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TypeFamilies #-} #endif #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------ -- | -- Module : Data.HashSet -- Copyright : 2011 Bryan O'Sullivan -- License : BSD-style -- Maintainer : johan.tibell@gmail.com -- Stability : provisional -- Portability : portable -- -- A set of /hashable/ values. A set cannot contain duplicate items. -- A 'HashSet' makes no guarantees as to the order of its elements. -- -- The implementation is based on /hash array mapped trie/. A -- 'HashSet' is often faster than other tree-based set types, -- especially when value comparison is expensive, as in the case of -- strings. -- -- Many operations have a average-case complexity of /O(log n)/. The -- implementation uses a large base (i.e. 16) so in practice these -- operations are constant time. module Data.HashSet ( HashSet -- * Construction , empty , singleton -- * Combine , union , unions -- * Basic interface , null , size , member , insert , delete -- * Transformations , map -- * Difference and intersection , difference , intersection -- * Folds , foldl' , foldr -- * Filter , filter -- * Conversions -- ** Lists , toList , fromList -- * HashMaps , toMap , fromMap ) where import Control.DeepSeq (NFData(..)) import Data.Data hiding (Typeable) import Data.HashMap.Base (HashMap, foldrWithKey) import Data.Hashable (Hashable(hashWithSalt)) #if __GLASGOW_HASKELL__ >= 711 import Data.Semigroup (Semigroup(..), Monoid(..)) #elif __GLASGOW_HASKELL__ < 709 import Data.Monoid (Monoid(..)) #endif import GHC.Exts (build) import Prelude hiding (filter, foldr, map, null) import qualified Data.Foldable as Foldable import qualified Data.HashMap.Lazy as H import qualified Data.List as List import Data.Typeable (Typeable) import Text.Read #if __GLASGOW_HASKELL__ >= 708 import qualified GHC.Exts as Exts #endif -- | A set of values. A set cannot contain duplicate values. newtype HashSet a = HashSet { asMap :: HashMap a () } deriving (Typeable) #if __GLASGOW_HASKELL__ >= 708 type role HashSet nominal #endif instance (NFData a) => NFData (HashSet a) where rnf = rnf . asMap {-# INLINE rnf #-} instance (Hashable a, Eq a) => Eq (HashSet a) where -- This performs two passes over the tree. a == b = foldr f True b && size a == size b where f i = (&& i `member` a) {-# INLINE (==) #-} instance Foldable.Foldable HashSet where foldr = Data.HashSet.foldr {-# INLINE foldr #-} #if __GLASGOW_HASKELL__ >= 711 instance (Hashable a, Eq a) => Semigroup (HashSet a) where (<>) = union {-# INLINE (<>) #-} #endif instance (Hashable a, Eq a) => Monoid (HashSet a) where mempty = empty {-# INLINE mempty #-} #if __GLASGOW_HASKELL__ >= 711 mappend = (<>) #else mappend = union #endif {-# INLINE mappend #-} instance (Eq a, Hashable a, Read a) => Read (HashSet a) where readPrec = parens $ prec 10 $ do Ident "fromList" <- lexP xs <- readPrec return (fromList xs) readListPrec = readListPrecDefault instance (Show a) => Show (HashSet a) where showsPrec d m = showParen (d > 10) $ showString "fromList " . shows (toList m) instance (Data a, Eq a, Hashable a) => Data (HashSet a) where gfoldl f z m = z fromList `f` toList m toConstr _ = fromListConstr gunfold k z c = case constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" dataTypeOf _ = hashSetDataType dataCast1 f = gcast1 f instance (Hashable a) => Hashable (HashSet a) where hashWithSalt salt = hashWithSalt salt . asMap fromListConstr :: Constr fromListConstr = mkConstr hashSetDataType "fromList" [] Prefix hashSetDataType :: DataType hashSetDataType = mkDataType "Data.HashSet" [fromListConstr] -- | /O(1)/ Construct an empty set. empty :: HashSet a empty = HashSet H.empty -- | /O(1)/ Construct a set with a single element. singleton :: Hashable a => a -> HashSet a singleton a = HashSet (H.singleton a ()) {-# INLINABLE singleton #-} -- | /O(1)/ Convert to the equivalent 'HashMap'. toMap :: HashSet a -> HashMap a () toMap = asMap -- | /O(1)/ Convert from the equivalent 'HashMap'. fromMap :: HashMap a () -> HashSet a fromMap = HashSet -- | /O(n+m)/ Construct a set containing all elements from both sets. -- -- To obtain good performance, the smaller set must be presented as -- the first argument. union :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a union s1 s2 = HashSet $ H.union (asMap s1) (asMap s2) {-# INLINE union #-} -- TODO: Figure out the time complexity of 'unions'. -- | Construct a set containing all elements from a list of sets. unions :: (Eq a, Hashable a) => [HashSet a] -> HashSet a unions = List.foldl' union empty {-# INLINE unions #-} -- | /O(1)/ Return 'True' if this set is empty, 'False' otherwise. null :: HashSet a -> Bool null = H.null . asMap {-# INLINE null #-} -- | /O(n)/ Return the number of elements in this set. size :: HashSet a -> Int size = H.size . asMap {-# INLINE size #-} -- | /O(min(n,W))/ Return 'True' if the given value is present in this -- set, 'False' otherwise. member :: (Eq a, Hashable a) => a -> HashSet a -> Bool member a s = case H.lookup a (asMap s) of Just _ -> True _ -> False {-# INLINABLE member #-} -- | /O(min(n,W))/ Add the specified value to this set. insert :: (Eq a, Hashable a) => a -> HashSet a -> HashSet a insert a = HashSet . H.insert a () . asMap {-# INLINABLE insert #-} -- | /O(min(n,W))/ Remove the specified value from this set if -- present. delete :: (Eq a, Hashable a) => a -> HashSet a -> HashSet a delete a = HashSet . H.delete a . asMap {-# INLINABLE delete #-} -- | /O(n)/ Transform this set by applying a function to every value. -- The resulting set may be smaller than the source. map :: (Hashable b, Eq b) => (a -> b) -> HashSet a -> HashSet b map f = fromList . List.map f . toList {-# INLINE map #-} -- | /O(n)/ Difference of two sets. Return elements of the first set -- not existing in the second. difference :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a difference (HashSet a) (HashSet b) = HashSet (H.difference a b) {-# INLINABLE difference #-} -- | /O(n)/ Intersection of two sets. Return elements present in both -- the first set and the second. intersection :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a intersection (HashSet a) (HashSet b) = HashSet (H.intersection a b) {-# INLINABLE intersection #-} -- | /O(n)/ Reduce this set by applying a binary operator to all -- elements, using the given starting value (typically the -- left-identity of the operator). Each application of the operator -- is evaluated before before using the result in the next -- application. This function is strict in the starting value. foldl' :: (a -> b -> a) -> a -> HashSet b -> a foldl' f z0 = H.foldlWithKey' g z0 . asMap where g z k _ = f z k {-# INLINE foldl' #-} -- | /O(n)/ Reduce this set by applying a binary operator to all -- elements, using the given starting value (typically the -- right-identity of the operator). foldr :: (b -> a -> a) -> a -> HashSet b -> a foldr f z0 = foldrWithKey g z0 . asMap where g k _ z = f k z {-# INLINE foldr #-} -- | /O(n)/ Filter this set by retaining only elements satisfying a -- predicate. filter :: (a -> Bool) -> HashSet a -> HashSet a filter p = HashSet . H.filterWithKey q . asMap where q k _ = p k {-# INLINE filter #-} -- | /O(n)/ Return a list of this set's elements. The list is -- produced lazily. toList :: HashSet a -> [a] toList t = build (\ c z -> foldrWithKey ((const .) c) z (asMap t)) {-# INLINE toList #-} -- | /O(n*min(W, n))/ Construct a set from a list of elements. fromList :: (Eq a, Hashable a) => [a] -> HashSet a fromList = HashSet . List.foldl' (\ m k -> H.insert k () m) H.empty {-# INLINE fromList #-} #if __GLASGOW_HASKELL__ >= 708 instance (Eq a, Hashable a) => Exts.IsList (HashSet a) where type Item (HashSet a) = a fromList = fromList toList = toList #endif unordered-containers-0.2.7.1/Data/HashMap/0000755000000000000000000000000012726130613016372 5ustar0000000000000000unordered-containers-0.2.7.1/Data/HashMap/PopCount.hs0000644000000000000000000000064312726130613020500 0ustar0000000000000000{-# 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)) #endifunordered-containers-0.2.7.1/Data/HashMap/Array.hs0000644000000000000000000003154112726130613020010 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples #-} {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} -- | Zero based arrays. -- -- Note that no bounds checking are performed. module Data.HashMap.Array ( Array , MArray -- * Creation , new , new_ , singleton , singletonM , pair -- * Basic interface , length , lengthM , read , write , index , indexM , update , updateWith' , unsafeUpdateM , insert , insertM , delete , unsafeFreeze , unsafeThaw , run , run2 , copy , copyM -- * Folds , foldl' , foldr , thaw , map , map' , traverse , filter , toList ) where import qualified Data.Traversable as Traversable #if __GLASGOW_HASKELL__ < 709 import Control.Applicative (Applicative) #endif import Control.DeepSeq -- GHC 7.7 exports toList/fromList from GHC.Exts -- In order to avoid warnings on previous GHC versions, we provide -- an explicit import list instead of only hiding the offending symbols import GHC.Exts (Array#, Int(..), newArray#, readArray#, writeArray#, indexArray#, unsafeFreezeArray#, unsafeThawArray#, MutableArray#) import GHC.ST (ST(..)) #if __GLASGOW_HASKELL__ >= 709 import Prelude hiding (filter, foldr, length, map, read, traverse) #else import Prelude hiding (filter, foldr, length, map, read) #endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Exts (sizeofArray#, copyArray#, thawArray#, sizeofMutableArray#, copyMutableArray#) #endif #if defined(ASSERTS) import qualified Prelude #endif import Data.HashMap.Unsafe (runST) ------------------------------------------------------------------------ #if defined(ASSERTS) -- This fugly hack is brought by GHC's apparent reluctance to deal -- with MagicHash and UnboxedTuples when inferring types. Eek! # define CHECK_BOUNDS(_func_,_len_,_k_) \ if (_k_) < 0 || (_k_) >= (_len_) then error ("Data.HashMap.Array." ++ (_func_) ++ ": bounds error, offset " ++ show (_k_) ++ ", length " ++ show (_len_)) else # define CHECK_OP(_func_,_op_,_lhs_,_rhs_) \ if not ((_lhs_) _op_ (_rhs_)) then error ("Data.HashMap.Array." ++ (_func_) ++ ": Check failed: _lhs_ _op_ _rhs_ (" ++ show (_lhs_) ++ " vs. " ++ show (_rhs_) ++ ")") else # define CHECK_GT(_func_,_lhs_,_rhs_) CHECK_OP(_func_,>,_lhs_,_rhs_) # define CHECK_LE(_func_,_lhs_,_rhs_) CHECK_OP(_func_,<=,_lhs_,_rhs_) # define CHECK_EQ(_func_,_lhs_,_rhs_) CHECK_OP(_func_,==,_lhs_,_rhs_) #else # define CHECK_BOUNDS(_func_,_len_,_k_) # define CHECK_OP(_func_,_op_,_lhs_,_rhs_) # define CHECK_GT(_func_,_lhs_,_rhs_) # define CHECK_LE(_func_,_lhs_,_rhs_) # define CHECK_EQ(_func_,_lhs_,_rhs_) #endif data Array a = Array { unArray :: !(Array# a) #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 (singletonM x) {-# INLINE singleton #-} singletonM :: a -> ST s (Array a) singletonM x = new 1 x >>= unsafeFreeze {-# INLINE singletonM #-} pair :: a -> a -> Array a pair x y = run $ do ary <- new 2 x write ary 1 y return ary {-# INLINE pair #-} read :: MArray s a -> Int -> ST s a read ary _i@(I# i#) = ST $ \ s -> CHECK_BOUNDS("read", lengthM ary, _i) readArray# (unMArray ary) i# s {-# INLINE read #-} write :: MArray s a -> Int -> a -> ST s () write ary _i@(I# i#) b = ST $ \ s -> CHECK_BOUNDS("write", lengthM ary, _i) case writeArray# (unMArray ary) i# b s of s' -> (# s' , () #) {-# INLINE write #-} index :: Array a -> Int -> a index ary _i@(I# i#) = CHECK_BOUNDS("index", length ary, _i) case indexArray# (unArray ary) i# of (# b #) -> b {-# INLINE index #-} indexM :: Array a -> Int -> ST s a indexM ary _i@(I# i#) = CHECK_BOUNDS("indexM", length ary, _i) case indexArray# (unArray ary) i# of (# b #) -> return b {-# INLINE indexM #-} unsafeFreeze :: MArray s a -> ST s (Array a) unsafeFreeze mary = ST $ \s -> case unsafeFreezeArray# (unMArray mary) s of (# s', ary #) -> (# s', array ary (lengthM mary) #) {-# INLINE unsafeFreeze #-} unsafeThaw :: Array a -> ST s (MArray s a) unsafeThaw ary = ST $ \s -> case unsafeThawArray# (unArray ary) s of (# s', mary #) -> (# s', marray mary (length ary) #) {-# INLINE unsafeThaw #-} run :: (forall s . ST s (MArray s e)) -> Array e run act = runST $ act >>= unsafeFreeze {-# INLINE run #-} run2 :: (forall s. ST s (MArray s e, a)) -> (Array e, a) run2 k = runST (do (marr,b) <- k arr <- unsafeFreeze marr return (arr,b)) -- | Unsafely copy the elements of an array. Array bounds are not checked. copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s () #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 <- indexM 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 <- read 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 (insertM ary idx b) {-# INLINE insert #-} -- | /O(n)/ Insert an element at the given position in this array, -- increasing its size by one. insertM :: Array e -> Int -> e -> ST s (Array e) insertM ary idx b = CHECK_BOUNDS("insertM", count + 1, idx) do mary <- new_ (count+1) copy ary 0 mary 0 idx write mary idx b copy ary idx mary (idx+1) (count-idx) unsafeFreeze mary where !count = length ary {-# INLINE insertM #-} -- | /O(n)/ Update the element at the given position in this array. update :: Array e -> Int -> e -> Array e update ary idx b = runST (updateM ary idx b) {-# INLINE update #-} -- | /O(n)/ Update the element at the given position in this array. updateM :: Array e -> Int -> e -> ST s (Array e) updateM ary idx b = CHECK_BOUNDS("updateM", count, idx) do mary <- thaw ary 0 count write mary idx b unsafeFreeze mary where !count = length ary {-# INLINE updateM #-} -- | /O(n)/ Update the element at the given positio in this array, by -- applying a function to it. Evaluates the element to WHNF before -- inserting it into the array. updateWith' :: Array e -> Int -> (e -> e) -> Array e updateWith' ary idx f = update ary idx $! f (index ary idx) {-# INLINE updateWith' #-} -- | /O(1)/ Update the element at the given position in this array, -- without copying. unsafeUpdateM :: Array e -> Int -> e -> ST s () unsafeUpdateM ary idx b = CHECK_BOUNDS("unsafeUpdateM", length ary, idx) do mary <- unsafeThaw ary write mary idx b _ <- unsafeFreeze mary return () {-# INLINE unsafeUpdateM #-} foldl' :: (b -> a -> b) -> b -> Array a -> b foldl' f = \ z0 ary0 -> go ary0 (length ary0) 0 z0 where go ary n i !z | i >= n = z | otherwise = 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 (deleteM ary idx) {-# INLINE delete #-} -- | /O(n)/ Delete an element at the given position in this array, -- decreasing its size by one. deleteM :: Array e -> Int -> ST s (Array e) deleteM ary idx = do CHECK_BOUNDS("deleteM", count, idx) do mary <- new_ (count-1) copy ary 0 mary 0 idx copy ary (idx+1) mary idx (count-(idx+1)) unsafeFreeze mary where !count = length ary {-# INLINE deleteM #-} map :: (a -> b) -> Array a -> Array b map f = \ ary -> let !n = length ary in run $ do mary <- new_ n go ary mary 0 n where go ary mary i n | i >= n = return mary | otherwise = do 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 = CHECK_EQ("fromList", n, Prelude.length xs0) run $ do mary <- new_ n go xs0 mary 0 where go [] !mary !_ = return mary go (x:xs) mary i = do write mary i x go xs mary (i+1) toList :: Array a -> [a] toList = foldr (:) [] 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 #-} unordered-containers-0.2.7.1/Data/HashMap/Lazy.hs0000644000000000000000000000400212726130613017641 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------ -- | -- Module : Data.HashMap.Lazy -- Copyright : 2010-2012 Johan Tibell -- License : BSD-style -- Maintainer : johan.tibell@gmail.com -- Stability : provisional -- Portability : portable -- -- A map from /hashable/ keys to values. A map cannot contain -- duplicate keys; each key can map to at most one value. A 'HashMap' -- makes no guarantees as to the order of its elements. -- -- The implementation is based on /hash array mapped tries/. A -- 'HashMap' is often faster than other tree-based set types, -- especially when key comparison is expensive, as in the case of -- strings. -- -- Many operations have a average-case complexity of /O(log n)/. The -- implementation uses a large base (i.e. 16) so in practice these -- operations are constant time. module Data.HashMap.Lazy ( -- * Strictness properties -- $strictness HashMap -- * Construction , empty , singleton -- * Basic interface , HM.null , size , member , HM.lookup , lookupDefault , (!) , insert , insertWith , delete , adjust , update , alter -- * Combine -- ** Union , union , unionWith , unionWithKey , unions -- * Transformations , HM.map , mapWithKey , traverseWithKey -- * Difference and intersection , difference , intersection , intersectionWith , intersectionWithKey -- * Folds , foldl' , foldlWithKey' , HM.foldr , foldrWithKey -- * Filter , HM.filter , filterWithKey , mapMaybe , mapMaybeWithKey -- * Conversions , keys , elems -- ** Lists , toList , fromList , fromListWith ) where import Data.HashMap.Base as HM -- $strictness -- -- This module satisfies the following strictness property: -- -- * Key arguments are evaluated to WHNF unordered-containers-0.2.7.1/Data/HashMap/Unsafe.hs0000644000000000000000000000162612726130613020154 0ustar0000000000000000{-# LANGUAGE MagicHash, Rank2Types, UnboxedTuples #-} -- | This module exports a workaround for this bug: -- -- http://hackage.haskell.org/trac/ghc/ticket/5916 -- -- Please read the comments in ghc/libraries/base/GHC/ST.lhs to -- understand what's going on here. -- -- Code that uses this module should be compiled with -fno-full-laziness module Data.HashMap.Unsafe ( runST ) where import GHC.Base (realWorld#) import qualified GHC.ST as ST -- | Return the value computed by a state transformer computation. -- The @forall@ ensures that the internal state used by the 'ST' -- computation is inaccessible to the rest of the program. runST :: (forall s. ST.ST s a) -> a runST st = runSTRep (case st of { ST.ST st_rep -> st_rep }) {-# INLINE runST #-} runSTRep :: (forall s. ST.STRep s a) -> a runSTRep st_rep = case st_rep realWorld# of (# _, r #) -> r {-# INLINE [0] runSTRep #-} unordered-containers-0.2.7.1/Data/HashMap/UnsafeShift.hs0000644000000000000000000000066512726130613021154 0ustar0000000000000000{-# 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 #-} unordered-containers-0.2.7.1/Data/HashMap/Strict.hs0000644000000000000000000004300412726130613020177 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP, PatternGuards #-} #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif ------------------------------------------------------------------------ -- | -- Module : Data.HashMap.Strict -- Copyright : 2010-2012 Johan Tibell -- License : BSD-style -- Maintainer : johan.tibell@gmail.com -- Stability : provisional -- Portability : portable -- -- A map from /hashable/ keys to values. A map cannot contain -- duplicate keys; each key can map to at most one value. A 'HashMap' -- makes no guarantees as to the order of its elements. -- -- The implementation is based on /hash array mapped tries/. A -- 'HashMap' is often faster than other tree-based set types, -- especially when key comparison is expensive, as in the case of -- strings. -- -- Many operations have a average-case complexity of /O(log n)/. The -- implementation uses a large base (i.e. 16) so in practice these -- operations are constant time. module Data.HashMap.Strict ( -- * Strictness properties -- $strictness HashMap -- * Construction , empty , singleton -- * Basic interface , HM.null , size , HM.member , HM.lookup , lookupDefault , (!) , insert , insertWith , delete , adjust , update , alter -- * Combine -- ** Union , union , unionWith , unionWithKey , unions -- * Transformations , map , mapWithKey , traverseWithKey -- * Difference and intersection , difference , intersection , intersectionWith , intersectionWithKey -- * Folds , foldl' , foldlWithKey' , HM.foldr , foldrWithKey -- * Filter , HM.filter , filterWithKey , mapMaybe , mapMaybeWithKey -- * Conversions , keys , elems -- ** Lists , toList , fromList , fromListWith ) where import Data.Bits ((.&.), (.|.)) import qualified Data.List as L import Data.Hashable (Hashable) import Prelude hiding (map) import qualified Data.HashMap.Array as A import qualified Data.HashMap.Base as HM import Data.HashMap.Base hiding ( alter, adjust, fromList, fromListWith, insert, insertWith, intersectionWith, intersectionWithKey, map, mapWithKey, mapMaybe, mapMaybeWithKey, singleton, update, unionWith, unionWithKey) import Data.HashMap.Unsafe (runST) -- $strictness -- -- This module satisfies the following strictness properties: -- -- 1. Key arguments are evaluated to WHNF; -- -- 2. Keys and values are evaluated to WHNF before they are stored in -- the map. ------------------------------------------------------------------------ -- * Construction -- | /O(1)/ Construct a map with a single element. singleton :: (Hashable k) => k -> v -> HashMap k v singleton k !v = HM.singleton k v ------------------------------------------------------------------------ -- * Basic interface -- | /O(log n)/ Associate the specified value with the specified -- key in this map. If this map previously contained a mapping for -- the key, the old value is replaced. insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v insert k !v = HM.insert k v {-# INLINABLE insert #-} -- | /O(log n)/ Associate the value with the key in this map. If -- this map previously contained a mapping for the key, the old value -- is replaced by the result of applying the given function to the new -- and old value. Example: -- -- > insertWith f k v map -- > where f new old = new + old insertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v insertWith f k0 v0 m0 = go h0 k0 v0 0 m0 where h0 = hash k0 go !h !k x !_ Empty = leaf h k x go h k x s (Leaf hy l@(L ky y)) | hy == h = if ky == k then leaf h k (f x y) else x `seq` (collision h l (L k x)) | otherwise = x `seq` runST (two s h k x hy ky y) go h k x s (BitmapIndexed b ary) | b .&. m == 0 = let ary' = A.insert ary i $! leaf h k x in bitmapIndexedOrFull (b .|. m) ary' | otherwise = let st = A.index ary i st' = go h k x (s+bitsPerSubkey) st ary' = A.update ary i $! st' in BitmapIndexed b ary' where m = mask h s i = sparseIndex b m go h k x s (Full ary) = let st = A.index ary i st' = go h k x (s+bitsPerSubkey) st ary' = update16 ary i $! st' in Full ary' where i = index h s go h k x s t@(Collision hy v) | h == hy = Collision h (updateOrSnocWith f k x v) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) {-# INLINABLE insertWith #-} -- | In-place update version of insertWith unsafeInsertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v unsafeInsertWith f k0 v0 m0 = runST (go h0 k0 v0 0 m0) where h0 = hash k0 go !h !k x !_ Empty = return $! leaf h k x go h k x s (Leaf hy l@(L ky y)) | hy == h = if ky == k then return $! leaf h k (f x y) else do let l' = x `seq` (L k x) return $! collision h l l' | otherwise = two s h k x hy ky y go h k x s t@(BitmapIndexed b ary) | b .&. m == 0 = do ary' <- A.insertM ary i $! leaf h k x return $! bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i st' <- go h k x (s+bitsPerSubkey) st A.unsafeUpdateM ary i st' return t where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = do st <- A.indexM ary i st' <- go h k x (s+bitsPerSubkey) st A.unsafeUpdateM ary i st' return t where i = index h s go h k x s t@(Collision hy v) | h == hy = return $! Collision h (updateOrSnocWith f k x v) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) {-# INLINABLE unsafeInsertWith #-} -- | /O(log n)/ Adjust the value tied to a given key in this map only -- if it is present. Otherwise, leave the map alone. adjust :: (Eq k, Hashable k) => (v -> v) -> k -> HashMap k v -> HashMap k v adjust f k0 m0 = go h0 k0 0 m0 where h0 = hash k0 go !_ !_ !_ Empty = Empty go h k _ t@(Leaf hy (L ky y)) | hy == h && ky == k = leaf h k (f y) | otherwise = t go h k s t@(BitmapIndexed b ary) | b .&. m == 0 = t | otherwise = let st = A.index ary i st' = go h k (s+bitsPerSubkey) st ary' = A.update ary i $! st' in BitmapIndexed b ary' where m = mask h s i = sparseIndex b m go h k s (Full ary) = let i = index h s st = A.index ary i st' = go h k (s+bitsPerSubkey) st ary' = update16 ary i $! st' in Full ary' go h k _ t@(Collision hy v) | h == hy = Collision h (updateWith f k v) | otherwise = t {-# INLINABLE adjust #-} -- | /O(log n)/ The expression (@'update' f k map@) updates the value @x@ at @k@, -- (if it is in the map). If (f k x) is @'Nothing', the element is deleted. -- If it is (@'Just' y), the key k is bound to the new value y. update :: (Eq k, Hashable k) => (a -> Maybe a) -> k -> HashMap k a -> HashMap k a update f = alter (>>= f) {-# INLINABLE update #-} -- | /O(log n)/ The expression (@'alter' f k map@) alters the value @x@ at @k@, or -- absence thereof. @alter@ can be used to insert, delete, or update a value in a -- map. In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. alter :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v alter f k m = case f (HM.lookup k m) of Nothing -> delete k m Just v -> insert k v m {-# INLINABLE alter #-} ------------------------------------------------------------------------ -- * Combine -- | /O(n+m)/ The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the result. unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWith f = unionWithKey (const f) {-# INLINE unionWith #-} -- | /O(n+m)/ The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the result. unionWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWithKey f = go 0 where -- empty vs. anything go !_ t1 Empty = t1 go _ Empty t2 = t2 -- leaf vs. leaf go s t1@(Leaf h1 l1@(L k1 v1)) t2@(Leaf h2 l2@(L k2 v2)) | h1 == h2 = if k1 == k2 then leaf h1 k1 (f k1 v1 v2) else collision h1 l1 l2 | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Leaf h1 (L k1 v1)) t2@(Collision h2 ls2) | h1 == h2 = Collision h1 (updateOrSnocWithKey f k1 v1 ls2) | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Collision h1 ls1) t2@(Leaf h2 (L k2 v2)) | h1 == h2 = Collision h1 (updateOrSnocWithKey (flip . f) k2 v2 ls1) | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Collision h1 ls1) t2@(Collision h2 ls2) | h1 == h2 = Collision h1 (updateOrConcatWithKey f ls1 ls2) | otherwise = goDifferentHash s h1 h2 t1 t2 -- branch vs. branch go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = let b' = b1 .|. b2 ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2 in bitmapIndexedOrFull b' ary' go s (BitmapIndexed b1 ary1) (Full ary2) = let ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2 in Full ary' go s (Full ary1) (BitmapIndexed b2 ary2) = let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2 in Full ary' go s (Full ary1) (Full ary2) = let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask ary1 ary2 in Full ary' -- leaf vs. branch go s (BitmapIndexed b1 ary1) t2 | b1 .&. m2 == 0 = let ary' = A.insert ary1 i t2 b' = b1 .|. m2 in bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 in BitmapIndexed b1 ary' where h2 = leafHashCode t2 m2 = mask h2 s i = sparseIndex b1 m2 go s t1 (BitmapIndexed b2 ary2) | b2 .&. m1 == 0 = let ary' = A.insert ary2 i $! t1 b' = b2 .|. m1 in bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 in BitmapIndexed b2 ary' where h1 = leafHashCode t1 m1 = mask h1 s i = sparseIndex b2 m1 go s (Full ary1) t2 = let h2 = leafHashCode t2 i = index h2 s ary' = update16With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 in Full ary' go s t1 (Full ary2) = let h1 = leafHashCode t1 i = index h1 s ary' = update16With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 in Full ary' leafHashCode (Leaf h _) = h leafHashCode (Collision h _) = h leafHashCode _ = error "leafHashCode" goDifferentHash s h1 h2 t1 t2 | m1 == m2 = BitmapIndexed m1 (A.singleton $! go (s+bitsPerSubkey) t1 t2) | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1) where m1 = mask h1 s m2 = mask h2 s {-# INLINE unionWithKey #-} ------------------------------------------------------------------------ -- * Transformations -- | /O(n)/ Transform this map by applying a function to every value. mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2 mapWithKey f = go where go Empty = Empty go (Leaf h (L k v)) = leaf h k (f k v) go (BitmapIndexed b ary) = BitmapIndexed b $ A.map' go ary go (Full ary) = Full $ A.map' go ary go (Collision h ary) = Collision h $ A.map' (\ (L k v) -> let !v' = f k v in L k v') ary {-# INLINE mapWithKey #-} -- | /O(n)/ Transform this map by applying a function to every value. map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2 map f = mapWithKey (const f) {-# INLINE map #-} ------------------------------------------------------------------------ -- * Filter -- | /O(n)/ Transform this map by applying a function to every value -- and retaining only some of them. mapMaybeWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 mapMaybeWithKey f = filterMapAux onLeaf onColl where onLeaf (Leaf h (L k v)) | Just v' <- f k v = Just (leaf h k v') onLeaf _ = Nothing onColl (L k v) | Just v' <- f k v = Just (L k v') | otherwise = Nothing {-# INLINE mapMaybeWithKey #-} -- | /O(n)/ Transform this map by applying a function to every value -- and retaining only some of them. mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 mapMaybe f = mapMaybeWithKey (const f) {-# INLINE mapMaybe #-} -- TODO: Should we add a strict traverseWithKey? ------------------------------------------------------------------------ -- * Difference and intersection -- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 intersectionWith f a b = foldlWithKey' go empty a where go m k v = case HM.lookup k b of Just w -> insert k (f v w) m _ -> m {-# INLINABLE intersectionWith #-} -- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. intersectionWithKey :: (Eq k, Hashable k) => (k -> v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 intersectionWithKey f a b = foldlWithKey' go empty a where go m k v = case HM.lookup k b of Just w -> insert k (f k v w) m _ -> m {-# INLINABLE intersectionWithKey #-} ------------------------------------------------------------------------ -- ** Lists -- | /O(n*log n)/ Construct a map with the supplied mappings. If the -- list contains duplicate mappings, the later mappings take -- precedence. fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v fromList = L.foldl' (\ m (k, !v) -> HM.unsafeInsert k v m) empty {-# INLINABLE fromList #-} -- | /O(n*log n)/ Construct a map from a list of elements. Uses -- the provided function f to merge duplicate entries (f newVal oldVal). -- -- For example: -- -- > fromListWith (+) [ (x, 1) | x <- xs ] -- -- will create a map with number of occurrences of each element in xs. -- -- > fromListWith (++) [ (k, [v]) | (k, v) <- xs ] -- -- will group all values by their keys in a list 'xs :: [(k, v)]' and -- return a 'HashMap k [v]'. fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v fromListWith f = L.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty {-# INLINE fromListWith #-} ------------------------------------------------------------------------ -- Array operations updateWith :: Eq k => (v -> v) -> k -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateWith f k0 ary0 = go k0 ary0 0 (A.length ary0) where go !k !ary !i !n | i >= n = ary | otherwise = case A.index ary i of (L kx y) | k == kx -> let !v' = f y in A.update ary i (L k v') | otherwise -> go k ary (i+1) n {-# INLINABLE updateWith #-} -- | Append the given key and value to the array. If the key is -- already present, instead update the value of the key by applying -- the given function to the new and old value (in that order). The -- value is always evaluated to WHNF before being inserted into the -- array. updateOrSnocWith :: Eq k => (v -> v -> v) -> k -> v -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateOrSnocWith f = updateOrSnocWithKey (const f) {-# INLINABLE updateOrSnocWith #-} -- | Append the given key and value to the array. If the key is -- already present, instead update the value of the key by applying -- the given function to the new and old value (in that order). The -- value is always evaluated to WHNF before being inserted into the -- array. updateOrSnocWithKey :: Eq k => (k -> v -> v -> v) -> k -> v -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0) where go !k v !ary !i !n | i >= n = A.run $ do -- Not found, append to the end. mary <- A.new_ (n + 1) A.copy ary 0 mary 0 n let !l = v `seq` (L k v) A.write mary n l return mary | otherwise = case A.index ary i of (L kx y) | k == kx -> let !v' = f k v y in A.update ary i (L k v') | otherwise -> go k v ary (i+1) n {-# INLINABLE updateOrSnocWithKey #-} ------------------------------------------------------------------------ -- Smart constructors -- -- These constructors make sure the value is in WHNF before it's -- inserted into the constructor. leaf :: Hash -> k -> v -> HashMap k v leaf h k !v = Leaf h (L k v) {-# INLINE leaf #-} unordered-containers-0.2.7.1/Data/HashMap/Base.hs0000644000000000000000000012744312726130613017613 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternGuards #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TypeFamilies #-} #endif {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} module Data.HashMap.Base ( HashMap(..) , Leaf(..) -- * Construction , empty , singleton -- * Basic interface , null , size , member , lookup , lookupDefault , (!) , insert , insertWith , unsafeInsert , delete , adjust , update , alter -- * Combine -- ** Union , union , unionWith , unionWithKey , unions -- * Transformations , map , mapWithKey , traverseWithKey -- * Difference and intersection , difference , intersection , intersectionWith , intersectionWithKey -- * Folds , foldl' , foldlWithKey' , foldr , foldrWithKey -- * Filter , mapMaybe , mapMaybeWithKey , filter , filterWithKey -- * Conversions , keys , elems -- ** Lists , toList , fromList , fromListWith -- Internals used by the strict version , Hash , Bitmap , bitmapIndexedOrFull , collision , hash , mask , index , bitsPerSubkey , fullNodeMask , sparseIndex , two , unionArrayBy , update16 , update16M , update16With' , updateOrConcatWith , updateOrConcatWithKey , filterMapAux ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), Applicative(pure)) import Data.Monoid (Monoid(mempty, mappend)) import Data.Traversable (Traversable(..)) import Data.Word (Word) #endif #if __GLASGOW_HASKELL__ >= 711 import Data.Semigroup (Semigroup((<>))) #endif import Control.DeepSeq (NFData(rnf)) import Control.Monad.ST (ST) import Data.Bits ((.&.), (.|.), complement) import Data.Data hiding (Typeable) import qualified Data.Foldable as Foldable import qualified Data.List as L import GHC.Exts ((==#), build, reallyUnsafePtrEquality#) import Prelude hiding (filter, foldr, lookup, map, null, pred) import Text.Read hiding (step) import qualified Data.HashMap.Array as A import qualified Data.Hashable as H import Data.Hashable (Hashable) import Data.HashMap.PopCount (popCount) import Data.HashMap.Unsafe (runST) import Data.HashMap.UnsafeShift (unsafeShiftL, unsafeShiftR) import Data.Typeable (Typeable) #if __GLASGOW_HASKELL__ >= 707 import GHC.Exts (isTrue#) #endif #if __GLASGOW_HASKELL__ >= 708 import qualified GHC.Exts as Exts #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 deriving (Eq) instance (NFData k, NFData v) => NFData (Leaf k v) where rnf (L k v) = rnf k `seq` rnf v -- Invariant: The length of the 1st argument to 'Full' is -- 2^bitsPerSubkey -- | A map from keys to values. A map cannot contain duplicate keys; -- each key can map to at most one value. data HashMap k v = Empty | BitmapIndexed !Bitmap !(A.Array (HashMap k v)) | Leaf !Hash !(Leaf k v) | Full !(A.Array (HashMap k v)) | Collision !Hash !(A.Array (Leaf k v)) deriving (Typeable) #if __GLASGOW_HASKELL__ >= 708 type role HashMap nominal representational #endif 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) #if __GLASGOW_HASKELL__ >= 711 instance (Eq k, Hashable k) => Semigroup (HashMap k v) where (<>) = union {-# INLINE (<>) #-} #endif instance (Eq k, Hashable k) => Monoid (HashMap k v) where mempty = empty {-# INLINE mempty #-} #if __GLASGOW_HASKELL__ >= 711 mappend = (<>) #else mappend = union #endif {-# INLINE mappend #-} instance (Data k, Data v, Eq k, Hashable k) => Data (HashMap k v) where gfoldl f z m = z fromList `f` toList m toConstr _ = fromListConstr gunfold k z c = case constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" dataTypeOf _ = hashMapDataType dataCast2 f = gcast2 f fromListConstr :: Constr fromListConstr = mkConstr hashMapDataType "fromList" [] Prefix hashMapDataType :: DataType hashMapDataType = mkDataType "Data.HashMap.Base.HashMap" [fromListConstr] type Hash = Word type Bitmap = Word type Shift = Int instance (Eq k, Hashable k, Read k, Read e) => Read (HashMap k e) where readPrec = parens $ prec 10 $ do Ident "fromList" <- lexP xs <- readPrec return (fromList xs) readListPrec = readListPrecDefault instance (Show k, Show v) => Show (HashMap k v) where showsPrec d m = showParen (d > 10) $ showString "fromList " . shows (toList m) instance Traversable (HashMap k) where traverse f = traverseWithKey (const f) instance (Eq k, Eq v) => Eq (HashMap k v) where (==) = equal equal :: (Eq k, Eq v) => HashMap k v -> HashMap k v -> Bool equal t1 t2 = go (toList' t1 []) (toList' t2 []) where -- If the two trees are the same, then their lists of 'Leaf's and -- 'Collision's read from left to right should be the same (modulo the -- order of elements in 'Collision'). go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) | k1 == k2 && l1 == l2 = go tl1 tl2 go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2) | k1 == k2 && A.length ary1 == A.length ary2 && L.null (A.toList ary1 L.\\ A.toList ary2) = go tl1 tl2 go [] [] = True go _ _ = False instance (Hashable k, Hashable v) => Hashable (HashMap k v) where hashWithSalt salt hm = go salt (toList' hm []) where go :: Int -> [HashMap k v] -> Int go s [] = s go s (Leaf _ l : tl) = s `hashLeafWithSalt` l `go` tl -- For collisions we hashmix hash value -- and then array of values' hashes sorted go s (Collision h a : tl) = (s `H.hashWithSalt` h) `hashCollisionWithSalt` a `go` tl go s (_ : tl) = s `go` tl hashLeafWithSalt :: Int -> Leaf k v -> Int hashLeafWithSalt s (L k v) = s `H.hashWithSalt` k `H.hashWithSalt` v hashCollisionWithSalt :: Int -> A.Array (Leaf k v) -> Int hashCollisionWithSalt s = L.foldl' H.hashWithSalt s . arrayHashesSorted arrayHashesSorted :: A.Array (Leaf k v) -> [Int] arrayHashesSorted = L.sort . L.map leafValueHash . A.toList leafValueHash :: Leaf k v -> Int leafValueHash (L _ v) = H.hash v -- Helper to get 'Leaf's and 'Collision's as a list. toList' :: HashMap k v -> [HashMap k v] -> [HashMap k v] toList' (BitmapIndexed _ ary) a = A.foldr toList' a ary toList' (Full ary) a = A.foldr toList' a ary toList' l@(Leaf _ _) a = l : a toList' c@(Collision _ _) a = c : a toList' Empty a = a -- Helper function to detect 'Leaf's and 'Collision's. isLeafOrCollision :: HashMap k v -> Bool isLeafOrCollision (Leaf _ _) = True isLeafOrCollision (Collision _ _) = True isLeafOrCollision _ = False ------------------------------------------------------------------------ -- * Construction -- | /O(1)/ Construct an empty map. empty :: HashMap k v empty = Empty -- | /O(1)/ Construct a map with a single element. singleton :: (Hashable k) => k -> v -> HashMap k v singleton k v = Leaf (hash k) (L k v) ------------------------------------------------------------------------ -- * Basic interface -- | /O(1)/ Return 'True' if this map is empty, 'False' otherwise. null :: HashMap k v -> Bool null Empty = True null _ = False -- | /O(n)/ Return the number of key-value mappings in this map. size :: HashMap k v -> Int size t = go t 0 where go Empty !n = n go (Leaf _ _) n = n + 1 go (BitmapIndexed _ ary) n = A.foldl' (flip go) n ary go (Full ary) n = A.foldl' (flip go) n ary go (Collision _ ary) n = n + A.length ary -- | /O(log n)/ Return 'True' if the specified key is present in the -- map, 'False' otherwise. member :: (Eq k, Hashable k) => k -> HashMap k a -> Bool member k m = case lookup k m of Nothing -> False Just _ -> True {-# INLINABLE member #-} -- | /O(log n)/ Return the value to which the specified key is mapped, -- or 'Nothing' if this map contains no mapping for the key. lookup :: (Eq k, Hashable k) => k -> HashMap k v -> Maybe v lookup k0 m0 = go h0 k0 0 m0 where h0 = hash k0 go !_ !_ !_ Empty = Nothing go h k _ (Leaf hx (L kx x)) | h == hx && k == kx = Just x -- TODO: Split test in two | 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 {-# INLINABLE lookup #-} -- | /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 {-# INLINABLE lookupDefault #-} -- | /O(log n)/ Return the value to which the specified key is mapped. -- Calls 'error' if this map contains no mapping for the key. (!) :: (Eq k, Hashable k) => HashMap k v -> k -> v (!) m k = case lookup k m of Just v -> v Nothing -> error "Data.HashMap.Base.(!): key not found" {-# INLINABLE (!) #-} infixl 9 ! -- | Create a 'Collision' value with two 'Leaf' values. collision :: Hash -> Leaf k v -> Leaf k v -> HashMap k v collision h e1 e2 = let v = A.run $ do mary <- A.new 2 e1 A.write mary 1 e2 return mary in Collision h v {-# INLINE collision #-} -- | Create a 'BitmapIndexed' or 'Full' node. bitmapIndexedOrFull :: Bitmap -> A.Array (HashMap k v) -> HashMap k v bitmapIndexedOrFull b ary | b == fullNodeMask = Full ary | otherwise = BitmapIndexed b ary {-# INLINE bitmapIndexedOrFull #-} -- | /O(log n)/ Associate the specified value with the specified -- key in this map. If this map previously contained a mapping for -- the key, the old value is replaced. insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v insert k0 v0 m0 = go h0 k0 v0 0 m0 where h0 = hash k0 go !h !k x !_ Empty = Leaf h (L k x) go h k x s t@(Leaf hy l@(L ky y)) | hy == h = if ky == k then if x `ptrEq` y then t else Leaf h (L k x) else collision h l (L k x) | otherwise = runST (two s h k x hy ky y) go h k x s t@(BitmapIndexed b ary) | b .&. m == 0 = let !ary' = A.insert ary i $! Leaf h (L k x) in bitmapIndexedOrFull (b .|. m) ary' | otherwise = let !st = A.index ary i !st' = go h k x (s+bitsPerSubkey) st in if st' `ptrEq` st then t else BitmapIndexed b (A.update ary i st') where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = let !st = A.index ary i !st' = go h k x (s+bitsPerSubkey) st in if st' `ptrEq` st then t else Full (update16 ary i st') where i = index h s go h k x s t@(Collision hy v) | h == hy = Collision h (updateOrSnocWith const k x v) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) {-# INLINABLE insert #-} -- | In-place update version of insert unsafeInsert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v unsafeInsert k0 v0 m0 = runST (go h0 k0 v0 0 m0) where h0 = hash k0 go !h !k x !_ Empty = return $! Leaf h (L k x) go h k x s t@(Leaf hy l@(L ky y)) | hy == h = if ky == k then if x `ptrEq` y then return t else return $! Leaf h (L k x) else return $! collision h l (L k x) | otherwise = two s h k x hy ky y go h k x s t@(BitmapIndexed b ary) | b .&. m == 0 = do ary' <- A.insertM ary i $! Leaf h (L k x) return $! bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i st' <- go h k x (s+bitsPerSubkey) st A.unsafeUpdateM ary i st' return t where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = do st <- A.indexM ary i st' <- go h k x (s+bitsPerSubkey) st A.unsafeUpdateM ary i st' return t where i = index h s go h k x s t@(Collision hy v) | h == hy = return $! Collision h (updateOrSnocWith const k x v) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) {-# INLINABLE unsafeInsert #-} -- | Create a map from two key-value pairs which hashes don't collide. 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.singletonM 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 = go h0 k0 v0 0 m0 where h0 = hash k0 go !h !k x !_ Empty = Leaf h (L k x) go h k x s (Leaf hy l@(L ky y)) | hy == h = if ky == k then Leaf h (L k (f x y)) else collision h l (L k x) | otherwise = runST (two s h k x hy ky y) go h k x s (BitmapIndexed b ary) | b .&. m == 0 = let ary' = A.insert ary i $! Leaf h (L k x) in bitmapIndexedOrFull (b .|. m) ary' | otherwise = let st = A.index ary i st' = go h k x (s+bitsPerSubkey) st ary' = A.update ary i $! st' in BitmapIndexed b ary' where m = mask h s i = sparseIndex b m go h k x s (Full ary) = let st = A.index ary i st' = go h k x (s+bitsPerSubkey) st ary' = update16 ary i $! st' in Full ary' where i = index h s go h k x s t@(Collision hy v) | h == hy = Collision h (updateOrSnocWith f k x v) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) {-# INLINABLE insertWith #-} -- | In-place update version of insertWith unsafeInsertWith :: forall k v. (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v unsafeInsertWith f k0 v0 m0 = runST (go h0 k0 v0 0 m0) where h0 = hash k0 go :: Hash -> k -> v -> Shift -> HashMap k v -> ST s (HashMap k v) go !h !k x !_ Empty = return $! Leaf h (L k x) go h k x s (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 t@(BitmapIndexed b ary) | b .&. m == 0 = do ary' <- A.insertM ary i $! Leaf h (L k x) return $! bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i st' <- go h k x (s+bitsPerSubkey) st A.unsafeUpdateM ary i st' return t where m = mask h s i = sparseIndex b m go h k x s t@(Full ary) = do st <- A.indexM ary i st' <- go h k x (s+bitsPerSubkey) st A.unsafeUpdateM ary i st' return t where i = index h s go h k x s t@(Collision hy v) | h == hy = return $! Collision h (updateOrSnocWith f k x v) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) {-# INLINABLE unsafeInsertWith #-} -- | /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 = go h0 k0 0 m0 where h0 = hash k0 go !_ !_ !_ Empty = Empty go h k _ t@(Leaf hy (L ky _)) | hy == h && ky == k = Empty | otherwise = t go h k s t@(BitmapIndexed b ary) | b .&. m == 0 = t | otherwise = let !st = A.index ary i !st' = go h k (s+bitsPerSubkey) st in if st' `ptrEq` st then t else case st' of Empty | A.length ary == 1 -> Empty | A.length ary == 2 -> case (i, A.index ary 0, A.index ary 1) of (0, _, l) | isLeafOrCollision l -> l (1, l, _) | isLeafOrCollision l -> l _ -> bIndexed | otherwise -> bIndexed where bIndexed = BitmapIndexed (b .&. complement m) (A.delete ary i) l | isLeafOrCollision l && A.length ary == 1 -> l _ -> BitmapIndexed b (A.update ary i st') where m = mask h s i = sparseIndex b m go h k s t@(Full ary) = let !st = A.index ary i !st' = go h k (s+bitsPerSubkey) st in if st' `ptrEq` st then t else case st' of Empty -> let ary' = A.delete ary i bm = fullNodeMask .&. complement (1 `unsafeShiftL` i) in BitmapIndexed bm ary' _ -> Full (A.update ary i st') where i = index h s go h k _ t@(Collision hy v) | h == hy = case indexOf k v of Just i | A.length v == 2 -> if i == 0 then Leaf h (A.index v 1) else Leaf h (A.index v 0) | otherwise -> Collision h (A.delete v i) Nothing -> t | otherwise = t {-# INLINABLE delete #-} -- | /O(log n)/ Adjust the value tied to a given key in this map only -- if it is present. Otherwise, leave the map alone. adjust :: (Eq k, Hashable k) => (v -> v) -> k -> HashMap k v -> HashMap k v adjust f k0 m0 = go h0 k0 0 m0 where h0 = hash k0 go !_ !_ !_ Empty = Empty go h k _ t@(Leaf hy (L ky y)) | hy == h && ky == k = Leaf h (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 {-# INLINABLE adjust #-} -- | /O(log n)/ The expression (@'update' f k map@) updates the value @x@ at @k@, -- (if it is in the map). If (f k x) is @'Nothing', the element is deleted. -- If it is (@'Just' y), the key k is bound to the new value y. update :: (Eq k, Hashable k) => (a -> Maybe a) -> k -> HashMap k a -> HashMap k a update f = alter (>>= f) {-# INLINABLE update #-} -- | /O(log n)/ The expression (@'alter' f k map@) alters the value @x@ at @k@, or -- absence thereof. @alter@ can be used to insert, delete, or update a value in a -- map. In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. alter :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v alter f k m = case f (lookup k m) of Nothing -> delete k m Just v -> insert k v m {-# INLINABLE alter #-} ------------------------------------------------------------------------ -- * 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 {-# INLINABLE union #-} -- | /O(n+m)/ The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the -- result. unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWith f = unionWithKey (const f) {-# INLINE unionWith #-} -- | /O(n+m)/ The union of two maps. If a key occurs in both maps, -- the provided function (first argument) will be used to compute the -- result. unionWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v unionWithKey f = go 0 where -- empty vs. anything go !_ t1 Empty = t1 go _ Empty t2 = t2 -- leaf vs. leaf go s t1@(Leaf h1 l1@(L k1 v1)) t2@(Leaf h2 l2@(L k2 v2)) | h1 == h2 = if k1 == k2 then Leaf h1 (L k1 (f k1 v1 v2)) else collision h1 l1 l2 | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Leaf h1 (L k1 v1)) t2@(Collision h2 ls2) | h1 == h2 = Collision h1 (updateOrSnocWithKey f k1 v1 ls2) | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Collision h1 ls1) t2@(Leaf h2 (L k2 v2)) | h1 == h2 = Collision h1 (updateOrSnocWithKey (flip . f) k2 v2 ls1) | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Collision h1 ls1) t2@(Collision h2 ls2) | h1 == h2 = Collision h1 (updateOrConcatWithKey f ls1 ls2) | otherwise = goDifferentHash s h1 h2 t1 t2 -- branch vs. branch go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = let b' = b1 .|. b2 ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2 in bitmapIndexedOrFull b' ary' go s (BitmapIndexed b1 ary1) (Full ary2) = let ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2 in Full ary' go s (Full ary1) (BitmapIndexed b2 ary2) = let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2 in Full ary' go s (Full ary1) (Full ary2) = let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask ary1 ary2 in Full ary' -- leaf vs. branch go s (BitmapIndexed b1 ary1) t2 | b1 .&. m2 == 0 = let ary' = A.insert ary1 i t2 b' = b1 .|. m2 in bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 in BitmapIndexed b1 ary' where h2 = leafHashCode t2 m2 = mask h2 s i = sparseIndex b1 m2 go s t1 (BitmapIndexed b2 ary2) | b2 .&. m1 == 0 = let ary' = A.insert ary2 i $! t1 b' = b2 .|. m1 in bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 in BitmapIndexed b2 ary' where h1 = leafHashCode t1 m1 = mask h1 s i = sparseIndex b2 m1 go s (Full ary1) t2 = let h2 = leafHashCode t2 i = index h2 s ary' = update16With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 in Full ary' go s t1 (Full ary2) = let h1 = leafHashCode t1 i = index h1 s ary' = update16With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 in Full ary' leafHashCode (Leaf h _) = h leafHashCode (Collision h _) = h leafHashCode _ = error "leafHashCode" goDifferentHash s h1 h2 t1 t2 | m1 == m2 = BitmapIndexed m1 (A.singleton $! go (s+bitsPerSubkey) t1 t2) | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) | otherwise = BitmapIndexed (m1 .|. m2) (A.pair t2 t1) where m1 = mask h1 s m2 = mask h2 s {-# INLINE unionWithKey #-} -- | Strict in the result of @f@. unionArrayBy :: (a -> a -> a) -> Bitmap -> Bitmap -> A.Array a -> A.Array a -> A.Array a unionArrayBy f b1 b2 ary1 ary2 = A.run $ do let b' = b1 .|. b2 mary <- A.new_ (popCount b') -- iterate over nonzero bits of b1 .|. b2 -- it would be nice if we could shift m by more than 1 each time let ba = b1 .&. b2 go !i !i1 !i2 !m | m > b' = return () | b' .&. m == 0 = go i i1 i2 (m `unsafeShiftL` 1) | ba .&. m /= 0 = do A.write mary i $! f (A.index ary1 i1) (A.index ary2 i2) go (i+1) (i1+1) (i2+1) (m `unsafeShiftL` 1) | b1 .&. m /= 0 = do A.write mary i =<< A.indexM ary1 i1 go (i+1) (i1+1) (i2 ) (m `unsafeShiftL` 1) | otherwise = do A.write mary i =<< A.indexM ary2 i2 go (i+1) (i1 ) (i2+1) (m `unsafeShiftL` 1) go 0 0 0 (b' .&. negate b') -- XXX: b' must be non-zero return mary -- TODO: For the case where b1 .&. b2 == b1, i.e. when one is a -- subset of the other, we could use a slightly simpler algorithm, -- where we copy one array, and then update. {-# INLINE unionArrayBy #-} -- TODO: Figure out the time complexity of 'unions'. -- | Construct a set containing all elements from a list of sets. unions :: (Eq k, Hashable k) => [HashMap k v] -> HashMap k v unions = L.foldl' union empty {-# INLINE unions #-} ------------------------------------------------------------------------ -- * Transformations -- | /O(n)/ Transform this map by applying a function to every value. mapWithKey :: (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2 mapWithKey f = go where go Empty = Empty go (Leaf h (L k v)) = Leaf h $ L k (f k v) go (BitmapIndexed b ary) = BitmapIndexed b $ A.map' go ary go (Full ary) = Full $ A.map' go ary go (Collision h ary) = Collision h $ A.map' (\ (L k v) -> L k (f k v)) ary {-# INLINE mapWithKey #-} -- | /O(n)/ Transform this map by applying a function to every value. map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2 map f = mapWithKey (const f) {-# INLINE map #-} -- TODO: We should be able to use mutation to create the new -- 'HashMap'. -- | /O(n)/ 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*log m)/ Difference of two maps. Return elements of the first map -- not existing in the second. difference :: (Eq k, Hashable k) => HashMap k v -> HashMap k w -> HashMap k v difference a b = foldlWithKey' go empty a where go m k v = case lookup k b of Nothing -> insert k v m _ -> m {-# INLINABLE difference #-} -- | /O(n*log m)/ Intersection of two maps. Return elements of the first -- map for keys existing in the second. intersection :: (Eq k, Hashable k) => HashMap k v -> HashMap k w -> HashMap k v intersection a b = foldlWithKey' go empty a where go m k v = case lookup k b of Just _ -> insert k v m _ -> m {-# INLINABLE intersection #-} -- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 intersectionWith f a b = foldlWithKey' go empty a where go m k v = case lookup k b of Just w -> insert k (f v w) m _ -> m {-# INLINABLE intersectionWith #-} -- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps -- the provided function is used to combine the values from the two -- maps. intersectionWithKey :: (Eq k, Hashable k) => (k -> v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3 intersectionWithKey f a b = foldlWithKey' go empty a where go m k v = case lookup k b of Just w -> insert k (f k v w) m _ -> m {-# INLINABLE intersectionWithKey #-} ------------------------------------------------------------------------ -- * Folds -- | /O(n)/ Reduce this map by applying a binary operator to all -- elements, using the given starting value (typically the -- left-identity of the operator). Each application of the operator -- is evaluated before 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)/ Transform this map by applying a function to every value -- and retaining only some of them. mapMaybeWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 mapMaybeWithKey f = filterMapAux onLeaf onColl where onLeaf (Leaf h (L k v)) | Just v' <- f k v = Just (Leaf h (L k v')) onLeaf _ = Nothing onColl (L k v) | Just v' <- f k v = Just (L k v') | otherwise = Nothing {-# INLINE mapMaybeWithKey #-} -- | /O(n)/ Transform this map by applying a function to every value -- and retaining only some of them. mapMaybe :: (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2 mapMaybe f = mapMaybeWithKey (const f) {-# INLINE mapMaybe #-} -- | /O(n)/ Filter this map by retaining only elements satisfying a -- predicate. filterWithKey :: forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v filterWithKey pred = filterMapAux onLeaf onColl where onLeaf t@(Leaf _ (L k v)) | pred k v = Just t onLeaf _ = Nothing onColl el@(L k v) | pred k v = Just el onColl _ = Nothing {-# INLINE filterWithKey #-} -- | Common implementation for 'filterWithKey' and 'mapMaybeWithKey', -- allowing the former to former to reuse terms. filterMapAux :: forall k v1 v2 . (HashMap k v1 -> Maybe (HashMap k v2)) -> (Leaf k v1 -> Maybe (Leaf k v2)) -> HashMap k v1 -> HashMap k v2 filterMapAux onLeaf onColl = go where go Empty = Empty go t@Leaf{} | Just t' <- onLeaf t = t' | otherwise = Empty go (BitmapIndexed b ary) = filterA ary b go (Full ary) = filterA ary fullNodeMask go (Collision h ary) = filterC ary h filterA ary0 b0 = let !n = A.length ary0 in runST $ do mary <- A.new_ n step ary0 mary b0 0 0 1 n where step :: A.Array (HashMap k v1) -> A.MArray s (HashMap k v2) -> Bitmap -> Int -> Int -> Bitmap -> Int -> ST s (HashMap k v2) step !ary !mary !b i !j !bi n | i >= n = case j of 0 -> return Empty 1 -> do ch <- A.read mary 0 case ch of t | isLeafOrCollision t -> return t _ -> BitmapIndexed b <$> trim mary 1 _ -> 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 :: A.Array (Leaf k v1) -> A.MArray s (Leaf k v2) -> Int -> Int -> Int -> ST s (HashMap k v2) step !ary !mary i !j n | i >= n = case j of 0 -> return Empty 1 -> do l <- A.read mary 0 return $! Leaf h l _ | i == j -> do ary2 <- A.unsafeFreeze mary return $! Collision h ary2 | otherwise -> do ary2 <- trim mary j return $! Collision h ary2 | Just el <- onColl (A.index ary i) = A.write mary j el >> step ary mary (i+1) (j+1) n | otherwise = step ary mary (i+1) j n {-# INLINE filterMapAux #-} -- | /O(n)/ Filter this map by retaining only elements which values -- satisfy a predicate. filter :: (v -> Bool) -> HashMap k v -> HashMap k v filter p = filterWithKey (\_ v -> p v) {-# INLINE filter #-} ------------------------------------------------------------------------ -- * Conversions -- TODO: Improve fusion rules by modelled them after the Prelude ones -- on lists. -- | /O(n)/ Return a list of this map's keys. The list is produced -- lazily. keys :: HashMap k v -> [k] keys = L.map fst . toList {-# INLINE keys #-} -- | /O(n)/ Return a list of this map's values. The list is produced -- lazily. elems :: HashMap k v -> [v] elems = L.map snd . toList {-# INLINE elems #-} ------------------------------------------------------------------------ -- ** Lists -- | /O(n)/ Return a list of this map's elements. The list is -- produced lazily. The order of its elements is unspecified. toList :: HashMap k v -> [(k, v)] toList t = build (\ c z -> foldrWithKey (curry c) z t) {-# INLINE toList #-} -- | /O(n)/ Construct a map with the supplied mappings. If the list -- contains duplicate mappings, the later mappings take precedence. fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v fromList = L.foldl' (\ m (k, v) -> unsafeInsert k v m) empty {-# INLINABLE fromList #-} -- | /O(n*log n)/ Construct a map from a list of elements. Uses -- the provided function to merge duplicate entries. fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v fromListWith f = L.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty {-# INLINE fromListWith #-} ------------------------------------------------------------------------ -- 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 {-# INLINABLE lookupInArray #-} -- | /O(n)/ Lookup the value associated with the given key in this -- array. Returns 'Nothing' if the key wasn't found. indexOf :: Eq k => k -> A.Array (Leaf k v) -> Maybe Int indexOf k0 ary0 = go k0 ary0 0 (A.length ary0) where go !k !ary !i !n | i >= n = Nothing | otherwise = case A.index ary i of (L kx _) | k == kx -> Just i | otherwise -> go k ary (i+1) n {-# INLINABLE indexOf #-} updateWith :: Eq k => (v -> v) -> k -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateWith f k0 ary0 = go k0 ary0 0 (A.length ary0) where go !k !ary !i !n | i >= n = ary | otherwise = case A.index ary i of (L kx y) | k == kx -> A.update ary i (L k (f y)) | otherwise -> go k ary (i+1) n {-# INLINABLE updateWith #-} updateOrSnocWith :: Eq k => (v -> v -> v) -> k -> v -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateOrSnocWith f = updateOrSnocWithKey (const f) {-# INLINABLE updateOrSnocWith #-} updateOrSnocWithKey :: Eq k => (k -> v -> v -> v) -> k -> v -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateOrSnocWithKey f k0 v0 ary0 = go k0 v0 ary0 0 (A.length ary0) where go !k v !ary !i !n | i >= n = A.run $ do -- Not found, append to the end. mary <- A.new_ (n + 1) A.copy ary 0 mary 0 n A.write mary n (L k v) return mary | otherwise = case A.index ary i of (L kx y) | k == kx -> A.update ary i (L k (f k v y)) | otherwise -> go k v ary (i+1) n {-# INLINABLE updateOrSnocWithKey #-} updateOrConcatWith :: Eq k => (v -> v -> v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateOrConcatWith f = updateOrConcatWithKey (const f) {-# INLINABLE updateOrConcatWith #-} updateOrConcatWithKey :: Eq k => (k -> v -> v -> v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateOrConcatWithKey f ary1 ary2 = A.run $ do -- first: look up the position of each element of ary2 in ary1 let indices = A.map (\(L k _) -> indexOf k ary1) ary2 -- that tells us how large the overlap is: -- count number of Nothing constructors let nOnly2 = A.foldl' (\n -> maybe (n+1) (const n)) 0 indices let n1 = A.length ary1 let n2 = A.length ary2 -- copy over all elements from ary1 mary <- A.new_ (n1 + nOnly2) A.copy ary1 0 mary 0 n1 -- append or update all elements from ary2 let go !iEnd !i2 | i2 >= n2 = return () | otherwise = case A.index indices i2 of Just i1 -> do -- key occurs in both arrays, store combination in position i1 L k v1 <- A.indexM ary1 i1 L _ v2 <- A.indexM ary2 i2 A.write mary i1 (L k (f k v1 v2)) go iEnd (i2+1) Nothing -> do -- key is only in ary2, append to end A.write mary iEnd =<< A.indexM ary2 i2 go (iEnd+1) (i2+1) go n1 0 return mary {-# INLINABLE updateOrConcatWithKey #-} ------------------------------------------------------------------------ -- Manually unrolled loops -- | /O(n)/ Update the element at the given position in this array. update16 :: A.Array e -> Int -> e -> A.Array e update16 ary idx b = runST (update16M ary idx b) {-# INLINE update16 #-} -- | /O(n)/ Update the element at the given position in this array. update16M :: A.Array e -> Int -> e -> ST s (A.Array e) update16M ary idx b = do mary <- clone16 ary A.write mary idx b A.unsafeFreeze mary {-# INLINE update16M #-} -- | /O(n)/ Update the element at the given position in this array, by applying a function to it. update16With' :: A.Array e -> Int -> (e -> e) -> A.Array e update16With' ary idx f = 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.indexM ary 0 >>= A.write mary 0 A.indexM ary 1 >>= A.write mary 1 A.indexM ary 2 >>= A.write mary 2 A.indexM ary 3 >>= A.write mary 3 A.indexM ary 4 >>= A.write mary 4 A.indexM ary 5 >>= A.write mary 5 A.indexM ary 6 >>= A.write mary 6 A.indexM ary 7 >>= A.write mary 7 A.indexM ary 8 >>= A.write mary 8 A.indexM ary 9 >>= A.write mary 9 A.indexM ary 10 >>= A.write mary 10 A.indexM ary 11 >>= A.write mary 11 A.indexM ary 12 >>= A.write mary 12 A.indexM ary 13 >>= A.write mary 13 A.indexM ary 14 >>= A.write mary 14 A.indexM 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` maxChildren) {-# INLINE fullNodeMask #-} -- | Check if two the two arguments are the same value. N.B. This -- function might give false negatives (due to GC moving objects.) ptrEq :: a -> a -> Bool #if __GLASGOW_HASKELL__ < 707 ptrEq x y = reallyUnsafePtrEquality# x y ==# 1# #else ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y ==# 1#) #endif {-# INLINE ptrEq #-} #if __GLASGOW_HASKELL__ >= 708 ------------------------------------------------------------------------ -- IsList instance instance (Eq k, Hashable k) => Exts.IsList (HashMap k v) where type Item (HashMap k v) = (k, v) fromList = fromList toList = toList #endif unordered-containers-0.2.7.1/benchmarks/0000755000000000000000000000000012726130613016315 5ustar0000000000000000unordered-containers-0.2.7.1/benchmarks/Benchmarks.hs0000644000000000000000000003277012726130613020737 0ustar0000000000000000{-# LANGUAGE CPP, DeriveGeneric, GADTs, PackageImports, RecordWildCards #-} module Main where import Control.DeepSeq import Control.DeepSeq.Generics (genericRnf) import Criterion.Main (bench, bgroup, defaultMain, env, nf, whnf) import Data.Bits ((.&.)) import Data.Hashable (Hashable) import qualified Data.ByteString as BS import qualified "hashmap" Data.HashMap as IHM import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as IM import qualified Data.Map as M import Data.List (foldl') import Data.Maybe (fromMaybe) import GHC.Generics (Generic) import Prelude hiding (lookup) import qualified Util.ByteString as UBS import qualified Util.Int as UI import qualified Util.String as US #if !MIN_VERSION_bytestring(0,10,0) instance NFData BS.ByteString #endif data B where B :: NFData a => a -> B instance NFData B where rnf (B b) = rnf b -- TODO: This a stopgap measure to keep the benchmark work with -- Criterion 1.0. data Env = Env { n :: !Int, elems :: ![(String, Int)], keys :: ![String], elemsBS :: ![(BS.ByteString, Int)], keysBS :: ![BS.ByteString], elemsI :: ![(Int, Int)], keysI :: ![Int], elemsI2 :: ![(Int, Int)], -- for union keys' :: ![String], keysBS' :: ![BS.ByteString], keysI' :: ![Int], keysDup :: ![String], keysDupBS :: ![BS.ByteString], keysDupI :: ![Int], elemsDup :: ![(String, Int)], elemsDupBS :: ![(BS.ByteString, Int)], elemsDupI :: ![(Int, Int)], hm :: !(HM.HashMap String Int), hmbs :: !(HM.HashMap BS.ByteString Int), hmi :: !(HM.HashMap Int Int), hmi2 :: !(HM.HashMap Int Int), m :: !(M.Map String Int), mbs :: !(M.Map BS.ByteString Int), im :: !(IM.IntMap Int), ihm :: !(IHM.Map String Int), ihmbs :: !(IHM.Map BS.ByteString Int) } deriving Generic instance NFData Env where rnf = genericRnf setupEnv :: IO Env setupEnv = do let n = 2^(12 :: Int) elems = zip keys [1..n] keys = US.rnd 8 n elemsBS = zip keysBS [1..n] keysBS = UBS.rnd 8 n elemsI = zip keysI [1..n] keysI = UI.rnd (n+n) n elemsI2 = zip [n `div` 2..n + (n `div` 2)] [1..n] -- for union keys' = US.rnd' 8 n keysBS' = UBS.rnd' 8 n keysI' = UI.rnd' (n+n) n keysDup = US.rnd 2 n keysDupBS = UBS.rnd 2 n keysDupI = UI.rnd (n`div`4) n elemsDup = zip keysDup [1..n] elemsDupBS = zip keysDupBS [1..n] elemsDupI = zip keysDupI [1..n] hm = HM.fromList elems hmbs = HM.fromList elemsBS hmi = HM.fromList elemsI hmi2 = HM.fromList elemsI2 m = M.fromList elems mbs = M.fromList elemsBS im = IM.fromList elemsI ihm = IHM.fromList elems ihmbs = IHM.fromList elemsBS return Env{..} main :: IO () main = do defaultMain [ env setupEnv $ \ ~(Env{..}) -> -- * 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 ] ] -- ** Map from the hashmap package , env setupEnv $ \ ~(Env{..}) -> bgroup "hashmap/Map" [ bgroup "lookup" [ bench "String" $ whnf (lookupIHM keys) ihm , bench "ByteString" $ whnf (lookupIHM keysBS) ihmbs ] , bgroup "lookup-miss" [ bench "String" $ whnf (lookupIHM keys') ihm , bench "ByteString" $ whnf (lookupIHM keysBS') ihmbs ] , bgroup "insert" [ bench "String" $ whnf (insertIHM elems) IHM.empty , bench "ByteStringString" $ whnf (insertIHM elemsBS) IHM.empty ] , bgroup "insert-dup" [ bench "String" $ whnf (insertIHM elems) ihm , bench "ByteStringString" $ whnf (insertIHM elemsBS) ihmbs ] , bgroup "delete" [ bench "String" $ whnf (deleteIHM keys) ihm , bench "ByteString" $ whnf (deleteIHM keysBS) ihmbs ] , bgroup "delete-miss" [ bench "String" $ whnf (deleteIHM keys') ihm , bench "ByteString" $ whnf (deleteIHM keysBS') ihmbs ] , bgroup "size" [ bench "String" $ whnf IHM.size ihm , bench "ByteString" $ whnf IHM.size ihmbs ] , bgroup "fromList" [ bench "String" $ whnf IHM.fromList elems , bench "ByteString" $ whnf IHM.fromList elemsBS ] ] -- ** IntMap , env setupEnv $ \ ~(Env{..}) -> bgroup "IntMap" [ bench "lookup" $ whnf (lookupIM keysI) im , bench "lookup-miss" $ whnf (lookupIM keysI') im , bench "insert" $ whnf (insertIM elemsI) IM.empty , 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 ] , env setupEnv $ \ ~(Env{..}) -> bgroup "HashMap" [ -- * Basic interface bgroup "lookup" [ bench "String" $ whnf (lookup keys) hm , bench "ByteString" $ whnf (lookup keysBS) hmbs , bench "Int" $ whnf (lookup keysI) hmi ] , bgroup "lookup-miss" [ bench "String" $ whnf (lookup keys') hm , bench "ByteString" $ whnf (lookup keysBS') hmbs , bench "Int" $ whnf (lookup keysI') hmi ] , bgroup "insert" [ bench "String" $ whnf (insert elems) HM.empty , bench "ByteString" $ whnf (insert elemsBS) HM.empty , bench "Int" $ whnf (insert elemsI) HM.empty ] , bgroup "insert-dup" [ bench "String" $ whnf (insert elems) hm , bench "ByteString" $ whnf (insert elemsBS) hmbs , bench "Int" $ whnf (insert elemsI) hmi ] , bgroup "delete" [ bench "String" $ whnf (delete keys) hm , bench "ByteString" $ whnf (delete keysBS) hmbs , bench "Int" $ whnf (delete keysI) hmi ] , bgroup "delete-miss" [ bench "String" $ whnf (delete keys') hm , bench "ByteString" $ whnf (delete keysBS') hmbs , bench "Int" $ whnf (delete keysI') hmi ] -- 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" $ nf (HM.foldr (:) []) hmi -- Filter , bench "filter" $ whnf (HM.filter (\ v -> v .&. 1 == 0)) hmi , bench "filterWithKey" $ whnf (HM.filterWithKey (\ k _ -> k .&. 1 == 0)) hmi -- Size , bgroup "size" [ bench "String" $ whnf HM.size hm , bench "ByteString" $ whnf HM.size hmbs , bench "Int" $ whnf HM.size hmi ] -- fromList , bgroup "fromList" [ bgroup "long" [ bench "String" $ whnf HM.fromList elems , bench "ByteString" $ whnf HM.fromList elemsBS , bench "Int" $ whnf HM.fromList elemsI ] , bgroup "short" [ bench "String" $ whnf HM.fromList elemsDup , bench "ByteString" $ whnf HM.fromList elemsDupBS , bench "Int" $ whnf HM.fromList elemsDupI ] ] -- fromListWith , bgroup "fromListWith" [ bgroup "long" [ bench "String" $ whnf (HM.fromListWith (+)) elems , bench "ByteString" $ whnf (HM.fromListWith (+)) elemsBS , bench "Int" $ whnf (HM.fromListWith (+)) elemsI ] , bgroup "short" [ bench "String" $ whnf (HM.fromListWith (+)) elemsDup , bench "ByteString" $ whnf (HM.fromListWith (+)) elemsDupBS , bench "Int" $ whnf (HM.fromListWith (+)) elemsDupI ] ] ] ] ------------------------------------------------------------------------ -- * 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 #-} ------------------------------------------------------------------------ -- * Map from the hashmap package lookupIHM :: (Eq k, Hashable k, Ord k) => [k] -> IHM.Map k Int -> Int lookupIHM xs m = foldl' (\z k -> fromMaybe z (IHM.lookup k m)) 0 xs {-# SPECIALIZE lookupIHM :: [String] -> IHM.Map String Int -> Int #-} {-# SPECIALIZE lookupIHM :: [BS.ByteString] -> IHM.Map BS.ByteString Int -> Int #-} insertIHM :: (Eq k, Hashable k, Ord k) => [(k, Int)] -> IHM.Map k Int -> IHM.Map k Int insertIHM xs m0 = foldl' (\m (k, v) -> IHM.insert k v m) m0 xs {-# SPECIALIZE insertIHM :: [(String, Int)] -> IHM.Map String Int -> IHM.Map String Int #-} {-# SPECIALIZE insertIHM :: [(BS.ByteString, Int)] -> IHM.Map BS.ByteString Int -> IHM.Map BS.ByteString Int #-} deleteIHM :: (Eq k, Hashable k, Ord k) => [k] -> IHM.Map k Int -> IHM.Map k Int deleteIHM xs m0 = foldl' (\m k -> IHM.delete k m) m0 xs {-# SPECIALIZE deleteIHM :: [String] -> IHM.Map String Int -> IHM.Map String Int #-} {-# SPECIALIZE deleteIHM :: [BS.ByteString] -> IHM.Map BS.ByteString Int -> IHM.Map BS.ByteString Int #-} ------------------------------------------------------------------------ -- * 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 unordered-containers-0.2.7.1/benchmarks/Util/0000755000000000000000000000000012726130613017232 5ustar0000000000000000unordered-containers-0.2.7.1/benchmarks/Util/Int.hs0000644000000000000000000000121412726130613020316 0ustar0000000000000000-- | 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 unordered-containers-0.2.7.1/benchmarks/Util/ByteString.hs0000644000000000000000000000205212726130613021657 0ustar0000000000000000-- | 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 unordered-containers-0.2.7.1/benchmarks/Util/String.hs0000644000000000000000000000263512726130613021042 0ustar0000000000000000-- | 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' unordered-containers-0.2.7.1/cbits/0000755000000000000000000000000012726130613015304 5ustar0000000000000000unordered-containers-0.2.7.1/cbits/popc.c0000644000000000000000000000717112726130613016417 0ustar0000000000000000#include /* 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 */ 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 */ unordered-containers-0.2.7.1/tests/0000755000000000000000000000000012726130613015342 5ustar0000000000000000unordered-containers-0.2.7.1/tests/Strictness.hs0000644000000000000000000001115412726130613020041 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Data.Hashable (Hashable(hashWithSalt)) import Test.ChasingBottoms.IsBottom import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck (Arbitrary(arbitrary)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM -- Key type that generates more hash collisions. newtype Key = K { unK :: Int } deriving (Arbitrary, Eq, Ord, Show) instance Hashable Key where hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20 instance (Arbitrary k, Arbitrary v, Eq k, Hashable k) => Arbitrary (HashMap k v) where arbitrary = HM.fromList `fmap` arbitrary instance Show (Int -> Int) where show _ = "" instance Show (Int -> Int -> Int) where show _ = "" ------------------------------------------------------------------------ -- * Properties ------------------------------------------------------------------------ -- ** Strict module pSingletonKeyStrict :: Int -> Bool pSingletonKeyStrict v = isBottom $ HM.singleton (bottom :: Key) v pSingletonValueStrict :: Key -> Bool pSingletonValueStrict k = isBottom $ (HM.singleton k (bottom :: Int)) pLookupDefaultKeyStrict :: Int -> HashMap Key Int -> Bool pLookupDefaultKeyStrict def m = isBottom $ HM.lookupDefault def bottom m pAdjustKeyStrict :: (Int -> Int) -> HashMap Key Int -> Bool pAdjustKeyStrict f m = isBottom $ HM.adjust f bottom m pAdjustValueStrict :: Key -> HashMap Key Int -> Bool pAdjustValueStrict k m | k `HM.member` m = isBottom $ HM.adjust (const bottom) k m | otherwise = case HM.keys m of [] -> True (k':_) -> isBottom $ HM.adjust (const bottom) k' m pInsertKeyStrict :: Int -> HashMap Key Int -> Bool pInsertKeyStrict v m = isBottom $ HM.insert bottom v m pInsertValueStrict :: Key -> HashMap Key Int -> Bool pInsertValueStrict k m = isBottom $ HM.insert k bottom m pInsertWithKeyStrict :: (Int -> Int -> Int) -> Int -> HashMap Key Int -> Bool pInsertWithKeyStrict f v m = isBottom $ HM.insertWith f bottom v m pInsertWithValueStrict :: (Int -> Int -> Int) -> Key -> Int -> HashMap Key Int -> Bool pInsertWithValueStrict f k v m | HM.member k m = isBottom $ HM.insertWith (const2 bottom) k v m | otherwise = isBottom $ HM.insertWith f k bottom m pFromListKeyStrict :: Bool pFromListKeyStrict = isBottom $ HM.fromList [(undefined :: Key, 1 :: Int)] pFromListValueStrict :: Bool pFromListValueStrict = isBottom $ HM.fromList [(K 1, undefined)] pFromListWithKeyStrict :: (Int -> Int -> Int) -> Bool pFromListWithKeyStrict f = isBottom $ HM.fromListWith f [(undefined :: Key, 1 :: Int)] pFromListWithValueStrict :: [(Key, Int)] -> Bool pFromListWithValueStrict xs = case xs of [] -> True (x:_) -> isBottom $ HM.fromListWith (\ _ _ -> undefined) (x:xs) ------------------------------------------------------------------------ -- * Test list tests :: [Test] tests = [ -- Basic interface testGroup "HashMap.Strict" [ testProperty "singleton is key-strict" pSingletonKeyStrict , testProperty "singleton is value-strict" pSingletonValueStrict , testProperty "member is key-strict" $ keyStrict HM.member , testProperty "lookup is key-strict" $ keyStrict HM.lookup , testProperty "lookupDefault is key-strict" pLookupDefaultKeyStrict , testProperty "! is key-strict" $ keyStrict (flip (HM.!)) , testProperty "delete is key-strict" $ keyStrict HM.delete , testProperty "adjust is key-strict" pAdjustKeyStrict , testProperty "adjust is value-strict" pAdjustValueStrict , testProperty "insert is key-strict" pInsertKeyStrict , testProperty "insert is value-strict" pInsertValueStrict , testProperty "insertWith is key-strict" pInsertWithKeyStrict , testProperty "insertWith is value-strict" pInsertWithValueStrict , testProperty "fromList is key-strict" pFromListKeyStrict , testProperty "fromList is value-strict" pFromListValueStrict , testProperty "fromListWith is key-strict" pFromListWithKeyStrict , testProperty "fromListWith is value-strict" pFromListWithValueStrict ] ] ------------------------------------------------------------------------ -- * Test harness main :: IO () main = defaultMain tests ------------------------------------------------------------------------ -- * Utilities keyStrict :: (Key -> HashMap Key Int -> a) -> HashMap Key Int -> Bool keyStrict f m = isBottom $ f bottom m const2 :: a -> b -> c -> a const2 x _ _ = x unordered-containers-0.2.7.1/tests/Regressions.hs0000644000000000000000000000431012726130613020177 0ustar0000000000000000module Main where import Control.Applicative ((<$>)) import Control.Monad (replicateM) import qualified Data.HashMap.Strict as HM import Data.List (delete) import Data.Maybe import Test.HUnit (Assertion, assert) import Test.Framework (Test, defaultMain) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck issue32 :: Assertion issue32 = assert $ isJust $ HM.lookup 7 m' where ns = [0..16] :: [Int] m = HM.fromList (zip ns (repeat [])) m' = HM.delete 10 m ------------------------------------------------------------------------ -- Issue #39 -- First regression issue39 :: Assertion issue39 = assert $ hm1 == hm2 where hm1 = HM.fromList ([a, b] `zip` [1, 1 :: Int ..]) hm2 = HM.fromList ([b, a] `zip` [1, 1 :: Int ..]) a = (1, -1) :: (Int, Int) b = (-1, 1) :: (Int, Int) -- Second regression newtype Keys = Keys [Int] deriving Show instance Arbitrary Keys where arbitrary = sized $ \l -> do pis <- replicateM (l+1) positiveInt return (Keys $ prefixSum pis) shrink (Keys ls) = let l = length ls in if l == 1 then [] else [ Keys (dropAt i ls) | i <- [0..l-1] ] positiveInt :: Gen Int positiveInt = (+1) . abs <$> arbitrary prefixSum :: [Int] -> [Int] prefixSum = loop 0 where loop _ [] = [] loop prefix (l:ls) = let n = l + prefix in n : loop n ls dropAt :: Int -> [a] -> [a] dropAt _ [] = [] dropAt i (l:ls) | i == 0 = ls | otherwise = l : dropAt (i-1) ls propEqAfterDelete :: Keys -> Bool propEqAfterDelete (Keys keys) = let keyMap = mapFromKeys keys k = head keys in HM.delete k keyMap == mapFromKeys (delete k keys) mapFromKeys :: [Int] -> HM.HashMap Int () mapFromKeys keys = HM.fromList (zip keys (repeat ())) ------------------------------------------------------------------------ -- * Test list tests :: [Test] tests = [ testCase "issue32" issue32 , testCase "issue39a" issue39 , testProperty "issue39b" propEqAfterDelete ] ------------------------------------------------------------------------ -- * Test harness main :: IO () main = defaultMain tests unordered-containers-0.2.7.1/tests/HashMapProperties.hs0000644000000000000000000002707412726130613021306 0ustar0000000000000000{-# 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 Control.Monad ( guard ) import qualified Data.Foldable as Foldable import Data.Function (on) import Data.Hashable (Hashable(hashWithSalt)) import qualified Data.List as L import Data.Ord (comparing) #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, Property, (==>), (===)) import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -- Key type that generates more hash collisions. newtype Key = K { unK :: Int } deriving (Arbitrary, Eq, Ord, Read, Show) instance Hashable Key where hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20 ------------------------------------------------------------------------ -- * Properties ------------------------------------------------------------------------ -- ** Instances pEq :: [(Key, Int)] -> [(Key, Int)] -> Bool pEq xs = (M.fromList xs ==) `eq` (HM.fromList xs ==) pNeq :: [(Key, Int)] -> [(Key, Int)] -> Bool pNeq xs = (M.fromList xs /=) `eq` (HM.fromList xs /=) pReadShow :: [(Key, Int)] -> Bool pReadShow xs = M.fromList xs == read (show (M.fromList xs)) pFunctor :: [(Key, Int)] -> Bool pFunctor = fmap (+ 1) `eq_` fmap (+ 1) pFoldable :: [(Int, Int)] -> Bool pFoldable = (L.sort . Foldable.foldr (:) []) `eq` (L.sort . Foldable.foldr (:) []) pHashable :: [(Key, Int)] -> [Int] -> Int -> Property pHashable xs is salt = x == y ==> hashWithSalt salt x === hashWithSalt salt y where ys = shuffle is xs x = HM.fromList xs y = HM.fromList ys -- Shuffle the list using indexes in the second shuffle :: [Int] -> [a] -> [a] shuffle idxs = L.map snd . L.sortBy (comparing fst) . L.zip (idxs ++ [L.maximum (0:is) + 1 ..]) ------------------------------------------------------------------------ -- ** Basic interface pSize :: [(Key, Int)] -> Bool pSize = M.size `eq` HM.size pMember :: Key -> [(Key, Int)] -> Bool pMember k = M.member k `eq` HM.member k pLookup :: Key -> [(Key, Int)] -> Bool pLookup k = M.lookup k `eq` HM.lookup k pInsert :: Key -> Int -> [(Key, Int)] -> Bool pInsert k v = M.insert k v `eq_` HM.insert k v pDelete :: Key -> [(Key, Int)] -> Bool pDelete k = M.delete k `eq_` HM.delete k newtype AlwaysCollide = AC Int deriving (Arbitrary, Eq, Ord, Show) instance Hashable AlwaysCollide where hashWithSalt _ _ = 1 -- White-box test that tests the case of deleting one of two keys from -- a map, where the keys' hash values collide. pDeleteCollision :: AlwaysCollide -> AlwaysCollide -> AlwaysCollide -> Int -> Property pDeleteCollision k1 k2 k3 idx = (k1 /= k2) && (k2 /= k3) && (k1 /= k3) ==> HM.member toKeep $ HM.delete toDelete $ HM.fromList [(k1, 1 :: Int), (k2, 2), (k3, 3)] where which = idx `mod` 3 toDelete | which == 0 = k1 | which == 1 = k2 | which == 2 = k3 | otherwise = error "Impossible" toKeep | which == 0 = k2 | which == 1 = k3 | which == 2 = k1 | otherwise = error "Impossible" pInsertWith :: Key -> [(Key, Int)] -> Bool pInsertWith k = M.insertWith (+) k 1 `eq_` HM.insertWith (+) k 1 pAdjust :: Key -> [(Key, Int)] -> Bool pAdjust k = M.adjust succ k `eq_` HM.adjust succ k pUpdateAdjust :: Key -> [(Key, Int)] -> Bool pUpdateAdjust k = M.update (Just . succ) k `eq_` HM.update (Just . succ) k pUpdateDelete :: Key -> [(Key, Int)] -> Bool pUpdateDelete k = M.update (const Nothing) k `eq_` HM.update (const Nothing) k pAlterAdjust :: Key -> [(Key, Int)] -> Bool pAlterAdjust k = M.alter (fmap succ) k `eq_` HM.alter (fmap succ) k pAlterInsert :: Key -> [(Key, Int)] -> Bool pAlterInsert k = M.alter (const $ Just 3) k `eq_` HM.alter (const $ Just 3) k pAlterDelete :: Key -> [(Key, Int)] -> Bool pAlterDelete k = M.alter (const Nothing) k `eq_` HM.alter (const Nothing) k ------------------------------------------------------------------------ -- ** Combine pUnion :: [(Key, Int)] -> [(Key, Int)] -> Bool pUnion xs ys = M.union (M.fromList xs) `eq_` HM.union (HM.fromList xs) $ ys pUnionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool pUnionWith xs ys = M.unionWith (-) (M.fromList xs) `eq_` HM.unionWith (-) (HM.fromList xs) $ ys pUnionWithKey :: [(Key, Int)] -> [(Key, Int)] -> Bool pUnionWithKey xs ys = M.unionWithKey go (M.fromList xs) `eq_` HM.unionWithKey go (HM.fromList xs) $ ys where go :: Key -> Int -> Int -> Int go (K k) i1 i2 = k - i1 + i2 pUnions :: [[(Key, Int)]] -> Bool pUnions xss = M.toAscList (M.unions (map M.fromList xss)) == toAscList (HM.unions (map HM.fromList xss)) ------------------------------------------------------------------------ -- ** Transformations pMap :: [(Key, Int)] -> Bool pMap = M.map (+ 1) `eq_` HM.map (+ 1) ------------------------------------------------------------------------ -- ** 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 pIntersectionWith :: [(Key, Int)] -> [(Key, Int)] -> Bool pIntersectionWith xs ys = M.intersectionWith (-) (M.fromList xs) `eq_` HM.intersectionWith (-) (HM.fromList xs) $ ys pIntersectionWithKey :: [(Key, Int)] -> [(Key, Int)] -> Bool pIntersectionWithKey xs ys = M.intersectionWithKey go (M.fromList xs) `eq_` HM.intersectionWithKey go (HM.fromList xs) $ ys where go :: Key -> Int -> Int -> Int go (K k) i1 i2 = k - i1 - i2 ------------------------------------------------------------------------ -- ** Folds pFoldr :: [(Int, Int)] -> Bool pFoldr = (L.sort . M.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 = foldlWithKey'Map (\ z _ v -> v + z) z0 `eq` HM.foldl' (+) z0 foldlWithKey'Map :: (b -> k -> a -> b) -> b -> M.Map k a -> b #if MIN_VERSION_containers(4,2,0) foldlWithKey'Map = M.foldlWithKey' #else -- Equivalent except for bottoms, which we don't test. foldlWithKey'Map = M.foldlWithKey #endif ------------------------------------------------------------------------ -- ** Filter pMapMaybeWithKey :: [(Key, Int)] -> Bool pMapMaybeWithKey = M.mapMaybeWithKey f `eq_` HM.mapMaybeWithKey f where f k v = guard (odd (unK k + v)) >> Just (v + 1) pMapMaybe :: [(Key, Int)] -> Bool pMapMaybe = M.mapMaybe f `eq_` HM.mapMaybe f where f v = guard (odd v) >> Just (v + 1) pFilter :: [(Key, Int)] -> Bool pFilter = M.filter odd `eq_` HM.filter odd pFilterWithKey :: [(Key, Int)] -> Bool pFilterWithKey = M.filterWithKey p `eq_` HM.filterWithKey p where p k v = odd (unK k + v) ------------------------------------------------------------------------ -- ** Conversions -- 'eq_' already calls fromList. pFromList :: [(Key, Int)] -> Bool pFromList = id `eq_` id pFromListWith :: [(Key, Int)] -> Bool pFromListWith kvs = (M.toAscList $ M.fromListWith (+) kvs) == (toAscList $ HM.fromListWith (+) kvs) 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 "Read/Show" pReadShow , testProperty "Functor" pFunctor , testProperty "Foldable" pFoldable , testProperty "Hashable" pHashable ] -- Basic interface , testGroup "basic interface" [ testProperty "size" pSize , testProperty "member" pMember , testProperty "lookup" pLookup , testProperty "insert" pInsert , testProperty "delete" pDelete , testProperty "deleteCollision" pDeleteCollision , testProperty "insertWith" pInsertWith , testProperty "adjust" pAdjust , testProperty "updateAdjust" pUpdateAdjust , testProperty "updateDelete" pUpdateDelete , testProperty "alterAdjust" pAlterAdjust , testProperty "alterInsert" pAlterInsert , testProperty "alterDelete" pAlterDelete ] -- Combine , testProperty "union" pUnion , testProperty "unionWith" pUnionWith , testProperty "unionWithKey" pUnionWithKey , testProperty "unions" pUnions -- 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 , testProperty "intersectionWith" pIntersectionWith , testProperty "intersectionWithKey" pIntersectionWithKey ] -- Filter , testGroup "filter" [ testProperty "filter" pFilter , testProperty "filterWithKey" pFilterWithKey , testProperty "mapMaybe" pMapMaybe , testProperty "mapMaybeWithKey" pMapMaybeWithKey ] -- Conversions , testGroup "conversions" [ testProperty "elems" pElems , testProperty "keys" pKeys , testProperty "fromList" pFromList , testProperty "fromListWith" pFromListWith , testProperty "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 unordered-containers-0.2.7.1/tests/HashSetProperties.hs0000644000000000000000000001402512726130613021314 0ustar0000000000000000{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -- | Tests for the 'Data.HashSet' module. We test functions by -- comparing them to a simpler model, a list. module Main (main) where import qualified Data.Foldable as Foldable import Data.Hashable (Hashable(hashWithSalt)) import qualified Data.List as L import qualified Data.HashSet as S import qualified Data.Set as Set import Data.Ord (comparing) import Test.QuickCheck (Arbitrary, Property, (==>), (===)) import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -- Key type that generates more hash collisions. newtype Key = K { unK :: Int } deriving (Arbitrary, Enum, Eq, Integral, Num, Ord, Read, Show, Real) instance Hashable Key where hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20 ------------------------------------------------------------------------ -- * Properties ------------------------------------------------------------------------ -- ** Instances pEq :: [Key] -> [Key] -> Bool pEq xs = (Set.fromList xs ==) `eq` (S.fromList xs ==) pNeq :: [Key] -> [Key] -> Bool pNeq xs = (Set.fromList xs /=) `eq` (S.fromList xs /=) pReadShow :: [Key] -> Bool pReadShow xs = Set.fromList xs == read (show (Set.fromList xs)) pFoldable :: [Int] -> Bool pFoldable = (L.sort . Foldable.foldr (:) []) `eq` (L.sort . Foldable.foldr (:) []) pPermutationEq :: [Key] -> [Int] -> Bool pPermutationEq xs is = S.fromList xs == S.fromList ys where ys = shuffle is xs shuffle idxs = L.map snd . L.sortBy (comparing fst) . L.zip (idxs ++ [L.maximum (0:is) + 1 ..]) pHashable :: [Key] -> [Int] -> Int -> Property pHashable xs is salt = x == y ==> hashWithSalt salt x === hashWithSalt salt y where ys = shuffle is xs x = S.fromList xs y = S.fromList ys shuffle idxs = L.map snd . L.sortBy (comparing fst) . L.zip (idxs ++ [L.maximum (0:is) + 1 ..]) ------------------------------------------------------------------------ -- ** Basic interface pSize :: [Key] -> Bool pSize = Set.size `eq` S.size pMember :: Key -> [Key] -> Bool pMember k = Set.member k `eq` S.member k pInsert :: Key -> [Key] -> Bool pInsert a = Set.insert a `eq_` S.insert a pDelete :: Key -> [Key] -> Bool pDelete a = Set.delete a `eq_` S.delete a ------------------------------------------------------------------------ -- ** Combine pUnion :: [Key] -> [Key] -> Bool pUnion xs ys = Set.union (Set.fromList xs) `eq_` S.union (S.fromList xs) $ ys ------------------------------------------------------------------------ -- ** Transformations pMap :: [Key] -> Bool pMap = Set.map (+ 1) `eq_` S.map (+ 1) ------------------------------------------------------------------------ -- ** Folds pFoldr :: [Int] -> Bool pFoldr = (L.sort . foldrSet (:) []) `eq` (L.sort . S.foldr (:) []) foldrSet :: (a -> b -> b) -> b -> Set.Set a -> b #if MIN_VERSION_containers(0,4,2) foldrSet = Set.foldr #else foldrSet = Foldable.foldr #endif pFoldl' :: Int -> [Int] -> Bool pFoldl' z0 = foldl'Set (+) z0 `eq` S.foldl' (+) z0 foldl'Set :: (a -> b -> a) -> a -> Set.Set b -> a #if MIN_VERSION_containers(0,4,2) foldl'Set = Set.foldl' #else foldl'Set = Foldable.foldl' #endif ------------------------------------------------------------------------ -- ** Filter pFilter :: [Key] -> Bool pFilter = Set.filter odd `eq_` S.filter odd ------------------------------------------------------------------------ -- ** Conversions pToList :: [Key] -> Bool pToList = Set.toAscList `eq` toAscList ------------------------------------------------------------------------ -- * Test list tests :: [Test] tests = [ -- Instances testGroup "instances" [ testProperty "==" pEq , testProperty "Permutation ==" pPermutationEq , testProperty "/=" pNeq , testProperty "Read/Show" pReadShow , testProperty "Foldable" pFoldable , testProperty "Hashable" pHashable ] -- Basic interface , testGroup "basic interface" [ testProperty "size" pSize , testProperty "member" pMember , testProperty "insert" pInsert , testProperty "delete" pDelete ] -- Combine , testProperty "union" pUnion -- Transformations , testProperty "map" pMap -- Folds , testGroup "folds" [ testProperty "foldr" pFoldr , testProperty "foldl'" pFoldl' ] -- Filter , testGroup "filter" [ testProperty "filter" pFilter ] -- Conversions , testGroup "conversions" [ testProperty "toList" pToList ] ] ------------------------------------------------------------------------ -- * Model -- Invariant: the list is sorted in ascending order, by key. type Model a = Set.Set a -- | Check that a function operating on a 'HashMap' is equivalent to -- one operating on a 'Model'. eq :: (Eq a, Hashable a, Ord a, Eq b) => (Model a -> b) -- ^ Function that modifies a 'Model' in the same -- way -> (S.HashSet a -> b) -- ^ Function that modified a 'HashSet' -> [a] -- ^ Initial content of the 'HashSet' and 'Model' -> Bool -- ^ True if the functions are equivalent eq f g xs = g (S.fromList xs) == f (Set.fromList xs) eq_ :: (Eq a, Hashable a, Ord a) => (Model a -> Model a) -- ^ Function that modifies a 'Model' -> (S.HashSet a -> S.HashSet a) -- ^ Function that modified a -- 'HashSet' in the same way -> [a] -- ^ Initial content of the 'HashSet' -- and 'Model' -> Bool -- ^ True if the functions are -- equivalent eq_ f g = (Set.toAscList . f) `eq` (toAscList . g) ------------------------------------------------------------------------ -- * Test harness main :: IO () main = defaultMain tests ------------------------------------------------------------------------ -- * Helpers toAscList :: Ord a => S.HashSet a -> [a] toAscList = L.sort . S.toList