unordered-containers 0.1.2.0 → 0.1.3.0
raw patch · 11 files changed
+937/−319 lines, 11 filesdep +QuickCheckdep +containersdep +test-frameworkdep ~base
Dependencies added: QuickCheck, containers, test-framework, test-framework-quickcheck2, unordered-containers
Dependency ranges changed: base
Files
- Data/FullList/Lazy.hs +47/−0
- Data/HashMap/Common.hs +184/−47
- Data/HashMap/Lazy.hs +48/−41
- Data/HashMap/Lazy/Internal.hs +2/−2
- Data/HashMap/Strict.hs +37/−25
- Data/HashSet.hs +187/−0
- benchmarks/Benchmarks.hs +17/−0
- tests/MapProperties.hs +205/−0
- tests/Properties.hs +0/−188
- tests/SetProperties.hs +171/−0
- unordered-containers.cabal +39/−16
Data/FullList/Lazy.hs view
@@ -25,6 +25,10 @@ , insertWith , adjust + -- * Combine+ -- * Union+ , union+ -- * Transformations , map , traverseWithKey@@ -115,6 +119,25 @@ {-# INLINABLE lookupL #-} #endif +member :: Eq k => k -> FullList k v -> Bool+member !k (FL k' _ xs)+ | k == k' = True+ | otherwise = memberL k xs+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE member #-}+#endif++memberL :: Eq k => k -> List k v -> Bool+memberL = go+ where+ go !_ Nil = False+ go k (Cons k' _ xs)+ | k == k' = True+ | otherwise = go k xs+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE memberL #-}+#endif+ insert :: Eq k => k -> v -> FullList k v -> FullList k v insert !k v (FL k' v' xs) | k == k' = FL k v xs@@ -194,6 +217,30 @@ | otherwise = Cons k' v (go k xs) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE adjustL #-}+#endif++------------------------------------------------------------------------+-- * Combine++-- | /O(n^2)/ Left biased union.+union :: Eq k => FullList k v -> FullList k v -> FullList k v+union xs (FL k v ys)+ | k `member` xs = unionL xs ys+ | otherwise = case unionL xs ys of+ FL k' v' zs -> FL k v $ Cons k' v' zs+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE union #-}+#endif++unionL :: Eq k => FullList k v -> List k v -> FullList k v+unionL xs@(FL k v zs) = FL k v . go+ where+ go Nil = zs+ go (Cons k' v' ys)+ | k' `member` xs = go ys+ | otherwise = Cons k' v' $ go ys+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE unionL #-} #endif ------------------------------------------------------------------------
Data/HashMap/Common.hs view
@@ -6,18 +6,21 @@ ( -- * Types HashMap(..)- , Suffix- , Mask- , Hash -- * Helpers , join , bin , zero , nomatch- , mask + -- * Construction+ , empty++ -- * Combine+ , union+ -- * Transformations+ , filterMapWithKey , traverseWithKey -- * Folds@@ -26,10 +29,11 @@ #include "MachDeps.h" -import Control.Applicative+import Control.Applicative (Applicative((<*>), pure), (<$>)) import Control.DeepSeq (NFData(rnf))-import Data.Bits ((.&.), xor)+import Data.Bits (Bits(..), (.&.), xor) import qualified Data.Foldable as Foldable+import Data.Monoid (Monoid(mempty, mappend)) import Data.Traversable (Traversable(..)) import Data.Typeable (Typeable) import Data.Word (Word)@@ -43,19 +47,27 @@ -- | 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- = Nil- | Tip {-# UNPACK #-} !Hash- {-# UNPACK #-} !(FL.FullList k v)- | Bin {-# UNPACK #-} !Suffix- {-# UNPACK #-} !Mask+ = Bin {-# UNPACK #-} !SuffixMask !(HashMap k v) !(HashMap k v)+ | Tip {-# UNPACK #-} !Hash+ {-# UNPACK #-} !(FL.FullList k v)+ | Nil deriving (Show, Typeable) type Suffix = Int-type Mask = Int type Hash = Int +-- | A SuffixMask stores a path to a Bin node in the hash map. The+-- uppermost set bit, the Mask, indicates the bit used to distinguish+-- hashes in the left and right subtrees. The lower-order bits (below+-- the highest set bit), the Suffix, are set the same way in all the+-- hashes contained in this subtree of the map. Thus, hashes in the+-- right subtree will match all the bits in the SuffixMask, but may+-- have set bits above the Mask. Hashes in the left subtree will not+-- match the Mask bit, but will match all the Suffix bits.+type SuffixMask = Int+ ------------------------------------------------------------------------ -- * Instances @@ -67,15 +79,15 @@ t1 /= t2 = nequal t1 t2 equal :: (Eq k, Eq v) => HashMap k v -> HashMap k v -> Bool-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) =- (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Bin sm1 l1 r1) (Bin sm2 l2 r2) =+ (sm1 == sm2) && (equal l1 l2) && (equal r1 r2) equal (Tip h1 l1) (Tip h2 l2) = (h1 == h2) && (l1 == l2) equal Nil Nil = True equal _ _ = False nequal :: (Eq k, Eq v) => HashMap k v -> HashMap k v -> Bool-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) =- (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)+nequal (Bin sm1 l1 r1) (Bin sm2 l2 r2) =+ (sm1 /= sm2) || (nequal l1 l2) || (nequal r1 r2) nequal (Tip h1 l1) (Tip h2 l2) = (h1 /= h2) || (l1 /= l2) nequal Nil Nil = False nequal _ _ = True@@ -83,7 +95,7 @@ instance (NFData k, NFData v) => NFData (HashMap k v) where rnf Nil = () rnf (Tip _ xs) = rnf xs- rnf (Bin _ _ l r) = rnf l `seq` rnf r+ rnf (Bin _ l r) = rnf l `seq` rnf r instance Functor (HashMap k) where fmap = map@@ -92,9 +104,9 @@ map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2 map f = go where- go (Bin s m l r) = Bin s m (go l) (go r)- go (Tip h l) = Tip h (FL.map f' l)- go Nil = Nil+ go (Bin sm l r) = Bin sm (go l) (go r)+ go (Tip h l) = Tip h (FL.map f' l)+ go Nil = Nil f' k v = (k, f v) {-# INLINE map #-} @@ -107,21 +119,110 @@ foldrWithKey :: (k -> v -> a -> a) -> a -> HashMap k v -> a foldrWithKey f = go where- go z (Bin _ _ l r) = go (go z r) l- go z (Tip _ l) = FL.foldrWithKey f z l- go z Nil = z+ go z (Bin _ l r) = go (go z r) l+ go z (Tip _ l) = FL.foldrWithKey f z l+ go z Nil = z {-# INLINE foldrWithKey #-} +instance Eq k => Monoid (HashMap k v) where+ mempty = empty+ {-# INLINE mempty #-}+ mappend = union+ {-# INLINE mappend #-}++-- | /O(1)/ Construct an empty map.+empty :: HashMap k v+empty = Nil++-- | /O(n+m)/ The union of two maps. If a key occurs in both maps,+-- the mapping from the first will be the mapping in the result.+union :: Eq k => HashMap k v -> HashMap k v -> HashMap k v+union t1@(Bin sm1 l1 r1) t2@(Bin sm2 l2 r2)+ | sm1 == sm2 = Bin sm1 (union l1 l2) (union r1 r2)+ | shorter sm1 sm2 = union1+ | shorter sm2 sm1 = union2+ | otherwise = join sm1 t1 sm2 t2+ where+ union1 | nomatch sm2 sm1 = join sm1 t1 sm2 t2+ | zero sm2 sm1 = Bin sm1 (union l1 t2) r1+ | otherwise = Bin sm1 l1 (union r1 t2)++ union2 | nomatch sm1 sm2 = join sm1 t1 sm2 t2+ | zero sm1 sm2 = Bin sm2 (union t1 l2) r2+ | otherwise = Bin sm2 l2 (union t1 r2)+union (Tip h l) t = insertCollidingL h l t+union t (Tip h l) = insertCollidingR h l t -- right bias+union Nil t = t+union t Nil = t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE union #-}+#endif++-- | Insert a list of key-value pairs which keys all hash to the same+-- hash value. Prefer key-value pairs in the list to key-value pairs+-- already in the map.+insertCollidingL :: Eq k => Hash -> FL.FullList k v -> HashMap k v -> HashMap k v+insertCollidingL = insertCollidingWith FL.union+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertCollidingL #-}+#endif++-- | Insert a list of key-value pairs which keys all hash to the same+-- hash value. Prefer key-value pairs already in the map to key-value+-- pairs in the list.+insertCollidingR :: Eq k => Hash -> FL.FullList k v -> HashMap k v -> HashMap k v+insertCollidingR = insertCollidingWith (flip FL.union)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertCollidingR #-}+#endif++-- | Insert a list of key-value pairs which keys all hash to the same+-- hash value. Merge the list of key-value pairs to be inserted @xs@+-- with any existing key-values pairs @ys@ by applying @f xs ys@.+insertCollidingWith :: Eq k+ => (FL.FullList k v -> FL.FullList k v -> FL.FullList k v)+ -> Hash -> FL.FullList k v+ -> HashMap k v -> HashMap k v+insertCollidingWith f h0 l0 t0 = go h0 l0 t0+ where+ go !h !xs t@(Bin sm l r)+ | nomatch h sm = join h (Tip h xs) sm t+ | zero h sm = Bin sm (go h xs l) r+ | otherwise = Bin sm l (go h xs r)+ go h xs t@(Tip h' l)+ | h == h' = Tip h $ f xs l+ | otherwise = join h (Tip h xs) h' t+ go h xs Nil = Tip h xs+{-# INLINE insertCollidingWith #-}+ instance Traversable (HashMap k) where traverse f = traverseWithKey (const f) +-- | /O(n)/ Transform this map by applying a function to every value;+-- when f k v returns Just x, keep an entry mapping k to x, otherwise+-- do not include k in the result.+filterMapWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2+filterMapWithKey f = go+ where+ go (Bin sm l r) = bin sm (go l) (go r)+ go (Tip h vs) =+ case FL.foldrWithKey ff FL.Nil vs of+ FL.Nil -> Nil+ FL.Cons k v xs -> Tip h (FL.FL k v xs)+ go Nil = Nil+ ff k v xs =+ case f k v of+ Nothing -> xs+ Just x -> FL.Cons k x xs+{-# INLINE filterMapWithKey #-}+ -- | /O(n)/ Transform this map by accumulating an Applicative result -- from every value. traverseWithKey :: Applicative f => (k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2) traverseWithKey f = go where- go (Bin p m l r) = Bin p m <$> go l <*> go r+ go (Bin sm l r) = Bin sm <$> go l <*> go r go (Tip h l) = Tip h <$> FL.traverseWithKey f l go Nil = pure Nil {-# INLINE traverseWithKey #-}@@ -131,46 +232,82 @@ join :: Suffix -> HashMap k v -> Suffix -> HashMap k v -> HashMap k v join s1 t1 s2 t2- | zero s1 m = Bin s m t1 t2- | otherwise = Bin s m t2 t1+ | zero s1 sm = Bin sm t1 t2+ | otherwise = Bin sm t2 t1 where- m = branchMask s1 s2- s = mask s1 m+ sm = branchSuffixMask s1 s2 {-# INLINE join #-} -- | @bin@ assures that we never have empty trees within a tree.-bin :: Suffix -> Mask -> HashMap k v -> HashMap k v -> HashMap k v-bin _ _ l Nil = l-bin _ _ Nil r = r-bin p m l r = Bin p m l r+bin :: SuffixMask -> HashMap k v -> HashMap k v -> HashMap k v+bin _ l Nil = l+bin _ Nil r = r+bin sm l r = Bin sm l r {-# INLINE bin #-} ------------------------------------------------------------------------ -- Endian independent bit twiddling -zero :: Hash -> Mask -> Bool-zero i m = (fromIntegral i :: Word) .&. (fromIntegral m :: Word) == 0+-- Actually detects if every set bit of sm is set in i (and returns+-- false if so). In most cases, the Suffix will already match, and+-- this just tests the Mask. For lookup it can send us down the wrong+-- path, but that's OK; we'll detect this when we reach a Tip and+-- don't match. We could have checked (i .|. fromIntegral sm) /= i+-- instead.+zero :: Hash -> SuffixMask -> Bool+zero i sm = (i .&. smi) /= smi+ where smi = fromIntegral sm {-# INLINE zero #-} -nomatch :: Hash -> Suffix -> Mask -> Bool-nomatch i s m = (mask i m) /= s+-- We want to detect Suffix bits in the Hash that differ from+-- SuffixMask. To do this, we find the first bit that differs between+-- Hash and SuffixMask, then check if that bit is smaller than the+-- Mask bit. We do this by observing that if we set this bit and all+-- bits to its right, we'll obtain a number >= the suffixmask if all+-- bits are the same (cb == 0, setting all bits) or if the first bit of+-- difference is >= the Mask. Note: this comparison must be unsigned.+nomatch :: Hash -> SuffixMask -> Bool+nomatch i sm = (cb + cb - 1) < fromIntegral sm+ where cb = differentBit i (fromIntegral sm) {-# INLINE nomatch #-} -mask :: Hash -> Mask -> Suffix-mask i m = maskW (fromIntegral i :: Word) (fromIntegral m :: Word)-{-# INLINE mask #-}- ------------------------------------------------------------------------ -- Big endian operations -maskW :: Word -> Word -> Suffix-maskW i m = fromIntegral (i .&. (m-1))-{-# INLINE maskW #-}+-- | Compute the first (lowest-order) bit at which h1 and h2 differ.+-- This is the mask that distinguishes them.+differentBit :: Hash -> Hash -> Word+differentBit h1 h2 =+ fromIntegral (critBit (fromIntegral h1 `xor` fromIntegral h2)) -branchMask :: Suffix -> Suffix -> Mask-branchMask p1 p2 =- fromIntegral (critBit (fromIntegral p1 `xor` fromIntegral p2 :: Word))-{-# INLINE branchMask #-}+-- | Given mask bit m expressed as a word, compute the suffix bits of+-- hash i, also expressed as a word.+suffixW :: Word -> Word -> Word+suffixW i m = i .&. (m-1)+{-# INLINE suffixW #-}++-- | Given two hashes and/or SuffixMasks for which nomatch p1 p2 &&+-- nomatch p2 p1, compute SuffixMask that differentiates them, by+-- first computing the mask m and then using that to derive a suffix+-- from one of them (it won't matter which, as those bits are the+-- same).+branchSuffixMask :: Suffix -> Suffix -> SuffixMask+branchSuffixMask p1 p2 =+ fromIntegral (m + suffixW w1 m)+ where m = differentBit p1 p2+ w1 = fromIntegral p1+{-# INLINE branchSuffixMask #-}++-- | Is the mask of sm1 closer to the root of the tree (lower order)+-- than the mask of sm2? This is actually approximate, and returns+-- junk when both sm1 and sm2 are at the same tree level. This must+-- be disambiguated by first checking sm1==sm2, and subsequently by+-- checking nomatch in the appropriate direction (which will need to+-- happen anyway to determine if insertion or branching is+-- appropriate).+shorter :: SuffixMask -> SuffixMask -> Bool+shorter sm1 sm2 = (fromIntegral sm1 :: Word) < (fromIntegral sm2 :: Word)+{-# INLINE shorter #-} -- | Return a 'Word' whose single set bit corresponds to the lowest set bit of w. critBit :: Word -> Word
Data/HashMap/Lazy.hs view
@@ -45,6 +45,10 @@ , insertWith , adjust + -- * Combine+ -- ** Union+ , union+ -- * Transformations , map , traverseWithKey@@ -66,6 +70,7 @@ -- ** Lists , toList , fromList+ , fromListWith ) where import qualified Data.FullList.Lazy as FL@@ -91,9 +96,9 @@ size :: HashMap k v -> Int size t = go t 0 where- go (Bin _ _ l r) !sz = go r (go l sz)- go (Tip _ l) !sz = sz + FL.size l- go Nil !sz = sz+ go (Bin _ l r) !sz = go r (go l sz)+ go (Tip _ l) !sz = sz + FL.size l+ go Nil !sz = sz -- | /O(min(n,W))/ Return the value to which the specified key is -- mapped, or 'Nothing' if this map contains no mapping for the key.@@ -101,8 +106,8 @@ lookup k0 t = go h0 k0 t where h0 = hash k0- go !h !k (Bin _ m l r)- | zero h m = go h k l+ go !h !k (Bin sm l r)+ | zero h sm = go h k l | otherwise = go h k r go h k (Tip h' l) | h == h' = FL.lookup k l@@ -123,10 +128,6 @@ _ -> def {-# INLINE lookupDefault #-} --- | /O(1)/ Construct an empty map.-empty :: HashMap k v-empty = Nil- -- | /O(1)/ Construct a map with a single element. singleton :: Hashable k => k -> v -> HashMap k v singleton k v = Tip h $ FL.singleton k v@@ -142,14 +143,14 @@ insert k0 v0 t0 = go h0 k0 v0 t0 where h0 = hash k0- go !h !k v t@(Bin s m l r)- | nomatch h s m = join h (Tip h $ FL.singleton k v) s t- | zero h m = Bin s m (go h k v l) r- | otherwise = Bin s m l (go h k v r)+ go !h !k v t@(Bin sm l r)+ | nomatch h sm = join h (Tip h $ FL.singleton k v) sm t+ | zero h sm = Bin sm (go h k v l) r+ | otherwise = Bin sm l (go h k v r) go h k v t@(Tip h' l)- | h == h' = Tip h $ FL.insert k v l- | otherwise = join h (Tip h $ FL.singleton k v) h' t- go h k v Nil = Tip h $ FL.singleton k v+ | h == h' = Tip h $ FL.insert k v l+ | otherwise = join h (Tip h $ FL.singleton k v) h' t+ go h k v Nil = Tip h $ FL.singleton k v #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insert #-} #endif@@ -160,10 +161,10 @@ delete k0 = go h0 k0 where h0 = hash k0- go !h !k t@(Bin s m l r)- | nomatch h s m = t- | zero h m = bin s m (go h k l) r- | otherwise = bin s m l (go h k r)+ go !h !k t@(Bin sm l r)+ | nomatch h sm = t+ | zero h sm = bin sm (go h k l) r+ | otherwise = bin sm l (go h k r) go h k t@(Tip h' l) | h == h' = case FL.delete k l of Nothing -> Nil@@ -186,10 +187,10 @@ insertWith f k0 v0 t0 = go h0 k0 v0 t0 where h0 = hash k0- go !h !k v t@(Bin s m l r)- | nomatch h s m = join h (Tip h $ FL.singleton k v) s t- | zero h m = Bin s m (go h k v l) r- | otherwise = Bin s m l (go h k v r)+ go !h !k v t@(Bin sm l r)+ | nomatch h sm = join h (Tip h $ FL.singleton k v) sm t+ | zero h sm = Bin sm (go h k v l) r+ | otherwise = Bin sm l (go h k v r) go h k v t@(Tip h' l) | h == h' = Tip h $ FL.insertWith f k v l | otherwise = join h (Tip h $ FL.singleton k v) h' t@@ -204,14 +205,14 @@ adjust f k0 t0 = go h0 k0 t0 where h0 = hash k0- go !h !k t@(Bin p m l r)- | nomatch h p m = t- | zero h m = Bin p m (go h k l) r- | otherwise = Bin p m l (go h k r)+ go !h !k t@(Bin sm l r)+ | nomatch h sm = t+ | zero h sm = Bin sm (go h k l) r+ | otherwise = Bin sm l (go h k r) go h k t@(Tip h' l)- | h == h' = Tip h $ FL.adjust f k l- | otherwise = t- go _ _ Nil = Nil+ | h == h' = Tip h $ FL.adjust f k l+ | otherwise = t+ go _ _ Nil = Nil #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE adjust #-} #endif@@ -223,9 +224,9 @@ map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2 map f = go where- go (Bin s m l r) = Bin s m (go l) (go r)- go (Tip h l) = Tip h (FL.map f' l)- go Nil = Nil+ go (Bin sm l r) = Bin sm (go l) (go r)+ go (Tip h l) = Tip h (FL.map f' l)+ go Nil = Nil f' k v = (k, f v) {-# INLINE map #-} @@ -256,10 +257,10 @@ foldlWithKey' :: (a -> k -> v -> a) -> a -> HashMap k v -> a foldlWithKey' f = go where- go !z (Bin _ _ l r) = let z' = go z l- in z' `seq` go z' r- go z (Tip _ l) = FL.foldlWithKey' f z l- go z Nil = z+ go !z (Bin _ l r) = let z' = go z l+ in z' `seq` go z' r+ go z (Tip _ l) = FL.foldlWithKey' f z l+ go z Nil = z {-# INLINE foldlWithKey' #-} ------------------------------------------------------------------------@@ -270,11 +271,11 @@ filterWithKey :: (k -> v -> Bool) -> HashMap k v -> HashMap k v filterWithKey pred = go where- go (Bin s m l r) = bin s m (go l) (go r)- go (Tip h l) = case FL.filterWithKey pred l of+ go (Bin sm l r) = bin sm (go l) (go r)+ go (Tip h l) = case FL.filterWithKey pred l of Just l' -> Tip h l' Nothing -> Nil- go Nil = Nil+ go Nil = Nil {-# INLINE filterWithKey #-} -- | /O(n)/ Filter this map by retaining only elements which values@@ -300,6 +301,12 @@ fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v fromList = List.foldl' (\ m (k, v) -> insert k v m) empty {-# INLINE fromList #-}++-- | /O(n*min(W, n))/ Construct a map from a list of elements. Uses+-- the provided function to merge duplicate entries.+fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v+fromListWith f = List.foldl' (\ m (k, v) -> insertWith f k v m) empty+{-# INLINE fromListWith #-} -- | /O(n)/ Return a list of this map's keys. The list is produced -- lazily.
Data/HashMap/Lazy/Internal.hs view
@@ -29,7 +29,7 @@ collisions :: HashMap k v -> Int collisions t = go t 0 where- go (Bin _ _ l r) !sz = go r (go l sz)+ go (Bin _ l r) !sz = go r (go l sz) go (Tip _ l) !sz | fl_sz <= 1 = sz | otherwise = sz + fl_sz@@ -42,7 +42,7 @@ collisionHistogram :: HashMap k v -> HashMap Int Int collisionHistogram t = go t Nil where- go (Bin _ _ l r) h = go r (go l h)+ go (Bin _ l r) h = go r (go l h) go (Tip _ l) h = (insert sz $! maybe 1 (1+) (lookup sz h)) h where sz = FL.size l go Nil h = h
Data/HashMap/Strict.hs view
@@ -46,6 +46,10 @@ , insertWith , adjust + -- * Combine+ -- ** Union+ , union+ -- * Transformations , map , traverseWithKey@@ -67,6 +71,7 @@ -- ** Lists , toList , fromList+ , fromListWith ) where import Data.Hashable (Hashable(hash))@@ -74,7 +79,8 @@ import qualified Data.FullList.Strict as FL import Data.HashMap.Common-import Data.HashMap.Lazy hiding (fromList, insert, insertWith, adjust, map, singleton)+import Data.HashMap.Lazy hiding (fromList, fromListWith, insert, insertWith,+ adjust, map, singleton) import qualified Data.HashMap.Lazy as L import qualified Data.List as List @@ -93,14 +99,14 @@ insert k0 !v0 t0 = go h0 k0 v0 t0 where h0 = hash k0- go !h !k v t@(Bin s m l r)- | nomatch h s m = join h (Tip h $ FL.singleton k v) s t- | zero h m = Bin s m (go h k v l) r- | otherwise = Bin s m l (go h k v r)+ go !h !k v t@(Bin sm l r)+ | nomatch h sm = join h (Tip h $ FL.singleton k v) sm t+ | zero h sm = Bin sm (go h k v l) r+ | otherwise = Bin sm l (go h k v r) go h k v t@(Tip h' l)- | h == h' = Tip h $ FL.insert k v l- | otherwise = join h (Tip h $ FL.singleton k v) h' t- go h k v Nil = Tip h $ FL.singleton k v+ | h == h' = Tip h $ FL.insert k v l+ | otherwise = join h (Tip h $ FL.singleton k v) h' t+ go h k v Nil = Tip h $ FL.singleton k v #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insert #-} #endif@@ -117,14 +123,14 @@ insertWith f k0 !v0 t0 = go h0 k0 v0 t0 where h0 = hash k0- go !h !k v t@(Bin s m l r)- | nomatch h s m = join h (Tip h $ FL.singleton k v) s t- | zero h m = Bin s m (go h k v l) r- | otherwise = Bin s m l (go h k v r)+ go !h !k v t@(Bin sm l r)+ | nomatch h sm = join h (Tip h $ FL.singleton k v) sm t+ | zero h sm = Bin sm (go h k v l) r+ | otherwise = Bin sm l (go h k v r) go h k v t@(Tip h' l)- | h == h' = Tip h $ FL.insertWith f k v l- | otherwise = join h (Tip h $ FL.singleton k v) h' t- go h k v Nil = Tip h $ FL.singleton k v+ | h == h' = Tip h $ FL.insertWith f k v l+ | otherwise = join h (Tip h $ FL.singleton k v) h' t+ go h k v Nil = Tip h $ FL.singleton k v #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insertWith #-} #endif@@ -135,14 +141,14 @@ adjust f k0 t0 = go h0 k0 t0 where h0 = hash k0- go !h !k t@(Bin p m l r)- | nomatch h p m = t- | zero h m = Bin p m (go h k l) r- | otherwise = Bin p m l (go h k r)+ go !h !k t@(Bin sm l r)+ | nomatch h sm = t+ | zero h sm = Bin sm (go h k l) r+ | otherwise = Bin sm l (go h k r) go h k t@(Tip h' l)- | h == h' = Tip h $ FL.adjust f k l- | otherwise = t- go _ _ Nil = Nil+ | h == h' = Tip h $ FL.adjust f k l+ | otherwise = t+ go _ _ Nil = Nil #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE adjust #-} #endif@@ -155,9 +161,9 @@ map :: (v1 -> v2) -> HashMap k v1 -> HashMap k v2 map f = go where- go (Bin s m l r) = Bin s m (go l) (go r)- go (Tip h l) = Tip h (FL.map f' l)- go Nil = Nil+ go (Bin sm l r) = Bin sm (go l) (go r)+ go (Tip h l) = Tip h (FL.map f' l)+ go Nil = Nil f' k v = (k, f v) {-# INLINE map #-} @@ -168,3 +174,9 @@ fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v fromList = List.foldl' (\ m (k, v) -> insert k v m) empty {-# INLINE fromList #-}++-- | /O(n*min(W, n))/ Construct a map from a list of elements. Uses+-- the provided function to merge duplicate entries.+fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v+fromListWith f = List.foldl' (\ m (k, v) -> insertWith f k v m) empty+{-# INLINE fromListWith #-}
+ Data/HashSet.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE CPP #-}++------------------------------------------------------------------------+-- |+-- 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 /big-endian patricia trees/, indexed+-- by a hash of the original value. A 'HashSet' is often faster than+-- other tree-based set types, especially when value comparison is+-- expensive, as in the case of strings.+--+-- Many operations have a worst-case complexity of /O(min(n,W))/.+-- This means that the operation can become linear in the number of+-- elements with a maximum of /W/ -- the number of bits in an 'Int'+-- (32 or 64).++module Data.HashSet+ (+ HashSet++ -- * Construction+ , empty+ , singleton++ -- * Combine+ , union++ -- * Basic interface+ , null+ , size+ , member+ , insert+ , delete++ -- * Transformations+ , map++ -- * Folds+ , foldl'+ , foldr++ -- * Filter+ , filter++ -- ** Lists+ , toList+ , fromList+ ) where++import Control.DeepSeq (NFData(..))+import Data.HashMap.Common (HashMap, foldrWithKey)+import Data.Hashable (Hashable)+import Data.Monoid (Monoid(..))+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++#if defined(__GLASGOW_HASKELL__)+import GHC.Exts (build)+#endif++-- | A set of values. A set cannot contain duplicate values.+newtype HashSet a = HashSet {+ asMap :: HashMap a ()+ }++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 #-}++instance (Hashable a, Eq a) => Monoid (HashSet a) where+ mempty = empty+ {-# INLINE mempty #-}+ mappend = union+ {-# INLINE mappend #-}++-- | /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 ())+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE singleton #-}+#endif++-- | /O(n)/ Construct a set containing all elements from both sets.+union :: (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a+union s1 s2 = HashSet $ H.union (asMap s1) (asMap s2)+{-# INLINE union #-}++-- | /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+{-# INLINE 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+{-# INLINE 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+{-# INLINE 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+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE map #-}+#endif++-- | /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]+#if defined(__GLASGOW_HASKELL__)+toList t = build (\ c z -> foldrWithKey ((const .) c) z (asMap t))+#else+toList = foldrWithKey (\ k _ xs -> k : xs) [] . asMap+#endif+{-# 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 #-}
benchmarks/Benchmarks.hs view
@@ -34,6 +34,7 @@ let hm = HM.fromList elems :: HM.HashMap String Int hmbs = HM.fromList elemsBS :: HM.HashMap BS.ByteString Int hmi = HM.fromList elemsI :: HM.HashMap Int Int+ hmi2 = HM.fromList elemsI2 :: HM.HashMap Int Int m = M.fromList elems :: M.Map String Int mbs = M.fromList elemsBS :: M.Map BS.ByteString Int im = IM.fromList elemsI :: IM.IntMap Int@@ -71,6 +72,10 @@ [ bench "String" $ whnf M.size m , bench "ByteString" $ whnf M.size mbs ]+ , bgroup "fromList"+ [ bench "String" $ whnf M.fromList elems+ , bench "ByteString" $ whnf M.fromList elemsBS+ ] ] -- ** IntMap@@ -82,6 +87,7 @@ , bench "delete" $ whnf (deleteIM keysI) im , bench "delete-miss" $ whnf (deleteIM keysI') im , bench "size" $ whnf IM.size im+ , bench "fromList" $ whnf IM.fromList elemsI ] -- * Basic interface@@ -116,6 +122,9 @@ , bench "Int" $ whnf (delete keysI') hmi ] + -- Combine+ , bench "union" $ whnf (HM.union hmi) hmi2+ -- Transformations , bench "map" $ whnf (HM.map (\ v -> v + 1)) hmi @@ -133,6 +142,13 @@ , bench "ByteString" $ whnf HM.size hmbs , bench "Int" $ whnf HM.size hmi ]++ -- fromList+ , bgroup "fromList"+ [ bench "String" $ whnf HM.fromList elems+ , bench "ByteString" $ whnf HM.fromList elemsBS+ , bench "Int" $ whnf HM.fromList elemsI+ ] ] where n :: Int@@ -144,6 +160,7 @@ 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
+ tests/MapProperties.hs view
@@ -0,0 +1,205 @@+ {-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Tests for the 'Data.HashMap.Lazy' module. We test functions by+-- comparing them to a simpler model, an association list.++module Main (main) where++import qualified Data.Foldable as Foldable+import Data.Function (on)+import Data.Hashable (Hashable(hash))+import qualified Data.List as L+import qualified Data.HashMap.Lazy as M+import Test.QuickCheck (Arbitrary)+import Test.Framework (Test, defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)++-- Key type that generates more hash collisions.+newtype Key = K { unK :: Int }+ deriving (Arbitrary, Eq, Ord, Show)++instance Hashable Key where+ hash k = hash (unK k) `mod` 20++------------------------------------------------------------------------+-- * Properties++------------------------------------------------------------------------+-- ** Instances++pEq :: [(Key, Int)] -> [(Key, Int)] -> Bool+pEq xs ys = (as ==) `eq` (M.fromList as ==) $ bs+ where as = fromList xs+ bs = fromList ys++pNeq :: [(Key, Int)] -> [(Key, Int)] -> Bool+pNeq xs = (xs /=) `eq` (M.fromList xs /=)++pFunctor :: [(Key, Int)] -> Bool+pFunctor = fmap (\ (k, v) -> (k, v + 1)) `eq` (toAscList . fmap (+ 1))++pFoldable :: [(Int, Int)] -> Bool+pFoldable = (L.sort . Foldable.foldr (\ (_, v) z -> v:z) []) `eq`+ (L.sort . Foldable.foldr (:) [])++------------------------------------------------------------------------+-- ** Basic interface++pSize :: [(Key, Int)] -> Bool+pSize = length `eq` M.size++pLookup :: Key -> [(Key, Int)] -> Bool+pLookup k = L.lookup k `eq` M.lookup k++pInsert :: Key -> Int -> [(Key, Int)] -> Bool+pInsert k v = insert (k, v) `eq` (toAscList . M.insert k v)++pDelete :: Key -> [(Key, Int)] -> Bool+pDelete k = delete k `eq` (toAscList . M.delete k)++pInsertWith :: Key -> [(Key, Int)] -> Bool+pInsertWith k = insertWith (+) (k, 1) `eq`+ (toAscList . M.insertWith (+) k 1)++------------------------------------------------------------------------+-- ** Combine++pUnion :: [(Key, Int)] -> [(Key, Int)] -> Bool+pUnion xs ys = L.sort (unionByKey as bs) == + toAscList (M.union (M.fromList as) (M.fromList bs))+ where+ as = fromList xs+ bs = fromList ys++------------------------------------------------------------------------+-- ** Transformations++pMap :: [(Key, Int)] -> Bool+pMap = map (\ (k, v) -> (k, v + 1)) `eq` (toAscList . M.map (+ 1))++------------------------------------------------------------------------+-- ** Folds++pFoldr :: [(Int, Int)] -> Bool+pFoldr = (L.sort . L.foldr (\ (_, v) z -> v:z) []) `eq`+ (L.sort . M.foldr (:) [])++pFoldrWithKey :: [(Int, Int)] -> Bool+pFoldrWithKey = (sortByKey . L.foldr (:) []) `eq`+ (sortByKey . M.foldrWithKey f [])+ where f k v z = (k, v) : z++pFoldl' :: Int -> [(Int, Int)] -> Bool+pFoldl' z0 = L.foldl' (\ z (_, v) -> z + v) z0 `eq` M.foldl' (+) z0++------------------------------------------------------------------------+-- ** Conversions++pToList :: [(Key, Int)] -> Bool+pToList = id `eq` toAscList++pElems :: [(Key, Int)] -> Bool+pElems = (L.sort . map snd) `eq` (L.sort . M.elems)++pKeys :: [(Key, Int)] -> Bool+pKeys = map fst `eq` (L.sort . M.keys)++------------------------------------------------------------------------+-- * Test list++tests :: [Test]+tests =+ [+ -- Instances+ testGroup "instances"+ [ testProperty "==" pEq+ , testProperty "/=" pNeq+ , testProperty "Functor" pFunctor+ , testProperty "Foldable" pFoldable+ ]+ -- Basic interface+ , testGroup "basic interface"+ [ testProperty "size" pSize+ , testProperty "lookup" pLookup+ , testProperty "insert" pInsert+ , testProperty "delete" pDelete+ , testProperty "insertWith" pInsertWith+ ]+ -- Combine+ , testProperty "union" pUnion+ -- Transformations+ , testProperty "map" pMap+ -- Folds+ , testGroup "folds"+ [ testProperty "foldr" pFoldr+ , testProperty "foldrWithKey" pFoldrWithKey+ , testProperty "foldl'" pFoldl'+ ]+ -- Conversions+ , testGroup "conversions"+ [ testProperty "elems" pElems+ , testProperty "keys" pKeys+ , testProperty "toList" pToList+ ]+ ]++------------------------------------------------------------------------+-- * Model++-- Invariant: the list is sorted in ascending order, by key.+type Model k v = [(k, v)]++-- | Check that a function operating on a 'HashMap' is equivalent to+-- one operating on a 'Model'.+eq :: (Eq a, Eq k, Hashable k, Ord k)+ => (Model k v -> a) -- ^ Function that modifies a 'Model' in the same+ -- way+ -> (M.HashMap k v -> a) -- ^ Function that modified a 'HashMap'+ -> [(k, v)] -- ^ Initial content of the 'HashMap' and 'Model'+ -> Bool -- ^ True if the functions are equivalent+eq f g xs = g (M.fromList ys) == f ys+ where ys = fromList xs++insert :: Ord k => (k, v) -> Model k v -> Model k v+insert x [] = [x]+insert x@(k, _) (y@(k', _):xs)+ | k == k' = x : xs+ | k > k' = y : insert x xs+ | otherwise = x : y : xs++delete :: Ord k => k -> Model k v -> Model k v+delete _ [] = []+delete k ys@(y@(k', _):xs)+ | k == k' = xs+ | k > k' = y : delete k xs+ | otherwise = ys++insertWith :: Ord k => (v -> v -> v) -> (k, v) -> Model k v -> Model k v+insertWith _ x [] = [x]+insertWith f x@(k, v) (y@(k', v'):xs)+ | k == k' = (k', f v v') : xs+ | k > k' = y : insertWith f x xs+ | otherwise = x : y : xs++-- | Create a model from a list of key-value pairs. If the input+-- contains multiple entries for the same key, the latter one is used.+fromList :: Ord k => [(k, v)] -> Model k v+fromList = L.foldl' (\ m p -> insert p m) []++------------------------------------------------------------------------+-- * Test harness++main :: IO ()+main = defaultMain tests++------------------------------------------------------------------------+-- * Helpers++sortByKey :: Ord k => [(k, v)] -> [(k, v)]+sortByKey = L.sortBy (compare `on` fst)++unionByKey :: (Eq k, Eq v) => [(k, v)] -> [(k, v)] -> [(k, v)]+unionByKey = L.unionBy ((==) `on` fst)++toAscList :: (Ord k, Ord v) => M.HashMap k v -> [(k, v)]+toAscList = L.sort . M.toList
− tests/Properties.hs
@@ -1,188 +0,0 @@- {-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | Tests for the 'Data.HashMap.Lazy' module. We test functions by--- comparing them to a simpler model, an association list.--module Main (main) where--import qualified Data.Foldable as Foldable-import Data.Function (on)-import Data.Hashable (Hashable(hash))-import qualified Data.List as L-import qualified Data.HashMap.Lazy as M-import Test.QuickCheck (Arbitrary)-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)---- Key type that generates more hash collisions.-newtype Key = K { unK :: Int }- deriving (Arbitrary, Eq, Ord, Show)--instance Hashable Key where- hash k = hash (unK k) `mod` 20----------------------------------------------------------------------------- * Properties----------------------------------------------------------------------------- ** Instances--pEq :: [(Key, Int)] -> [(Key, Int)] -> Bool-pEq xs = (xs ==) `eq` (M.fromList xs ==)--pNeq :: [(Key, Int)] -> [(Key, Int)] -> Bool-pNeq xs = (xs /=) `eq` (M.fromList xs /=)--pFunctor :: [(Key, Int)] -> Bool-pFunctor = fmap (\ (k, v) -> (k, v + 1)) `eq` (toAscList . fmap (+ 1))--pFoldable :: [(Int, Int)] -> Bool-pFoldable = (L.sort . Foldable.foldr (\ (_, v) z -> v:z) []) `eq`- (L.sort . Foldable.foldr (:) [])----------------------------------------------------------------------------- ** Basic interface--pSize :: [(Key, Int)] -> Bool-pSize = length `eq` M.size--pLookup :: Key -> [(Key, Int)] -> Bool-pLookup k = L.lookup k `eq` M.lookup k--pInsert :: Key -> Int -> [(Key, Int)] -> Bool-pInsert k v = insert (k, v) `eq` (toAscList . M.insert k v)--pDelete :: Key -> [(Key, Int)] -> Bool-pDelete k = delete k `eq` (toAscList . M.delete k)--pInsertWith :: Key -> [(Key, Int)] -> Bool-pInsertWith k = insertWith (+) (k, 1) `eq`- (toAscList . M.insertWith (+) k 1)----------------------------------------------------------------------------- ** Transformations--pMap :: [(Key, Int)] -> Bool-pMap = map (\ (k, v) -> (k, v + 1)) `eq` (toAscList . M.map (+ 1))----------------------------------------------------------------------------- ** Folds--pFoldr :: [(Int, Int)] -> Bool-pFoldr = (L.sort . L.foldr (\ (_, v) z -> v:z) []) `eq`- (L.sort . M.foldr (:) [])--pFoldrWithKey :: [(Int, Int)] -> Bool-pFoldrWithKey = (sortByKey . L.foldr (:) []) `eq`- (sortByKey . M.foldrWithKey f [])- where f k v z = (k, v) : z--pFoldl' :: Int -> [(Int, Int)] -> Bool-pFoldl' z0 = L.foldl' (\ z (_, v) -> z + v) z0 `eq` M.foldl' (+) z0----------------------------------------------------------------------------- ** Conversions--pToList :: [(Key, Int)] -> Bool-pToList = id `eq` toAscList--pElems :: [(Key, Int)] -> Bool-pElems = (L.sort . map snd) `eq` (L.sort . M.elems)--pKeys :: [(Key, Int)] -> Bool-pKeys = map fst `eq` (L.sort . M.keys)----------------------------------------------------------------------------- * Test list--tests :: [Test]-tests =- [- -- Instances- testGroup "instances"- [ testProperty "==" pEq- , testProperty "/=" pNeq- , testProperty "Functor" pFunctor- , testProperty "Foldable" pFoldable- ]- -- Basic interface- , testGroup "basic interface"- [ testProperty "size" pSize- , testProperty "lookup" pLookup- , testProperty "insert" pInsert- , testProperty "delete" pDelete- , testProperty "insertWith" pInsertWith- ]- -- Transformations- , testProperty "map" pMap- -- Folds- , testGroup "folds"- [ testProperty "foldr" pFoldr- , testProperty "foldrWithKey" pFoldrWithKey- , testProperty "foldl'" pFoldl'- ]- -- Conversions- , testGroup "conversions"- [ testProperty "elems" pElems- , testProperty "keys" pKeys- , testProperty "toList" pToList- ]- ]----------------------------------------------------------------------------- * Model---- Invariant: the list is sorted in ascending order, by key.-type Model k v = [(k, v)]---- | Check that a function operating on a 'HashMap' is equivalent to--- one operating on a 'Model'.-eq :: (Eq a, Eq k, Hashable k, Ord k)- => (Model k v -> a) -- ^ Function that modifies a 'Model' in the same- -- way- -> (M.HashMap k v -> a) -- ^ Function that modified a 'HashMap'- -> [(k, v)] -- ^ Initial content of the 'HashMap' and 'Model'- -> Bool -- ^ True if the functions are equivalent-eq f g xs = g (M.fromList ys) == f ys- where ys = fromList xs--insert :: Ord k => (k, v) -> Model k v -> Model k v-insert x [] = [x]-insert x@(k, _) (y@(k', _):xs)- | k == k' = x : xs- | k > k' = y : insert x xs- | otherwise = x : y : xs--delete :: Ord k => k -> Model k v -> Model k v-delete _ [] = []-delete k ys@(y@(k', _):xs)- | k == k' = xs- | k > k' = y : delete k xs- | otherwise = ys--insertWith :: Ord k => (v -> v -> v) -> (k, v) -> Model k v -> Model k v-insertWith _ x [] = [x]-insertWith f x@(k, v) (y@(k', v'):xs)- | k == k' = (k', f v v') : xs- | k > k' = y : insertWith f x xs- | otherwise = x : y : xs---- | Create a model from a list of key-value pairs. If the input--- contains multiple entries for the same key, the latter one is used.-fromList :: Ord k => [(k, v)] -> Model k v-fromList = L.foldl' (\ m p -> insert p m) []----------------------------------------------------------------------------- * Test harness--main :: IO ()-main = defaultMain tests----------------------------------------------------------------------------- * Helpers--sortByKey :: Ord k => [(k, v)] -> [(k, v)]-sortByKey = L.sortBy (compare `on` fst)--toAscList :: Ord k => M.HashMap k v -> [(k, v)]-toAscList = sortByKey . M.toList
+ tests/SetProperties.hs view
@@ -0,0 +1,171 @@+ {-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Tests for the 'Data.HashSet' module. We test functions by+-- comparing them to a simpler model, a list.++module Main (main) where++import qualified Data.Foldable as Foldable+import Data.Hashable (Hashable(hash))+import qualified Data.List as L+import qualified Data.HashSet as S+import qualified Data.Set as Set+import Test.QuickCheck (Arbitrary)+import Test.Framework (Test, defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)++-- Key type that generates more hash collisions.+newtype Key = K { unK :: Int }+ deriving (Arbitrary, Eq, Ord, Show)++instance Hashable Key where+ hash k = hash (unK k) `mod` 20++------------------------------------------------------------------------+-- * Properties++------------------------------------------------------------------------+-- ** Instances++pEq :: [Key] -> [Key] -> Bool+pEq xs = (unique xs ==) `eq` (S.fromList xs ==)++pNeq :: [Key] -> [Key] -> Bool+pNeq xs = (unique xs /=) `eq` (S.fromList xs /=)++pFoldable :: [Int] -> Bool+pFoldable = (L.sort . Foldable.foldr (:) []) `eq`+ (L.sort . Foldable.foldr (:) [])++------------------------------------------------------------------------+-- ** Basic interface++pSize :: [Key] -> Bool+pSize = length `eq` S.size++pMember :: Key -> [Key] -> Bool+pMember k = L.elem k `eq` S.member k++pInsert :: Key -> [Key] -> Bool+pInsert a = insert a `eq` (toAscList . S.insert a)++pDelete :: Key -> [Key] -> Bool+pDelete a = delete a `eq` (toAscList . S.delete a)++------------------------------------------------------------------------+-- ** Combine++pUnion :: [Key] -> [Key] -> Bool+pUnion xs ys = L.sort (L.union as bs) ==+ toAscList (S.union (S.fromList as) (S.fromList bs))+ where+ as = fromList xs+ bs = fromList ys++------------------------------------------------------------------------+-- ** Transformations++pMap :: [Key] -> Bool+pMap = map f `eq` (toAscList . S.map f)+ where f (K k) = K (k + 1)++------------------------------------------------------------------------+-- ** Folds++pFoldr :: [Int] -> Bool+pFoldr = (L.sort . L.foldr (:) []) `eq`+ (L.sort . S.foldr (:) [])++pFoldl' :: Int -> [Int] -> Bool+pFoldl' z0 = L.foldl' (+) z0 `eq` S.foldl' (+) z0++------------------------------------------------------------------------+-- ** Conversions++pToList :: [Key] -> Bool+pToList = id `eq` toAscList++------------------------------------------------------------------------+-- * Test list++tests :: [Test]+tests =+ [+ -- Instances+ testGroup "instances"+ [ testProperty "==" pEq+ , testProperty "/=" pNeq+ , testProperty "Foldable" pFoldable+ ]+ -- Basic interface+ , testGroup "basic interface"+ [ testProperty "size" pSize+ , testProperty "member" pMember+ , testProperty "insert" pInsert+ , testProperty "delete" pDelete+ ]+ -- Combine+ , testProperty "union" pUnion+ -- Transformations+ , testProperty "map" pMap+ -- Folds+ , testGroup "folds"+ [ testProperty "foldr" pFoldr+ , testProperty "foldl'" pFoldl'+ ]+ -- Conversions+ , testGroup "conversions"+ [ testProperty "toList" pToList+ ]+ ]++------------------------------------------------------------------------+-- * Model++-- Invariant: the list is sorted in ascending order, by key.+type Model a = [a]++-- | Check that a function operating on a 'HashMap' is equivalent to+-- one operating on a 'Model'.+eq :: (Eq a, Hashable a, Ord a, Eq b)+ => (Model a -> b) -- ^ Function that modifies a 'Model' in the same+ -- way+ -> (S.HashSet a -> b) -- ^ Function that modified a 'HashSet'+ -> [a] -- ^ Initial content of the 'HashSet' and 'Model'+ -> Bool -- ^ True if the functions are equivalent+eq f g xs = g (S.fromList ys) == f ys+ where ys = fromList xs++insert :: Ord a => a -> Model a -> Model a+insert x [] = [x]+insert x (y:xs)+ | x == y = x : xs+ | x > y = y : insert x xs+ | otherwise = x : y : xs++delete :: Ord a => a -> Model a -> Model a+delete _ [] = []+delete k ys@(y:xs)+ | k == y = xs+ | k > y = y : delete k xs+ | otherwise = ys++-- | Create a model from a list of key-value pairs. If the input+-- contains multiple entries for the same key, the latter one is used.+fromList :: Ord a => [a] -> Model a+fromList = L.foldl' (\ m p -> insert p m) []++------------------------------------------------------------------------+-- * Test harness++main :: IO ()+main = defaultMain tests++------------------------------------------------------------------------+-- * Helpers++toAscList :: Ord a => S.HashSet a -> [a]+toAscList = L.sort . S.toList++unique :: (Eq a, Ord a) => [a] -> [a]+unique = Set.toList . Set.fromList
unordered-containers.cabal view
@@ -1,5 +1,5 @@ name: unordered-containers-version: 0.1.2.0+version: 0.1.3.0 synopsis: Efficient hashing-based container types description: Efficient hashing-based container types. The containers have been@@ -13,20 +13,26 @@ author: Johan Tibell <johan.tibell@gmail.com> maintainer: johan.tibell@gmail.com bug-reports: https://github.com/tibbe/unordered-containers/issues-copyright: (c) 2010-2011 Johan Tibell+copyright: (c) Daan Leijen 2002+ (c) Andriy Palamarchuk 2008+ (c) 2010-2011 Johan Tibell category: Data build-type: Simple cabal-version: >=1.8 -- The test files shouldn't have to go here, but the source files for -- the test-suite stanzas don't get picked up by `cabal sdist`. Extra-source-files:- tests/Properties.hs, benchmarks/Benchmarks.hs benchmarks/Makefile+ tests/MapProperties.hs+ tests/SetProperties.hs+ benchmarks/Benchmarks.hs+ benchmarks/Makefile benchmarks/Util/*.hs library exposed-modules: Data.HashMap.Lazy Data.HashMap.Strict+ Data.HashSet build-depends: base < 4.4,@@ -46,21 +52,38 @@ if impl(ghc > 6.10) ghc-options: -fregs-graph --- -- Commented out until cabal-install release.--- test-suite properties--- hs-source-dirs: tests--- main-is: Properties.hs--- type: exitcode-stdio-1.0+-- Commented out until cabal-install release.+test-suite map-properties+ hs-source-dirs: tests+ main-is: MapProperties.hs+ type: exitcode-stdio-1.0 --- build-depends:--- base,--- hashable >= 1.0.1.1 && < 1.2,--- QuickCheck >= 2.4.0.1,--- test-framework >= 0.3.3 && < 0.4,--- test-framework-quickcheck2 >= 0.2.9 && < 0.3,--- unordered-containers+ build-depends:+ base,+ hashable >= 1.0.1.1 && < 1.2,+ QuickCheck >= 2.4.0.1,+ test-framework >= 0.3.3 && < 0.4,+ test-framework-quickcheck2 >= 0.2.9 && < 0.3,+ unordered-containers --- ghc-options: -Wall+ ghc-options: -Wall+++test-suite set-properties+ hs-source-dirs: tests+ main-is: SetProperties.hs+ type: exitcode-stdio-1.0++ build-depends:+ base,+ containers,+ hashable >= 1.0.1.1 && < 1.2,+ QuickCheck >= 2.4.0.1,+ test-framework >= 0.3.3 && < 0.4,+ test-framework-quickcheck2 >= 0.2.9 && < 0.3,+ unordered-containers++ ghc-options: -Wall source-repository head type: git