diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,23 @@ +## [0.2.17.0] + +* [Define `dataCast1` for `HashMap`](https://github.com/haskell-unordered-containers/unordered-containers/pull/345) + +* [Add `Lift` instances for Template Haskell](https://github.com/haskell-unordered-containers/unordered-containers/pull/343) + +* [Add definitions for `stimes`](https://github.com/haskell-unordered-containers/unordered-containers/pull/340) + +* [Expose internal constructors for `HashSet`, `Array` and `MArray`](https://github.com/haskell-unordered-containers/unordered-containers/pull/347) + +* [Tweak internal `Array.insertM` function](https://github.com/haskell-unordered-containers/unordered-containers/pull/359) + +* [Drop support for GHC 8.0](https://github.com/haskell-unordered-containers/unordered-containers/pull/354) + +* [Drop support for `hashable < 1.2.5`](https://github.com/haskell-unordered-containers/unordered-containers/pull/355) + +* Various cleanup and documentation improvements + +[0.2.17.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.16.0...v0.2.17.0 + ## [0.2.16.0] * [Increase maximum branching factor from 16 to 32](https://github.com/haskell-unordered-containers/unordered-containers/pull/317) diff --git a/Data/HashMap/Internal.hs b/Data/HashMap/Internal.hs --- a/Data/HashMap/Internal.hs +++ b/Data/HashMap/Internal.hs @@ -1,14 +1,17 @@ -{-# LANGUAGE BangPatterns, CPP, DeriveDataTypeable, MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE LambdaCase #-} -#if __GLASGOW_HASKELL__ >= 802 -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE UnboxedSums #-} -#endif +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} {-# OPTIONS_HADDOCK not-home #-} @@ -137,49 +140,36 @@ , adjust# ) where -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup (Semigroup((<>))) -#endif -import Control.DeepSeq (NFData(rnf)) -import Control.Monad.ST (ST, runST) -import Data.Bits ((.&.), (.|.), complement, popCount, unsafeShiftL, unsafeShiftR) -import Data.Data hiding (Typeable) -import qualified Data.Foldable as Foldable -#if MIN_VERSION_base(4,10,0) -import Data.Bifoldable -#endif -import qualified Data.List as L -import GHC.Exts ((==#), build, reallyUnsafePtrEquality#, inline) -import Prelude hiding (filter, foldl, foldr, lookup, map, null, pred) -import Text.Read hiding (step) - -import qualified Data.HashMap.Internal.Array as A -import qualified Data.Hashable as H -import Data.Hashable (Hashable) +import Control.Applicative (Const (..)) +import Control.DeepSeq (NFData (..), NFData1 (..), NFData2 (..)) +import Control.Monad.ST (ST, runST) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bits (complement, popCount, unsafeShiftL, + unsafeShiftR, (.&.), (.|.)) +import Data.Coerce (coerce) +import Data.Data (Constr, Data (..), DataType) +import Data.Functor.Classes (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), + Read1 (..), Show1 (..), Show2 (..)) +import Data.Functor.Identity (Identity (..)) import Data.HashMap.Internal.List (isPermutationBy, unorderedCompare) -import Data.Typeable (Typeable) - -import GHC.Exts (isTrue#) -import qualified GHC.Exts as Exts - -import Data.Functor.Classes -import GHC.Stack - -#if MIN_VERSION_hashable(1,2,5) -import qualified Data.Hashable.Lifted as H -#endif - -#if MIN_VERSION_deepseq(1,4,3) -import qualified Control.DeepSeq as NF -#endif - -#if __GLASGOW_HASKELL__ >= 802 -import GHC.Exts (TYPE, Int (..), Int#) -#endif +import Data.Hashable (Hashable) +import Data.Hashable.Lifted (Hashable1, Hashable2) +import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid) +import GHC.Exts (Int (..), Int#, TYPE, (==#)) +import GHC.Stack (HasCallStack) +import Prelude hiding (filter, foldl, foldr, lookup, map, + null, pred) +import Text.Read hiding (step) -import Data.Functor.Identity (Identity (..)) -import Control.Applicative (Const (..)) -import Data.Coerce (coerce) +import qualified Data.Data as Data +import qualified Data.Foldable as Foldable +import qualified Data.Functor.Classes as FC +import qualified Data.HashMap.Internal.Array as A +import qualified Data.Hashable as H +import qualified Data.Hashable.Lifted as H +import qualified Data.List as List +import qualified GHC.Exts as Exts +import qualified Language.Haskell.TH.Syntax as TH -- | A set of values. A set cannot contain duplicate values. ------------------------------------------------------------------------ @@ -194,15 +184,21 @@ instance (NFData k, NFData v) => NFData (Leaf k v) where rnf (L k v) = rnf k `seq` rnf v -#if MIN_VERSION_deepseq(1,4,3) +-- | @since 0.2.17.0 +instance (TH.Lift k, TH.Lift v) => TH.Lift (Leaf k v) where +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped (L k v) = [|| L k $! v ||] +#else + lift (L k v) = [| L k $! v |] +#endif + -- | @since 0.2.14.0 -instance NFData k => NF.NFData1 (Leaf k) where - liftRnf rnf2 = NF.liftRnf2 rnf rnf2 +instance NFData k => NFData1 (Leaf k) where + liftRnf rnf2 = liftRnf2 rnf rnf2 -- | @since 0.2.14.0 -instance NF.NFData2 Leaf where +instance NFData2 Leaf where liftRnf2 rnf1 rnf2 (L k v) = rnf1 k `seq` rnf2 v -#endif -- Invariant: The length of the 1st argument to 'Full' is -- 2^bitsPerSubkey @@ -215,10 +211,12 @@ | Leaf !Hash !(Leaf k v) | Full !(A.Array (HashMap k v)) | Collision !Hash !(A.Array (Leaf k v)) - deriving (Typeable) type role HashMap nominal representational +-- | @since 0.2.17.0 +deriving instance (TH.Lift k, TH.Lift v) => TH.Lift (HashMap k v) + instance (NFData k, NFData v) => NFData (HashMap k v) where rnf Empty = () rnf (BitmapIndexed _ ary) = rnf ary @@ -226,19 +224,17 @@ rnf (Full ary) = rnf ary rnf (Collision _ ary) = rnf ary -#if MIN_VERSION_deepseq(1,4,3) -- | @since 0.2.14.0 -instance NFData k => NF.NFData1 (HashMap k) where - liftRnf rnf2 = NF.liftRnf2 rnf rnf2 +instance NFData k => NFData1 (HashMap k) where + liftRnf rnf2 = liftRnf2 rnf rnf2 -- | @since 0.2.14.0 -instance NF.NFData2 HashMap where +instance NFData2 HashMap where liftRnf2 _ _ Empty = () - liftRnf2 rnf1 rnf2 (BitmapIndexed _ ary) = NF.liftRnf (NF.liftRnf2 rnf1 rnf2) ary - liftRnf2 rnf1 rnf2 (Leaf _ l) = NF.liftRnf2 rnf1 rnf2 l - liftRnf2 rnf1 rnf2 (Full ary) = NF.liftRnf (NF.liftRnf2 rnf1 rnf2) ary - liftRnf2 rnf1 rnf2 (Collision _ ary) = NF.liftRnf (NF.liftRnf2 rnf1 rnf2) ary -#endif + liftRnf2 rnf1 rnf2 (BitmapIndexed _ ary) = liftRnf (liftRnf2 rnf1 rnf2) ary + liftRnf2 rnf1 rnf2 (Leaf _ l) = liftRnf2 rnf1 rnf2 l + liftRnf2 rnf1 rnf2 (Full ary) = liftRnf (liftRnf2 rnf1 rnf2) ary + liftRnf2 rnf1 rnf2 (Collision _ ary) = liftRnf (liftRnf2 rnf1 rnf2) ary instance Functor (HashMap k) where fmap = map @@ -259,7 +255,6 @@ length = size {-# INLINE length #-} -#if MIN_VERSION_base(4,10,0) -- | @since 0.2.11 instance Bifoldable HashMap where bifoldMap f g = foldMapWithKey (\ k v -> f k `mappend` g v) @@ -268,7 +263,6 @@ {-# INLINE bifoldr #-} bifoldl f g = foldlWithKey (\ acc k v -> (acc `f` k) `g` v) {-# INLINE bifoldl #-} -#endif -- | '<>' = 'union' -- @@ -281,6 +275,8 @@ instance (Eq k, Hashable k) => Semigroup (HashMap k v) where (<>) = union {-# INLINE (<>) #-} + stimes = stimesIdempotentMonoid + {-# INLINE stimes #-} -- | 'mempty' = 'empty' -- @@ -301,17 +297,18 @@ 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 + gunfold k z c = case Data.constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" dataTypeOf _ = hashMapDataType - dataCast2 f = gcast2 f + dataCast1 f = Data.gcast1 f + dataCast2 f = Data.gcast2 f fromListConstr :: Constr -fromListConstr = mkConstr hashMapDataType "fromList" [] Prefix +fromListConstr = Data.mkConstr hashMapDataType "fromList" [] Data.Prefix hashMapDataType :: DataType -hashMapDataType = mkDataType "Data.HashMap.Internal.HashMap" [fromListConstr] +hashMapDataType = Data.mkDataType "Data.HashMap.Internal.HashMap" [fromListConstr] type Hash = Word type Bitmap = Word @@ -319,7 +316,7 @@ instance Show2 HashMap where liftShowsPrec2 spk slk spv slv d m = - showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) + FC.showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) where sp = liftShowsPrec2 spk slk spv slv sl = liftShowList2 spk slk spv slv @@ -328,8 +325,8 @@ liftShowsPrec = liftShowsPrec2 showsPrec showList instance (Eq k, Hashable k, Read k) => Read1 (HashMap k) where - liftReadsPrec rp rl = readsData $ - readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList + liftReadsPrec rp rl = FC.readsData $ + FC.readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList where rp' = liftReadsPrec rp rl rl' = liftReadList rp rl @@ -452,7 +449,7 @@ leafCompare (L k v) (L k' v') = cmpk k k' `mappend` cmpv v v' --- Same as 'equal' but doesn't compare the values. +-- Same as 'equal2' but doesn't compare the values. equalKeys1 :: (k -> k' -> Bool) -> HashMap k v -> HashMap k' v' -> Bool equalKeys1 eq t1 t2 = go (toList' t1 []) (toList' t2 []) where @@ -484,8 +481,7 @@ leafEq (L k1 _) (L k2 _) = k1 == k2 -#if MIN_VERSION_hashable(1,2,5) -instance H.Hashable2 HashMap where +instance Hashable2 HashMap where liftHashWithSalt2 hk hv salt hm = go salt (toList' hm []) where -- go :: Int -> [HashMap k v] -> Int @@ -503,14 +499,13 @@ -- hashCollisionWithSalt :: Int -> A.Array (Leaf k v) -> Int hashCollisionWithSalt s - = L.foldl' H.hashWithSalt s . arrayHashesSorted s + = List.foldl' H.hashWithSalt s . arrayHashesSorted s -- arrayHashesSorted :: Int -> A.Array (Leaf k v) -> [Int] - arrayHashesSorted s = L.sort . L.map (hashLeafWithSalt s) . A.toList + arrayHashesSorted s = List.sort . List.map (hashLeafWithSalt s) . A.toList -instance (Hashable k) => H.Hashable1 (HashMap k) where +instance (Hashable k) => Hashable1 (HashMap k) where liftHashWithSalt = H.liftHashWithSalt2 H.hashWithSalt -#endif instance (Hashable k, Hashable v) => Hashable (HashMap k v) where hashWithSalt salt hm = go salt hm @@ -531,10 +526,10 @@ hashCollisionWithSalt :: Int -> A.Array (Leaf k v) -> Int hashCollisionWithSalt s - = L.foldl' H.hashWithSalt s . arrayHashesSorted s + = List.foldl' H.hashWithSalt s . arrayHashesSorted s arrayHashesSorted :: Int -> A.Array (Leaf k v) -> [Int] - arrayHashesSorted s = L.sort . L.map (hashLeafWithSalt s) . A.toList + arrayHashesSorted s = List.sort . List.map (hashLeafWithSalt s) . A.toList -- Helper to get 'Leaf's and 'Collision's as a list. toList' :: HashMap k v -> [HashMap k v] -> [HashMap k v] @@ -590,7 +585,6 @@ -- | /O(log n)/ Return the value to which the specified key is mapped, -- or 'Nothing' if this map contains no mapping for the key. lookup :: (Eq k, Hashable k) => k -> HashMap k v -> Maybe v -#if __GLASGOW_HASKELL__ >= 802 -- GHC does not yet perform a worker-wrapper transformation on -- unboxed sums automatically. That seems likely to happen at some -- point (possibly as early as GHC 8.6) but for now we do it manually. @@ -603,16 +597,9 @@ lookup# k m = lookupCont (\_ -> (# (# #) | #)) (\v _i -> (# | v #)) (hash k) k 0 m {-# INLINABLE lookup# #-} -#else - -lookup k m = lookupCont (\_ -> Nothing) (\v _i -> Just v) (hash k) k 0 m -{-# INLINABLE lookup #-} -#endif - -- | lookup' is a version of lookup that takes the hash separately. -- It is used to implement alterF. lookup' :: Eq k => Hash -> k -> HashMap k v -> Maybe v -#if __GLASGOW_HASKELL__ >= 802 -- GHC does not yet perform a worker-wrapper transformation on -- unboxed sums automatically. That seems likely to happen at some -- point (possibly as early as GHC 8.6) but for now we do it manually. @@ -623,10 +610,6 @@ (# (# #) | #) -> Nothing (# | (# a, _i #) #) -> Just a {-# INLINE lookup' #-} -#else -lookup' h k m = lookupCont (\_ -> Nothing) (\v _i -> Just v) h k 0 m -{-# INLINABLE lookup' #-} -#endif -- The result of a lookup, keeping track of if a hash collision occured. -- If a collision did not occur then it will have the Int value (-1). @@ -646,7 +629,6 @@ -- Key in map, no collision => Present v (-1) -- Key in map, collision => Present v position lookupRecordCollision :: Eq k => Hash -> k -> HashMap k v -> LookupRes v -#if __GLASGOW_HASKELL__ >= 802 lookupRecordCollision h k m = case lookupRecordCollision# h k m of (# (# #) | #) -> Absent (# | (# a, i #) #) -> Present a (I# i) -- GHC will eliminate the I# @@ -663,12 +645,6 @@ -- INLINABLE to specialize to the Eq instance. {-# INLINABLE lookupRecordCollision# #-} -#else /* GHC < 8.2 so there are no unboxed sums */ - -lookupRecordCollision h k m = lookupCont (\_ -> Absent) Present h k 0 m -{-# INLINABLE lookupRecordCollision #-} -#endif - -- A two-continuation version of lookupRecordCollision. This lets us -- share source code between lookup and lookupRecordCollision without -- risking any performance degradation. @@ -682,11 +658,7 @@ -- keys at the top-level of a hashmap, the offset should be 0. When looking up -- keys at level @n@ of a hashmap, the offset should be @n * bitsPerSubkey@. lookupCont :: -#if __GLASGOW_HASKELL__ >= 802 forall rep (r :: TYPE rep) k v. -#else - forall r k v. -#endif Eq k => ((# #) -> r) -- Absent continuation -> (v -> Int -> r) -- Present continuation @@ -1435,7 +1407,7 @@ -- -- @since 0.2.12 isSubmapOf :: (Eq k, Hashable k, Eq v) => HashMap k v -> HashMap k v -> Bool -isSubmapOf = (inline isSubmapOfBy) (==) +isSubmapOf = (Exts.inline isSubmapOfBy) (==) {-# INLINABLE isSubmapOf #-} -- | /O(n*log m)/ Inclusion of maps with value comparison. A map is included in @@ -1677,7 +1649,7 @@ -- | 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 +unions = List.foldl' union empty {-# INLINE unions #-} @@ -2045,13 +2017,13 @@ -- | /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 +keys = List.map fst . toList {-# INLINE keys #-} -- | /O(n)/ Return a list of this map's values. The list is produced -- lazily. elems :: HashMap k v -> [v] -elems = L.map snd . toList +elems = List.map snd . toList {-# INLINE elems #-} ------------------------------------------------------------------------ @@ -2060,13 +2032,13 @@ -- | /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) +toList t = Exts.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 +fromList = List.foldl' (\ m (k, v) -> unsafeInsert k v m) empty {-# INLINABLE fromList #-} -- | /O(n*log n)/ Construct a map from a list of elements. Uses @@ -2100,7 +2072,7 @@ -- > fromListWith f [(k, a), (k, b), (k, c), (k, d)] -- > = fromList [(k, f d (f c (f b a)))] fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v -fromListWith f = L.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty +fromListWith f = List.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty {-# INLINE fromListWith #-} -- | /O(n*log n)/ Construct a map from a list of elements. Uses @@ -2130,7 +2102,7 @@ -- -- @since 0.2.11 fromListWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> [(k, v)] -> HashMap k v -fromListWithKey f = L.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) empty +fromListWithKey f = List.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) empty {-# INLINE fromListWithKey #-} ------------------------------------------------------------------------ @@ -2139,11 +2111,7 @@ -- | /O(n)/ Look up the value associated with the given key in an -- array. lookupInArrayCont :: -#if __GLASGOW_HASKELL__ >= 802 forall rep (r :: TYPE rep) k v. -#else - forall r k v. -#endif Eq k => ((# #) -> r) -> (v -> Int -> r) -> k -> A.Array (Leaf k v) -> r lookupInArrayCont absent present k0 ary0 = go k0 ary0 0 (A.length ary0) where @@ -2311,7 +2279,7 @@ -- | Check if two the two arguments are the same value. N.B. This -- function might give false negatives (due to GC moving objects.) ptrEq :: a -> a -> Bool -ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y ==# 1#) +ptrEq x y = Exts.isTrue# (Exts.reallyUnsafePtrEquality# x y ==# 1#) {-# INLINE ptrEq #-} ------------------------------------------------------------------------ diff --git a/Data/HashMap/Internal/Array.hs b/Data/HashMap/Internal/Array.hs --- a/Data/HashMap/Internal/Array.hs +++ b/Data/HashMap/Internal/Array.hs @@ -1,4 +1,10 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, UnboxedTuples, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} {-# OPTIONS_HADDOCK not-home #-} @@ -20,8 +26,8 @@ -- -- Note that no bounds checking are performed. module Data.HashMap.Internal.Array - ( Array - , MArray + ( Array(..) + , MArray(..) -- * Creation , new @@ -69,31 +75,32 @@ , traverse' , toList , fromList + , fromList' ) where import Control.Applicative (liftA2) -import Control.DeepSeq (NFData (..)) -import GHC.Exts(Int(..), reallyUnsafePtrEquality#, tagToEnum#, unsafeCoerce#) -import GHC.ST (ST(..)) -import Control.Monad.ST (runST, stToIO) - -import Prelude hiding (filter, foldMap, foldr, foldl, length, map, read, traverse, all) - -import GHC.Exts (SmallArray#, newSmallArray#, readSmallArray#, writeSmallArray#, - indexSmallArray#, unsafeFreezeSmallArray#, unsafeThawSmallArray#, - SmallMutableArray#, sizeofSmallArray#, copySmallArray#, thawSmallArray#, - sizeofSmallMutableArray#, copySmallMutableArray#, cloneSmallMutableArray#) +import Control.DeepSeq (NFData (..), NFData1 (..)) +import Control.Monad ((>=>)) +import Control.Monad.ST (runST, stToIO) +import GHC.Exts (Int (..), SmallArray#, SmallMutableArray#, + cloneSmallMutableArray#, copySmallArray#, + copySmallMutableArray#, indexSmallArray#, + newSmallArray#, readSmallArray#, + reallyUnsafePtrEquality#, sizeofSmallArray#, + sizeofSmallMutableArray#, tagToEnum#, + thawSmallArray#, unsafeCoerce#, + unsafeFreezeSmallArray#, unsafeThawSmallArray#, + writeSmallArray#) +import GHC.ST (ST (..)) +import Prelude hiding (all, filter, foldMap, foldl, foldr, length, + map, read, traverse) +import qualified Language.Haskell.TH.Syntax as TH #if defined(ASSERTS) import qualified Prelude #endif -#if MIN_VERSION_deepseq(1,4,3) -import qualified Control.DeepSeq as NF -#endif -import Control.Monad ((>=>)) - #if defined(ASSERTS) -- This fugly hack is brought by GHC's apparent reluctance to deal -- with MagicHash and UnboxedTuples when inferring types. Eek! @@ -169,9 +176,8 @@ -- relevant rnf is strict, or in case it actually isn't. {-# INLINE rnfArray #-} -#if MIN_VERSION_deepseq(1,4,3) -- | @since 0.2.14.0 -instance NF.NFData1 Array where +instance NFData1 Array where liftRnf = liftRnfArray liftRnfArray :: (a -> ()) -> Array a -> () @@ -183,7 +189,6 @@ | (# x #) <- index# ary i = rnf0 x `seq` go ary n (i+1) {-# INLINE liftRnfArray #-} -#endif -- | Create a new mutable array of specified size, in the specified -- state thread, with each element containing the specified initial @@ -303,9 +308,8 @@ insertM :: Array e -> Int -> e -> ST s (Array e) insertM ary idx b = CHECK_BOUNDS("insertM", count + 1, idx) - do mary <- new_ (count+1) + do mary <- new (count+1) b copy ary 0 mary 0 idx - write mary idx b copy ary idx mary (idx+1) (count-idx) unsafeFreeze mary where !count = length ary @@ -473,6 +477,28 @@ go [] !mary !_ = return mary go (x:xs) mary i = do write mary i x go xs mary (i+1) + +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) + +-- | @since 0.2.17.0 +instance TH.Lift a => TH.Lift (Array a) where +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped ar = [|| fromList' arlen arlist ||] +#else + lift ar = [| fromList' arlen arlist |] +#endif + where + arlen = length ar + arlist = toList ar toList :: Array a -> [a] toList = foldr (:) [] diff --git a/Data/HashMap/Internal/List.hs b/Data/HashMap/Internal/List.hs --- a/Data/HashMap/Internal/List.hs +++ b/Data/HashMap/Internal/List.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} {-# OPTIONS_HADDOCK not-home #-} @@ -25,10 +26,11 @@ , unorderedCompare ) where +import Data.List (sortBy) import Data.Maybe (fromMaybe) -import Data.List (sortBy) -import Data.Monoid -import Prelude +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup ((<>)) +#endif -- Note: previous implemenation isPermutation = null (as // bs) -- was O(n^2) too. @@ -68,7 +70,7 @@ go [] [] = EQ go [] (_ : _) = LT go (_ : _) [] = GT - go (x : xs) (y : ys) = c x y `mappend` go xs ys + go (x : xs) (y : ys) = c x y <> go xs ys cmpA a a' = compare (inB a) (inB a') cmpB b b' = compare (inA b) (inA b') diff --git a/Data/HashMap/Internal/Strict.hs b/Data/HashMap/Internal/Strict.hs --- a/Data/HashMap/Internal/Strict.hs +++ b/Data/HashMap/Internal/Strict.hs @@ -1,6 +1,9 @@ -{-# LANGUAGE BangPatterns, CPP, PatternGuards, MagicHash, UnboxedTuples #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} ------------------------------------------------------------------------ @@ -118,24 +121,23 @@ , fromListWithKey ) where -import Control.Monad.ST (runST) -import Data.Bits ((.&.), (.|.)) - -import qualified Data.List as L -import Data.Hashable (Hashable) -import Prelude hiding (map, lookup) +import Control.Applicative (Const (..)) +import Control.Monad.ST (runST) +import Data.Bits ((.&.), (.|.)) +import Data.Coerce (coerce) +import Data.Functor.Identity (Identity (..)) +import Data.HashMap.Internal hiding (adjust, alter, alterF, differenceWith, + fromList, fromListWith, fromListWithKey, insert, + insertWith, intersectionWith, intersectionWithKey, + map, mapMaybe, mapMaybeWithKey, mapWithKey, + singleton, traverseWithKey, unionWith, + unionWithKey, update) +import Data.Hashable (Hashable) +import Prelude hiding (lookup, map) +import qualified Data.HashMap.Internal as HM import qualified Data.HashMap.Internal.Array as A -import qualified Data.HashMap.Internal as HM -import Data.HashMap.Internal hiding ( - alter, alterF, adjust, fromList, fromListWith, fromListWithKey, - insert, insertWith, - differenceWith, intersectionWith, intersectionWithKey, map, mapWithKey, - mapMaybe, mapMaybeWithKey, singleton, update, unionWith, unionWithKey, - traverseWithKey) -import Data.Functor.Identity -import Control.Applicative (Const (..)) -import Data.Coerce +import qualified Data.List as List -- $strictness -- @@ -628,7 +630,7 @@ -- 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 +fromList = List.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 @@ -662,7 +664,7 @@ -- > fromListWith f [(k, a), (k, b), (k, c), (k, d)] -- > = fromList [(k, f d (f c (f b a)))] fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v -fromListWith f = L.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty +fromListWith f = List.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty {-# INLINE fromListWith #-} -- | /O(n*log n)/ Construct a map from a list of elements. Uses @@ -692,7 +694,7 @@ -- -- @since 0.2.11 fromListWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> [(k, v)] -> HashMap k v -fromListWithKey f = L.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) empty +fromListWithKey f = List.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) empty {-# INLINE fromListWithKey #-} ------------------------------------------------------------------------ diff --git a/Data/HashMap/Lazy.hs b/Data/HashMap/Lazy.hs --- a/Data/HashMap/Lazy.hs +++ b/Data/HashMap/Lazy.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} ------------------------------------------------------------------------ @@ -106,9 +106,10 @@ , HS.keysSet ) where -import Data.HashMap.Internal as HM +import Data.HashMap.Internal +import Prelude () + import qualified Data.HashSet.Internal as HS -import Prelude () -- $strictness -- diff --git a/Data/HashMap/Strict.hs b/Data/HashMap/Strict.hs --- a/Data/HashMap/Strict.hs +++ b/Data/HashMap/Strict.hs @@ -105,9 +105,10 @@ , HS.keysSet ) where -import Data.HashMap.Internal.Strict as HM +import Data.HashMap.Internal.Strict +import Prelude () + import qualified Data.HashSet.Internal as HS -import Prelude () -- $strictness -- diff --git a/Data/HashSet.hs b/Data/HashSet.hs --- a/Data/HashSet.hs +++ b/Data/HashSet.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} ------------------------------------------------------------------------ @@ -137,4 +137,4 @@ ) where import Data.HashSet.Internal -import Prelude () +import Prelude () diff --git a/Data/HashSet/Internal.hs b/Data/HashSet/Internal.hs --- a/Data/HashSet/Internal.hs +++ b/Data/HashSet/Internal.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE CPP, DeriveDataTypeable #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_HADDOCK not-home #-} ------------------------------------------------------------------------ @@ -40,7 +42,7 @@ module Data.HashSet.Internal ( - HashSet + HashSet(..) -- * Construction , empty @@ -88,49 +90,41 @@ , keysSet ) where -import Control.DeepSeq (NFData(..)) -import Data.Data hiding (Typeable) +import Control.DeepSeq (NFData (..), NFData1 (..), liftRnf2) +import Data.Data (Constr, Data (..), DataType) import Data.Functor.Classes -import Data.HashMap.Internal - ( HashMap, foldMapWithKey, foldlWithKey, foldrWithKey - , equalKeys, equalKeys1) -import Data.Hashable (Hashable(hashWithSalt)) -#if !MIN_VERSION_base(4,11,0) -import Data.Semigroup (Semigroup(..)) -#endif -import GHC.Exts (build) -import qualified GHC.Exts as Exts -import Prelude hiding (filter, foldr, foldl, map, null) -import qualified Data.Foldable as Foldable -import qualified Data.HashMap.Internal as H -import qualified Data.List as List -import Data.Typeable (Typeable) +import Data.HashMap.Internal (HashMap, equalKeys, equalKeys1, foldMapWithKey, + foldlWithKey, foldrWithKey) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.Hashable.Lifted (Hashable1 (..), Hashable2 (..)) +import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid) +import Prelude hiding (filter, foldl, foldr, map, null) import Text.Read -#if MIN_VERSION_hashable(1,2,5) -import qualified Data.Hashable.Lifted as H -#endif - -#if MIN_VERSION_deepseq(1,4,3) -import qualified Control.DeepSeq as NF -#endif +import qualified Data.Data as Data +import qualified Data.Foldable as Foldable +import qualified Data.HashMap.Internal as H +import qualified Data.List as List +import qualified GHC.Exts as Exts +import qualified Language.Haskell.TH.Syntax as TH -- | A set of values. A set cannot contain duplicate values. newtype HashSet a = HashSet { asMap :: HashMap a () - } deriving (Typeable) + } type role HashSet nominal +-- | @since 0.2.17.0 +deriving instance TH.Lift a => TH.Lift (HashSet a) + instance (NFData a) => NFData (HashSet a) where rnf = rnf . asMap {-# INLINE rnf #-} -#if MIN_VERSION_deepseq(1,4,3) -- | @since 0.2.14.0 -instance NF.NFData1 HashSet where - liftRnf rnf1 = NF.liftRnf2 rnf1 rnf . asMap -#endif +instance NFData1 HashSet where + liftRnf rnf1 = liftRnf2 rnf1 rnf . asMap -- | Note that, in the presence of hash collisions, equal @HashSet@s may -- behave differently, i.e. substitutivity may be violated: @@ -195,6 +189,8 @@ instance (Hashable a, Eq a) => Semigroup (HashSet a) where (<>) = union {-# INLINE (<>) #-} + stimes = stimesIdempotentMonoid + {-# INLINE stimes #-} -- | 'mempty' = 'empty' -- @@ -234,25 +230,23 @@ 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 + gunfold k z c = case Data.constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" dataTypeOf _ = hashSetDataType - dataCast1 f = gcast1 f + dataCast1 f = Data.gcast1 f -#if MIN_VERSION_hashable(1,2,6) -instance H.Hashable1 HashSet where - liftHashWithSalt h s = H.liftHashWithSalt2 h hashWithSalt s . asMap -#endif +instance Hashable1 HashSet where + liftHashWithSalt h s = liftHashWithSalt2 h hashWithSalt s . asMap instance (Hashable a) => Hashable (HashSet a) where hashWithSalt salt = hashWithSalt salt . asMap fromListConstr :: Constr -fromListConstr = mkConstr hashSetDataType "fromList" [] Prefix +fromListConstr = Data.mkConstr hashSetDataType "fromList" [] Data.Prefix hashSetDataType :: DataType -hashSetDataType = mkDataType "Data.HashSet.Internal.HashSet" [fromListConstr] +hashSetDataType = Data.mkDataType "Data.HashSet.Internal.HashSet" [fromListConstr] -- | /O(1)/ Construct an empty set. -- @@ -448,7 +442,7 @@ -- | /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)) +toList t = Exts.build (\ c z -> foldrWithKey ((const .) c) z (asMap t)) {-# INLINE toList #-} -- | /O(n*min(W, n))/ Construct a set from a list of elements. diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs --- a/benchmarks/Benchmarks.hs +++ b/benchmarks/Benchmarks.hs @@ -1,25 +1,30 @@ -{-# LANGUAGE CPP, DeriveAnyClass, DeriveGeneric, GADTs, PackageImports, RecordWildCards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} module Main where -import Control.DeepSeq -import Gauge (bench, bgroup, defaultMain, env, nf, whnf) -import Data.Bits ((.&.)) -import Data.Functor.Identity -import Data.Hashable (Hashable, hash) -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 Control.DeepSeq (NFData (..)) +import Data.Bits ((.&.)) +import Data.Functor.Identity (Identity (..)) +import Data.Hashable (Hashable, hash) +import Data.List (foldl') +import Data.Maybe (fromMaybe) +import GHC.Generics (Generic) +import Prelude hiding (lookup) +import Test.Tasty.Bench (bench, bgroup, defaultMain, env, nf, whnf) -import qualified Util.ByteString as UBS -import qualified Util.Int as UI -import qualified Util.String as US +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 qualified Util.ByteString as UBS +import qualified Util.Int as UI +import qualified Util.String as US data B where B :: NFData a => a -> B @@ -121,6 +126,7 @@ main = do defaultMain [ +#ifdef BENCH_containers_Map env setupEnv $ \ ~(Env{..}) -> -- * Comparison to other data structures -- ** Map @@ -161,10 +167,12 @@ [ bench "String" $ whnf (M.isSubmapOf mSubset) m , bench "ByteString" $ whnf (M.isSubmapOf mbsSubset) mbs ] - ] + ], +#endif +#ifdef BENCH_hashmap_Map -- ** Map from the hashmap package - , env setupEnv $ \ ~(Env{..}) -> + env setupEnv $ \ ~(Env{..}) -> bgroup "hashmap/Map" [ bgroup "lookup" [ bench "String" $ whnf (lookupIHM keys) ihm @@ -202,14 +210,12 @@ [ bench "String" $ whnf (IHM.isSubmapOf ihmSubset) ihm , bench "ByteString" $ whnf (IHM.isSubmapOf ihmbsSubset) ihmbs ] - , bgroup "hash" - [ bench "String" $ whnf hash hm - , bench "ByteString" $ whnf hash hmbs - ] - ] + ], +#endif +#ifdef BENCH_containers_IntMap -- ** IntMap - , env setupEnv $ \ ~(Env{..}) -> + env setupEnv $ \ ~(Env{..}) -> bgroup "IntMap" [ bench "lookup" $ whnf (lookupIM keysI) im , bench "lookup-miss" $ whnf (lookupIM keysI') im @@ -220,9 +226,10 @@ , bench "size" $ whnf IM.size im , bench "fromList" $ whnf IM.fromList elemsI , bench "isSubmapOf" $ whnf (IM.isSubmapOf imSubset) im - ] + ], +#endif - , env setupEnv $ \ ~(Env{..}) -> + env setupEnv $ \ ~(Env{..}) -> bgroup "HashMap" [ -- * Basic interface bgroup "lookup" @@ -357,6 +364,11 @@ , bench "Int" $ whnf (HM.fromListWith (+)) elemsDupI ] ] + -- Hashable instance + , bgroup "hash" + [ bench "String" $ whnf hash hm + , bench "ByteString" $ whnf hash hmbs + ] ] ] @@ -438,6 +450,7 @@ {-# SPECIALIZE isSubmapOfNaive :: HM.HashMap String Int -> HM.HashMap String Int -> Bool #-} {-# SPECIALIZE isSubmapOfNaive :: HM.HashMap BS.ByteString Int -> HM.HashMap BS.ByteString Int -> Bool #-} +#ifdef BENCH_containers_Map ------------------------------------------------------------------------ -- * Map @@ -458,7 +471,9 @@ {-# 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 #-} +#endif +#ifdef BENCH_hashmap_Map ------------------------------------------------------------------------ -- * Map from the hashmap package @@ -482,7 +497,9 @@ -> IHM.Map String Int #-} {-# SPECIALIZE deleteIHM :: [BS.ByteString] -> IHM.Map BS.ByteString Int -> IHM.Map BS.ByteString Int #-} +#endif +#ifdef BENCH_containers_IntMap ------------------------------------------------------------------------ -- * IntMap @@ -494,3 +511,4 @@ deleteIM :: [Int] -> IM.IntMap Int -> IM.IntMap Int deleteIM xs m0 = foldl' (\m k -> IM.delete k m) m0 xs +#endif diff --git a/benchmarks/Util/ByteString.hs b/benchmarks/Util/ByteString.hs --- a/benchmarks/Util/ByteString.hs +++ b/benchmarks/Util/ByteString.hs @@ -2,10 +2,9 @@ -- random 'ByteString's. module Util.ByteString where -import qualified Data.ByteString as S +import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C - -import Util.String as String +import qualified Util.String as String -- | Generate a number of fixed length 'ByteString's where the content -- of the strings are letters in ascending order. diff --git a/tests/HashMapProperties.hs b/tests/HashMapProperties.hs deleted file mode 100644 --- a/tests/HashMapProperties.hs +++ /dev/null @@ -1,587 +0,0 @@ -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v) - --- | Tests for the 'Data.HashMap.Lazy' module. We test functions by --- comparing them to a simpler model, an association list. - -module Main (main) where - -import Control.Monad ( guard ) -import qualified Data.Foldable as Foldable -#if MIN_VERSION_base(4,10,0) -import Data.Bifoldable -#endif -import Data.Function (on) -import Data.Hashable (Hashable(hashWithSalt)) -import qualified Data.List as L -import Data.Ord (comparing) -#if defined(STRICT) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HM -import qualified Data.Map.Strict as M -#else -import Data.HashMap.Lazy (HashMap) -import qualified Data.HashMap.Lazy as HM -import qualified Data.Map.Lazy as M -#endif -import Test.QuickCheck (Arbitrary(..), Property, (==>), (===), forAll, elements) -import Test.Framework (Test, defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Data.Functor.Identity (Identity (..)) -import Control.Applicative (Const (..)) -import Test.QuickCheck.Function (Fun, apply) -import Test.QuickCheck.Poly (A, B) - --- 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 - -instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where - arbitrary = fmap (HM.fromList) arbitrary - ------------------------------------------------------------------------- --- * 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 /=) - --- We cannot compare to `Data.Map` as ordering is different. -pOrd1 :: [(Key, Int)] -> Bool -pOrd1 xs = compare x x == EQ - where - x = HM.fromList xs - -pOrd2 :: [(Key, Int)] -> [(Key, Int)] -> [(Key, Int)] -> Bool -pOrd2 xs ys zs = case (compare x y, compare y z) of - (EQ, o) -> compare x z == o - (o, EQ) -> compare x z == o - (LT, LT) -> compare x z == LT - (GT, GT) -> compare x z == GT - (LT, GT) -> True -- ys greater than xs and zs. - (GT, LT) -> True - where - x = HM.fromList xs - y = HM.fromList ys - z = HM.fromList zs - -pOrd3 :: [(Key, Int)] -> [(Key, Int)] -> Bool -pOrd3 xs ys = case (compare x y, compare y x) of - (EQ, EQ) -> True - (LT, GT) -> True - (GT, LT) -> True - _ -> False - where - x = HM.fromList xs - y = HM.fromList ys - -pOrdEq :: [(Key, Int)] -> [(Key, Int)] -> Bool -pOrdEq xs ys = case (compare x y, x == y) of - (EQ, True) -> True - (LT, False) -> True - (GT, False) -> True - _ -> False - where - x = HM.fromList xs - y = HM.fromList ys - -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 - xs' = L.nubBy (\(k,_) (k',_) -> k == k') xs - 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 - -pLookupOperator :: Key -> [(Key, Int)] -> Bool -pLookupOperator k = M.lookup k `eq` (HM.!? 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 - - --- We choose the list functor here because we don't fuss with --- it in alterF rules and because it has a sufficiently interesting --- structure to have a good chance of breaking if something is wrong. -pAlterF :: Key -> Fun (Maybe A) [Maybe A] -> [(Key, A)] -> Property -pAlterF k f xs = - fmap M.toAscList (M.alterF (apply f) k (M.fromList xs)) - === - fmap toAscList (HM.alterF (apply f) k (HM.fromList xs)) - -pAlterFAdjust :: Key -> [(Key, Int)] -> Bool -pAlterFAdjust k = - runIdentity . M.alterF (Identity . fmap succ) k `eq_` - runIdentity . HM.alterF (Identity . fmap succ) k - -pAlterFInsert :: Key -> [(Key, Int)] -> Bool -pAlterFInsert k = - runIdentity . M.alterF (const . Identity . Just $ 3) k `eq_` - runIdentity . HM.alterF (const . Identity . Just $ 3) k - -pAlterFInsertWith :: Key -> Fun Int Int -> [(Key, Int)] -> Bool -pAlterFInsertWith k f = - runIdentity . M.alterF (Identity . Just . maybe 3 (apply f)) k `eq_` - runIdentity . HM.alterF (Identity . Just . maybe 3 (apply f)) k - -pAlterFDelete :: Key -> [(Key, Int)] -> Bool -pAlterFDelete k = - runIdentity . M.alterF (const (Identity Nothing)) k `eq_` - runIdentity . HM.alterF (const (Identity Nothing)) k - -pAlterFLookup :: Key - -> Fun (Maybe A) B - -> [(Key, A)] -> Bool -pAlterFLookup k f = - getConst . M.alterF (Const . apply f :: Maybe A -> Const B (Maybe A)) k - `eq` - getConst . HM.alterF (Const . apply f) k - -pSubmap :: [(Key, Int)] -> [(Key, Int)] -> Bool -pSubmap xs ys = M.isSubmapOf (M.fromList xs) (M.fromList ys) == - HM.isSubmapOf (HM.fromList xs) (HM.fromList ys) - -pSubmapReflexive :: HashMap Key Int -> Bool -pSubmapReflexive m = HM.isSubmapOf m m - -pSubmapUnion :: HashMap Key Int -> HashMap Key Int -> Bool -pSubmapUnion m1 m2 = HM.isSubmapOf m1 (HM.union m1 m2) - -pNotSubmapUnion :: HashMap Key Int -> HashMap Key Int -> Property -pNotSubmapUnion m1 m2 = not (HM.isSubmapOf m1 m2) ==> HM.isSubmapOf m1 (HM.union m1 m2) - -pSubmapDifference :: HashMap Key Int -> HashMap Key Int -> Bool -pSubmapDifference m1 m2 = HM.isSubmapOf (HM.difference m1 m2) m1 - -pNotSubmapDifference :: HashMap Key Int -> HashMap Key Int -> Property -pNotSubmapDifference m1 m2 = - not (HM.null (HM.intersection m1 m2)) ==> - not (HM.isSubmapOf m1 (HM.difference m1 m2)) - -pSubmapDelete :: HashMap Key Int -> Property -pSubmapDelete m = not (HM.null m) ==> - forAll (elements (HM.keys m)) $ \k -> - HM.isSubmapOf (HM.delete k m) m - -pNotSubmapDelete :: HashMap Key Int -> Property -pNotSubmapDelete m = - not (HM.null m) ==> - forAll (elements (HM.keys m)) $ \k -> - not (HM.isSubmapOf m (HM.delete k m)) - -pSubmapInsert :: Key -> Int -> HashMap Key Int -> Property -pSubmapInsert k v m = not (HM.member k m) ==> HM.isSubmapOf m (HM.insert k v m) - -pNotSubmapInsert :: Key -> Int -> HashMap Key Int -> Property -pNotSubmapInsert k v m = not (HM.member k m) ==> not (HM.isSubmapOf (HM.insert k v m) m) - ------------------------------------------------------------------------- --- ** Combine - -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) - -pTraverse :: [(Key, Int)] -> Bool -pTraverse xs = - L.sort (fmap (L.sort . M.toList) (M.traverseWithKey (\_ v -> [v + 1, v + 2]) (M.fromList (take 10 xs)))) - == L.sort (fmap (L.sort . HM.toList) (HM.traverseWithKey (\_ v -> [v + 1, v + 2]) (HM.fromList (take 10 xs)))) - -pMapKeys :: [(Int, Int)] -> Bool -pMapKeys = M.mapKeys (+1) `eq_` HM.mapKeys (+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 - -pDifferenceWith :: [(Key, Int)] -> [(Key, Int)] -> Bool -pDifferenceWith xs ys = M.differenceWith f (M.fromList xs) `eq_` - HM.differenceWith f (HM.fromList xs) $ ys - where - f x y = if x == 0 then Nothing else Just (x - y) - -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.foldr (:) []) `eq` (L.sort . HM.foldr (:) []) - -pFoldl :: [(Int, Int)] -> Bool -pFoldl = (L.sort . M.foldl (flip (:)) []) `eq` (L.sort . HM.foldl (flip (:)) []) - -#if MIN_VERSION_base(4,10,0) -pBifoldMap :: [(Int, Int)] -> Bool -pBifoldMap xs = concatMap f (HM.toList m) == bifoldMap (:[]) (:[]) m - where f (k, v) = [k, v] - m = HM.fromList xs - -pBifoldr :: [(Int, Int)] -> Bool -pBifoldr xs = concatMap f (HM.toList m) == bifoldr (:) (:) [] m - where f (k, v) = [k, v] - m = HM.fromList xs - -pBifoldl :: [(Int, Int)] -> Bool -pBifoldl xs = reverse (concatMap f $ HM.toList m) == bifoldl (flip (:)) (flip (:)) [] m - where f (k, v) = [k, v] - m = HM.fromList xs -#endif - -pFoldrWithKey :: [(Int, Int)] -> Bool -pFoldrWithKey = (sortByKey . M.foldrWithKey f []) `eq` - (sortByKey . HM.foldrWithKey f []) - where f k v z = (k, v) : z - -pFoldMapWithKey :: [(Int, Int)] -> Bool -pFoldMapWithKey = (sortByKey . M.foldMapWithKey f) `eq` - (sortByKey . HM.foldMapWithKey f) - where f k v = [(k, v)] - -pFoldrWithKey' :: [(Int, Int)] -> Bool -pFoldrWithKey' = (sortByKey . M.foldrWithKey' f []) `eq` - (sortByKey . HM.foldrWithKey' f []) - where f k v z = (k, v) : z - -pFoldlWithKey :: [(Int, Int)] -> Bool -pFoldlWithKey = (sortByKey . M.foldlWithKey f []) `eq` - (sortByKey . HM.foldlWithKey f []) - where f z k v = (k, v) : z - -pFoldlWithKey' :: [(Int, Int)] -> Bool -pFoldlWithKey' = (sortByKey . M.foldlWithKey' f []) `eq` - (sortByKey . HM.foldlWithKey' f []) - where f z k v = (k, v) : z - -pFoldl' :: [(Int, Int)] -> Bool -pFoldl' = (L.sort . M.foldl' (flip (:)) []) `eq` (L.sort . HM.foldl' (flip (:)) []) - -pFoldr' :: [(Int, Int)] -> Bool -pFoldr' = (L.sort . M.foldr' (:) []) `eq` (L.sort . HM.foldr' (:) []) - ------------------------------------------------------------------------- --- ** 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 - --- The free magma is used to test that operations are applied in the --- same order. -data Magma a - = Leaf a - | Op (Magma a) (Magma a) - deriving (Show, Eq, Ord) - -instance Hashable a => Hashable (Magma a) where - hashWithSalt s (Leaf a) = hashWithSalt s (hashWithSalt (1::Int) a) - hashWithSalt s (Op m n) = hashWithSalt s (hashWithSalt (hashWithSalt (2::Int) m) n) - --- 'eq_' already calls fromList. -pFromList :: [(Key, Int)] -> Bool -pFromList = id `eq_` id - -pFromListWith :: [(Key, Int)] -> Bool -pFromListWith kvs = (M.toAscList $ M.fromListWith Op kvsM) == - (toAscList $ HM.fromListWith Op kvsM) - where kvsM = fmap (fmap Leaf) kvs - -pFromListWithKey :: [(Key, Int)] -> Bool -pFromListWithKey kvs = (M.toAscList $ M.fromListWithKey combine kvsM) == - (toAscList $ HM.fromListWithKey combine kvsM) - where kvsM = fmap (\(K k,v) -> (Leaf k, Leaf v)) kvs - combine k v1 v2 = Op k (Op v1 v2) - -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 "compare reflexive" pOrd1 - , testProperty "compare transitive" pOrd2 - , testProperty "compare antisymmetric" pOrd3 - , testProperty "Ord => Eq" pOrdEq - , 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 "!?" pLookupOperator - , 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 - , testProperty "alterF" pAlterF - , testProperty "alterFAdjust" pAlterFAdjust - , testProperty "alterFInsert" pAlterFInsert - , testProperty "alterFInsertWith" pAlterFInsertWith - , testProperty "alterFDelete" pAlterFDelete - , testProperty "alterFLookup" pAlterFLookup - , testGroup "isSubmapOf" - [ testProperty "container compatibility" pSubmap - , testProperty "m ⊆ m" pSubmapReflexive - , testProperty "m1 ⊆ m1 ∪ m2" pSubmapUnion - , testProperty "m1 ⊈ m2 ⇒ m1 ∪ m2 ⊈ m1" pNotSubmapUnion - , testProperty "m1\\m2 ⊆ m1" pSubmapDifference - , testProperty "m1 ∩ m2 ≠ ∅ ⇒ m1 ⊈ m1\\m2 " pNotSubmapDifference - , testProperty "delete k m ⊆ m" pSubmapDelete - , testProperty "m ⊈ delete k m " pNotSubmapDelete - , testProperty "k ∉ m ⇒ m ⊆ insert k v m" pSubmapInsert - , testProperty "k ∉ m ⇒ insert k v m ⊈ m" pNotSubmapInsert - ] - ] - -- Combine - , testProperty "union" pUnion - , testProperty "unionWith" pUnionWith - , testProperty "unionWithKey" pUnionWithKey - , testProperty "unions" pUnions - -- Transformations - , testProperty "map" pMap - , testProperty "traverse" pTraverse - , testProperty "mapKeys" pMapKeys - -- Folds - , testGroup "folds" - [ testProperty "foldr" pFoldr - , testProperty "foldl" pFoldl -#if MIN_VERSION_base(4,10,0) - , testProperty "bifoldMap" pBifoldMap - , testProperty "bifoldr" pBifoldr - , testProperty "bifoldl" pBifoldl -#endif - , testProperty "foldrWithKey" pFoldrWithKey - , testProperty "foldlWithKey" pFoldlWithKey - , testProperty "foldrWithKey'" pFoldrWithKey' - , testProperty "foldlWithKey'" pFoldlWithKey' - , testProperty "foldl'" pFoldl' - , testProperty "foldr'" pFoldr' - , testProperty "foldMapWithKey" pFoldMapWithKey - ] - , testGroup "difference and intersection" - [ testProperty "difference" pDifference - , testProperty "differenceWith" pDifferenceWith - , 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 "fromListWithKey" pFromListWithKey - , 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) - -infix 4 `eq` - -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) - -infix 4 `eq_` - ------------------------------------------------------------------------- --- * 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 diff --git a/tests/HashSetProperties.hs b/tests/HashSetProperties.hs deleted file mode 100644 --- a/tests/HashSetProperties.hs +++ /dev/null @@ -1,240 +0,0 @@ -{-# 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 /=) - --- We cannot compare to `Data.Map` as ordering is different. -pOrd1 :: [Key] -> Bool -pOrd1 xs = compare x x == EQ - where - x = S.fromList xs - -pOrd2 :: [Key] -> [Key] -> [Key] -> Bool -pOrd2 xs ys zs = case (compare x y, compare y z) of - (EQ, o) -> compare x z == o - (o, EQ) -> compare x z == o - (LT, LT) -> compare x z == LT - (GT, GT) -> compare x z == GT - (LT, GT) -> True -- ys greater than xs and zs. - (GT, LT) -> True - where - x = S.fromList xs - y = S.fromList ys - z = S.fromList zs - -pOrd3 :: [Key] -> [Key] -> Bool -pOrd3 xs ys = case (compare x y, compare y x) of - (EQ, EQ) -> True - (LT, GT) -> True - (GT, LT) -> True - _ -> False - where - x = S.fromList xs - y = S.fromList ys - -pOrdEq :: [Key] -> [Key] -> Bool -pOrdEq xs ys = case (compare x y, x == y) of - (EQ, True) -> True - (LT, False) -> True - (GT, False) -> True - _ -> False - where - x = S.fromList xs - y = S.fromList ys - -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 - xs' = L.nub xs - 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 -foldrSet = Set.foldr - -pFoldl' :: Int -> [Int] -> Bool -pFoldl' z0 = foldl'Set (+) z0 `eq` S.foldl' (+) z0 - -foldl'Set :: (a -> b -> a) -> a -> Set.Set b -> a -foldl'Set = Set.foldl' - ------------------------------------------------------------------------- --- ** 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 "compare reflexive" pOrd1 - , testProperty "compare transitive" pOrd2 - , testProperty "compare antisymmetric" pOrd3 - , testProperty "Ord => Eq" pOrdEq - , 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 diff --git a/tests/List.hs b/tests/List.hs deleted file mode 100644 --- a/tests/List.hs +++ /dev/null @@ -1,68 +0,0 @@ -module Main (main) where - -import Data.HashMap.Internal.List -import Data.List (nub, sort, sortBy) -import Data.Ord (comparing) - -import Test.Framework (Test, defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck ((==>), (===), property, Property) - -tests :: Test -tests = testGroup "Data.HashMap.Internal.List" - [ testProperty "isPermutationBy" pIsPermutation - , testProperty "isPermutationBy of different length" pIsPermutationDiffLength - , testProperty "pUnorderedCompare" pUnorderedCompare - , testGroup "modelUnorderedCompare" - [ testProperty "reflexive" modelUnorderedCompareRefl - , testProperty "anti-symmetric" modelUnorderedCompareAntiSymm - , testProperty "transitive" modelUnorderedCompareTrans - ] - ] - -pIsPermutation :: [Char] -> [Int] -> Bool -pIsPermutation xs is = isPermutationBy (==) xs xs' - where - is' = nub is ++ [maximum (0:is) + 1 ..] - xs' = map fst . sortBy (comparing snd) $ zip xs is' - -pIsPermutationDiffLength :: [Int] -> [Int] -> Property -pIsPermutationDiffLength xs ys = - length xs /= length ys ==> isPermutationBy (==) xs ys === False - --- | Homogenous version of 'unorderedCompare' --- --- *Compare smallest non-equal elements of the two lists*. -modelUnorderedCompare :: Ord a => [a] -> [a] -> Ordering -modelUnorderedCompare as bs = compare (sort as) (sort bs) - -modelUnorderedCompareRefl :: [Int] -> Property -modelUnorderedCompareRefl xs = modelUnorderedCompare xs xs === EQ - -modelUnorderedCompareAntiSymm :: [Int] -> [Int] -> Property -modelUnorderedCompareAntiSymm xs ys = case a of - EQ -> b === EQ - LT -> b === GT - GT -> b === LT - where - a = modelUnorderedCompare xs ys - b = modelUnorderedCompare ys xs - -modelUnorderedCompareTrans :: [Int] -> [Int] -> [Int] -> Property -modelUnorderedCompareTrans xs ys zs = - case (modelUnorderedCompare xs ys, modelUnorderedCompare ys zs) of - (EQ, yz) -> xz === yz - (xy, EQ) -> xz === xy - (LT, LT) -> xz === LT - (GT, GT) -> xz === GT - (LT, GT) -> property True - (GT, LT) -> property True - where - xz = modelUnorderedCompare xs zs - -pUnorderedCompare :: [Int] -> [Int] -> Property -pUnorderedCompare xs ys = - unorderedCompare compare xs ys === modelUnorderedCompare xs ys - -main :: IO () -main = defaultMain [tests] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,14 @@ +module Main (main) where + +import Test.Tasty (defaultMain, testGroup) + +import qualified Properties +import qualified Regressions +import qualified Strictness + +main :: IO () +main = defaultMain $ testGroup "All" + [ Properties.tests + , Regressions.tests + , Strictness.tests + ] diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -0,0 +1,16 @@ +module Properties (tests) where + +import Test.Tasty (TestTree, testGroup) + +import qualified Properties.HashMapLazy +import qualified Properties.HashMapStrict +import qualified Properties.HashSet +import qualified Properties.List + +tests :: TestTree +tests = testGroup "Properties" + [ Properties.HashMapLazy.tests + , Properties.HashMapStrict.tests + , Properties.HashSet.tests + , Properties.List.tests + ] diff --git a/tests/Properties/HashMapLazy.hs b/tests/Properties/HashMapLazy.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/HashMapLazy.hs @@ -0,0 +1,591 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- because of Arbitrary (HashMap k v) + +-- | Tests for the 'Data.HashMap.Lazy' module. We test functions by +-- comparing them to @Map@ from @containers@. + +#if defined(STRICT) +#define MODULE_NAME Properties.HashMapStrict +#else +#define MODULE_NAME Properties.HashMapLazy +#endif + +module MODULE_NAME (tests) where + +import Control.Applicative (Const (..)) +import Control.Monad (guard) +import Data.Bifoldable +import Data.Function (on) +import Data.Functor.Identity (Identity (..)) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.Ord (comparing) +import Test.QuickCheck (Arbitrary (..), Property, elements, forAll, + (===), (==>)) +import Test.QuickCheck.Function (Fun, apply) +import Test.QuickCheck.Poly (A, B) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import qualified Data.Foldable as Foldable +import qualified Data.List as List + +#if defined(STRICT) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import qualified Data.Map.Strict as M +#else +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HM +import qualified Data.Map.Lazy as M +#endif + +-- 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 + +instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where + arbitrary = fmap (HM.fromList) arbitrary + +------------------------------------------------------------------------ +-- * 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 /=) + +-- We cannot compare to `Data.Map` as ordering is different. +pOrd1 :: [(Key, Int)] -> Bool +pOrd1 xs = compare x x == EQ + where + x = HM.fromList xs + +pOrd2 :: [(Key, Int)] -> [(Key, Int)] -> [(Key, Int)] -> Bool +pOrd2 xs ys zs = case (compare x y, compare y z) of + (EQ, o) -> compare x z == o + (o, EQ) -> compare x z == o + (LT, LT) -> compare x z == LT + (GT, GT) -> compare x z == GT + (LT, GT) -> True -- ys greater than xs and zs. + (GT, LT) -> True + where + x = HM.fromList xs + y = HM.fromList ys + z = HM.fromList zs + +pOrd3 :: [(Key, Int)] -> [(Key, Int)] -> Bool +pOrd3 xs ys = case (compare x y, compare y x) of + (EQ, EQ) -> True + (LT, GT) -> True + (GT, LT) -> True + _ -> False + where + x = HM.fromList xs + y = HM.fromList ys + +pOrdEq :: [(Key, Int)] -> [(Key, Int)] -> Bool +pOrdEq xs ys = case (compare x y, x == y) of + (EQ, True) -> True + (LT, False) -> True + (GT, False) -> True + _ -> False + where + x = HM.fromList xs + y = HM.fromList ys + +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 = (List.sort . Foldable.foldr (:) []) `eq` + (List.sort . Foldable.foldr (:) []) + +pHashable :: [(Key, Int)] -> [Int] -> Int -> Property +pHashable xs is salt = + x == y ==> hashWithSalt salt x === hashWithSalt salt y + where + xs' = List.nubBy (\(k,_) (k',_) -> k == k') xs + 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 = List.map snd + . List.sortBy (comparing fst) + . List.zip (idxs ++ [List.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 + +pLookupOperator :: Key -> [(Key, Int)] -> Bool +pLookupOperator k = M.lookup k `eq` (HM.!? 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 + + +-- We choose the list functor here because we don't fuss with +-- it in alterF rules and because it has a sufficiently interesting +-- structure to have a good chance of breaking if something is wrong. +pAlterF :: Key -> Fun (Maybe A) [Maybe A] -> [(Key, A)] -> Property +pAlterF k f xs = + fmap M.toAscList (M.alterF (apply f) k (M.fromList xs)) + === + fmap toAscList (HM.alterF (apply f) k (HM.fromList xs)) + +pAlterFAdjust :: Key -> [(Key, Int)] -> Bool +pAlterFAdjust k = + runIdentity . M.alterF (Identity . fmap succ) k `eq_` + runIdentity . HM.alterF (Identity . fmap succ) k + +pAlterFInsert :: Key -> [(Key, Int)] -> Bool +pAlterFInsert k = + runIdentity . M.alterF (const . Identity . Just $ 3) k `eq_` + runIdentity . HM.alterF (const . Identity . Just $ 3) k + +pAlterFInsertWith :: Key -> Fun Int Int -> [(Key, Int)] -> Bool +pAlterFInsertWith k f = + runIdentity . M.alterF (Identity . Just . maybe 3 (apply f)) k `eq_` + runIdentity . HM.alterF (Identity . Just . maybe 3 (apply f)) k + +pAlterFDelete :: Key -> [(Key, Int)] -> Bool +pAlterFDelete k = + runIdentity . M.alterF (const (Identity Nothing)) k `eq_` + runIdentity . HM.alterF (const (Identity Nothing)) k + +pAlterFLookup :: Key + -> Fun (Maybe A) B + -> [(Key, A)] -> Bool +pAlterFLookup k f = + getConst . M.alterF (Const . apply f :: Maybe A -> Const B (Maybe A)) k + `eq` + getConst . HM.alterF (Const . apply f) k + +pSubmap :: [(Key, Int)] -> [(Key, Int)] -> Bool +pSubmap xs ys = M.isSubmapOf (M.fromList xs) (M.fromList ys) == + HM.isSubmapOf (HM.fromList xs) (HM.fromList ys) + +pSubmapReflexive :: HashMap Key Int -> Bool +pSubmapReflexive m = HM.isSubmapOf m m + +pSubmapUnion :: HashMap Key Int -> HashMap Key Int -> Bool +pSubmapUnion m1 m2 = HM.isSubmapOf m1 (HM.union m1 m2) + +pNotSubmapUnion :: HashMap Key Int -> HashMap Key Int -> Property +pNotSubmapUnion m1 m2 = not (HM.isSubmapOf m1 m2) ==> HM.isSubmapOf m1 (HM.union m1 m2) + +pSubmapDifference :: HashMap Key Int -> HashMap Key Int -> Bool +pSubmapDifference m1 m2 = HM.isSubmapOf (HM.difference m1 m2) m1 + +pNotSubmapDifference :: HashMap Key Int -> HashMap Key Int -> Property +pNotSubmapDifference m1 m2 = + not (HM.null (HM.intersection m1 m2)) ==> + not (HM.isSubmapOf m1 (HM.difference m1 m2)) + +pSubmapDelete :: HashMap Key Int -> Property +pSubmapDelete m = not (HM.null m) ==> + forAll (elements (HM.keys m)) $ \k -> + HM.isSubmapOf (HM.delete k m) m + +pNotSubmapDelete :: HashMap Key Int -> Property +pNotSubmapDelete m = + not (HM.null m) ==> + forAll (elements (HM.keys m)) $ \k -> + not (HM.isSubmapOf m (HM.delete k m)) + +pSubmapInsert :: Key -> Int -> HashMap Key Int -> Property +pSubmapInsert k v m = not (HM.member k m) ==> HM.isSubmapOf m (HM.insert k v m) + +pNotSubmapInsert :: Key -> Int -> HashMap Key Int -> Property +pNotSubmapInsert k v m = not (HM.member k m) ==> not (HM.isSubmapOf (HM.insert k v m) m) + +------------------------------------------------------------------------ +-- ** Combine + +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) + +pTraverse :: [(Key, Int)] -> Bool +pTraverse xs = + List.sort (fmap (List.sort . M.toList) (M.traverseWithKey (\_ v -> [v + 1, v + 2]) (M.fromList (take 10 xs)))) + == List.sort (fmap (List.sort . HM.toList) (HM.traverseWithKey (\_ v -> [v + 1, v + 2]) (HM.fromList (take 10 xs)))) + +pMapKeys :: [(Int, Int)] -> Bool +pMapKeys = M.mapKeys (+1) `eq_` HM.mapKeys (+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 + +pDifferenceWith :: [(Key, Int)] -> [(Key, Int)] -> Bool +pDifferenceWith xs ys = M.differenceWith f (M.fromList xs) `eq_` + HM.differenceWith f (HM.fromList xs) $ ys + where + f x y = if x == 0 then Nothing else Just (x - y) + +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 = (List.sort . M.foldr (:) []) `eq` (List.sort . HM.foldr (:) []) + +pFoldl :: [(Int, Int)] -> Bool +pFoldl = (List.sort . M.foldl (flip (:)) []) `eq` (List.sort . HM.foldl (flip (:)) []) + +pBifoldMap :: [(Int, Int)] -> Bool +pBifoldMap xs = concatMap f (HM.toList m) == bifoldMap (:[]) (:[]) m + where f (k, v) = [k, v] + m = HM.fromList xs + +pBifoldr :: [(Int, Int)] -> Bool +pBifoldr xs = concatMap f (HM.toList m) == bifoldr (:) (:) [] m + where f (k, v) = [k, v] + m = HM.fromList xs + +pBifoldl :: [(Int, Int)] -> Bool +pBifoldl xs = reverse (concatMap f $ HM.toList m) == bifoldl (flip (:)) (flip (:)) [] m + where f (k, v) = [k, v] + m = HM.fromList xs + +pFoldrWithKey :: [(Int, Int)] -> Bool +pFoldrWithKey = (sortByKey . M.foldrWithKey f []) `eq` + (sortByKey . HM.foldrWithKey f []) + where f k v z = (k, v) : z + +pFoldMapWithKey :: [(Int, Int)] -> Bool +pFoldMapWithKey = (sortByKey . M.foldMapWithKey f) `eq` + (sortByKey . HM.foldMapWithKey f) + where f k v = [(k, v)] + +pFoldrWithKey' :: [(Int, Int)] -> Bool +pFoldrWithKey' = (sortByKey . M.foldrWithKey' f []) `eq` + (sortByKey . HM.foldrWithKey' f []) + where f k v z = (k, v) : z + +pFoldlWithKey :: [(Int, Int)] -> Bool +pFoldlWithKey = (sortByKey . M.foldlWithKey f []) `eq` + (sortByKey . HM.foldlWithKey f []) + where f z k v = (k, v) : z + +pFoldlWithKey' :: [(Int, Int)] -> Bool +pFoldlWithKey' = (sortByKey . M.foldlWithKey' f []) `eq` + (sortByKey . HM.foldlWithKey' f []) + where f z k v = (k, v) : z + +pFoldl' :: [(Int, Int)] -> Bool +pFoldl' = (List.sort . M.foldl' (flip (:)) []) `eq` (List.sort . HM.foldl' (flip (:)) []) + +pFoldr' :: [(Int, Int)] -> Bool +pFoldr' = (List.sort . M.foldr' (:) []) `eq` (List.sort . HM.foldr' (:) []) + +------------------------------------------------------------------------ +-- ** 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 + +-- The free magma is used to test that operations are applied in the +-- same order. +data Magma a + = Leaf a + | Op (Magma a) (Magma a) + deriving (Show, Eq, Ord) + +instance Hashable a => Hashable (Magma a) where + hashWithSalt s (Leaf a) = hashWithSalt s (hashWithSalt (1::Int) a) + hashWithSalt s (Op m n) = hashWithSalt s (hashWithSalt (hashWithSalt (2::Int) m) n) + +-- 'eq_' already calls fromList. +pFromList :: [(Key, Int)] -> Bool +pFromList = id `eq_` id + +pFromListWith :: [(Key, Int)] -> Bool +pFromListWith kvs = (M.toAscList $ M.fromListWith Op kvsM) == + (toAscList $ HM.fromListWith Op kvsM) + where kvsM = fmap (fmap Leaf) kvs + +pFromListWithKey :: [(Key, Int)] -> Bool +pFromListWithKey kvs = (M.toAscList $ M.fromListWithKey combine kvsM) == + (toAscList $ HM.fromListWithKey combine kvsM) + where kvsM = fmap (\(K k,v) -> (Leaf k, Leaf v)) kvs + combine k v1 v2 = Op k (Op v1 v2) + +pToList :: [(Key, Int)] -> Bool +pToList = M.toAscList `eq` toAscList + +pElems :: [(Key, Int)] -> Bool +pElems = (List.sort . M.elems) `eq` (List.sort . HM.elems) + +pKeys :: [(Key, Int)] -> Bool +pKeys = (List.sort . M.keys) `eq` (List.sort . HM.keys) + +------------------------------------------------------------------------ +-- * Test list + +tests :: TestTree +tests = + testGroup +#if defined(STRICT) + "Data.HashMap.Strict" +#else + "Data.HashMap.Lazy" +#endif + [ + -- Instances + testGroup "instances" + [ testProperty "==" pEq + , testProperty "/=" pNeq + , testProperty "compare reflexive" pOrd1 + , testProperty "compare transitive" pOrd2 + , testProperty "compare antisymmetric" pOrd3 + , testProperty "Ord => Eq" pOrdEq + , 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 "!?" pLookupOperator + , 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 + , testProperty "alterF" pAlterF + , testProperty "alterFAdjust" pAlterFAdjust + , testProperty "alterFInsert" pAlterFInsert + , testProperty "alterFInsertWith" pAlterFInsertWith + , testProperty "alterFDelete" pAlterFDelete + , testProperty "alterFLookup" pAlterFLookup + , testGroup "isSubmapOf" + [ testProperty "container compatibility" pSubmap + , testProperty "m ⊆ m" pSubmapReflexive + , testProperty "m1 ⊆ m1 ∪ m2" pSubmapUnion + , testProperty "m1 ⊈ m2 ⇒ m1 ∪ m2 ⊈ m1" pNotSubmapUnion + , testProperty "m1\\m2 ⊆ m1" pSubmapDifference + , testProperty "m1 ∩ m2 ≠ ∅ ⇒ m1 ⊈ m1\\m2 " pNotSubmapDifference + , testProperty "delete k m ⊆ m" pSubmapDelete + , testProperty "m ⊈ delete k m " pNotSubmapDelete + , testProperty "k ∉ m ⇒ m ⊆ insert k v m" pSubmapInsert + , testProperty "k ∉ m ⇒ insert k v m ⊈ m" pNotSubmapInsert + ] + ] + -- Combine + , testProperty "union" pUnion + , testProperty "unionWith" pUnionWith + , testProperty "unionWithKey" pUnionWithKey + , testProperty "unions" pUnions + -- Transformations + , testProperty "map" pMap + , testProperty "traverse" pTraverse + , testProperty "mapKeys" pMapKeys + -- Folds + , testGroup "folds" + [ testProperty "foldr" pFoldr + , testProperty "foldl" pFoldl + , testProperty "bifoldMap" pBifoldMap + , testProperty "bifoldr" pBifoldr + , testProperty "bifoldl" pBifoldl + , testProperty "foldrWithKey" pFoldrWithKey + , testProperty "foldlWithKey" pFoldlWithKey + , testProperty "foldrWithKey'" pFoldrWithKey' + , testProperty "foldlWithKey'" pFoldlWithKey' + , testProperty "foldl'" pFoldl' + , testProperty "foldr'" pFoldr' + , testProperty "foldMapWithKey" pFoldMapWithKey + ] + , testGroup "difference and intersection" + [ testProperty "difference" pDifference + , testProperty "differenceWith" pDifferenceWith + , 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 "fromListWithKey" pFromListWithKey + , 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) + +infix 4 `eq` + +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) + +infix 4 `eq_` + +------------------------------------------------------------------------ +-- * Helpers + +sortByKey :: Ord k => [(k, v)] -> [(k, v)] +sortByKey = List.sortBy (compare `on` fst) + +toAscList :: Ord k => HM.HashMap k v -> [(k, v)] +toAscList = List.sortBy (compare `on` fst) . HM.toList diff --git a/tests/Properties/HashMapStrict.hs b/tests/Properties/HashMapStrict.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/HashMapStrict.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE CPP #-} + +#define STRICT + +#include "HashMapLazy.hs" diff --git a/tests/Properties/HashSet.hs b/tests/Properties/HashSet.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/HashSet.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Tests for the 'Data.HashSet' module. We test functions by +-- comparing them to @Set@ from @containers@. + +module Properties.HashSet (tests) where + +import Data.Hashable (Hashable (hashWithSalt)) +import Data.Ord (comparing) +import Test.QuickCheck (Arbitrary, Property, (===), (==>)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import qualified Data.Foldable as Foldable +import qualified Data.HashSet as S +import qualified Data.List as List +import qualified Data.Set as Set + +-- 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 /=) + +-- We cannot compare to `Data.Map` as ordering is different. +pOrd1 :: [Key] -> Bool +pOrd1 xs = compare x x == EQ + where + x = S.fromList xs + +pOrd2 :: [Key] -> [Key] -> [Key] -> Bool +pOrd2 xs ys zs = case (compare x y, compare y z) of + (EQ, o) -> compare x z == o + (o, EQ) -> compare x z == o + (LT, LT) -> compare x z == LT + (GT, GT) -> compare x z == GT + (LT, GT) -> True -- ys greater than xs and zs. + (GT, LT) -> True + where + x = S.fromList xs + y = S.fromList ys + z = S.fromList zs + +pOrd3 :: [Key] -> [Key] -> Bool +pOrd3 xs ys = case (compare x y, compare y x) of + (EQ, EQ) -> True + (LT, GT) -> True + (GT, LT) -> True + _ -> False + where + x = S.fromList xs + y = S.fromList ys + +pOrdEq :: [Key] -> [Key] -> Bool +pOrdEq xs ys = case (compare x y, x == y) of + (EQ, True) -> True + (LT, False) -> True + (GT, False) -> True + _ -> False + where + x = S.fromList xs + y = S.fromList ys + +pReadShow :: [Key] -> Bool +pReadShow xs = Set.fromList xs == read (show (Set.fromList xs)) + +pFoldable :: [Int] -> Bool +pFoldable = (List.sort . Foldable.foldr (:) []) `eq` + (List.sort . Foldable.foldr (:) []) + +pPermutationEq :: [Key] -> [Int] -> Bool +pPermutationEq xs is = S.fromList xs == S.fromList ys + where + ys = shuffle is xs + shuffle idxs = List.map snd + . List.sortBy (comparing fst) + . List.zip (idxs ++ [List.maximum (0:is) + 1 ..]) + +pHashable :: [Key] -> [Int] -> Int -> Property +pHashable xs is salt = + x == y ==> hashWithSalt salt x === hashWithSalt salt y + where + xs' = List.nub xs + ys = shuffle is xs' + x = S.fromList xs' + y = S.fromList ys + shuffle idxs = List.map snd + . List.sortBy (comparing fst) + . List.zip (idxs ++ [List.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 = (List.sort . foldrSet (:) []) `eq` + (List.sort . S.foldr (:) []) + +foldrSet :: (a -> b -> b) -> b -> Set.Set a -> b +foldrSet = Set.foldr + +pFoldl' :: Int -> [Int] -> Bool +pFoldl' z0 = foldl'Set (+) z0 `eq` S.foldl' (+) z0 + +foldl'Set :: (a -> b -> a) -> a -> Set.Set b -> a +foldl'Set = Set.foldl' + +------------------------------------------------------------------------ +-- ** Filter + +pFilter :: [Key] -> Bool +pFilter = Set.filter odd `eq_` S.filter odd + +------------------------------------------------------------------------ +-- ** Conversions + +pToList :: [Key] -> Bool +pToList = Set.toAscList `eq` toAscList + +------------------------------------------------------------------------ +-- * Test list + +tests :: TestTree +tests = testGroup "Data.HashSet" + [ + -- Instances + testGroup "instances" + [ testProperty "==" pEq + , testProperty "Permutation ==" pPermutationEq + , testProperty "/=" pNeq + , testProperty "compare reflexive" pOrd1 + , testProperty "compare transitive" pOrd2 + , testProperty "compare antisymmetric" pOrd3 + , testProperty "Ord => Eq" pOrdEq + , 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) + +------------------------------------------------------------------------ +-- * Helpers + +toAscList :: Ord a => S.HashSet a -> [a] +toAscList = List.sort . S.toList diff --git a/tests/Properties/List.hs b/tests/Properties/List.hs new file mode 100644 --- /dev/null +++ b/tests/Properties/List.hs @@ -0,0 +1,64 @@ +module Properties.List (tests) where + +import Data.HashMap.Internal.List +import Data.List (nub, sort, sortBy) +import Data.Ord (comparing) +import Test.QuickCheck (Property, property, (===), (==>)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +tests :: TestTree +tests = testGroup "Data.HashMap.Internal.List" + [ testProperty "isPermutationBy" pIsPermutation + , testProperty "isPermutationBy of different length" pIsPermutationDiffLength + , testProperty "pUnorderedCompare" pUnorderedCompare + , testGroup "modelUnorderedCompare" + [ testProperty "reflexive" modelUnorderedCompareRefl + , testProperty "anti-symmetric" modelUnorderedCompareAntiSymm + , testProperty "transitive" modelUnorderedCompareTrans + ] + ] + +pIsPermutation :: [Char] -> [Int] -> Bool +pIsPermutation xs is = isPermutationBy (==) xs xs' + where + is' = nub is ++ [maximum (0:is) + 1 ..] + xs' = map fst . sortBy (comparing snd) $ zip xs is' + +pIsPermutationDiffLength :: [Int] -> [Int] -> Property +pIsPermutationDiffLength xs ys = + length xs /= length ys ==> isPermutationBy (==) xs ys === False + +-- | Homogenous version of 'unorderedCompare' +-- +-- *Compare smallest non-equal elements of the two lists*. +modelUnorderedCompare :: Ord a => [a] -> [a] -> Ordering +modelUnorderedCompare as bs = compare (sort as) (sort bs) + +modelUnorderedCompareRefl :: [Int] -> Property +modelUnorderedCompareRefl xs = modelUnorderedCompare xs xs === EQ + +modelUnorderedCompareAntiSymm :: [Int] -> [Int] -> Property +modelUnorderedCompareAntiSymm xs ys = case a of + EQ -> b === EQ + LT -> b === GT + GT -> b === LT + where + a = modelUnorderedCompare xs ys + b = modelUnorderedCompare ys xs + +modelUnorderedCompareTrans :: [Int] -> [Int] -> [Int] -> Property +modelUnorderedCompareTrans xs ys zs = + case (modelUnorderedCompare xs ys, modelUnorderedCompare ys zs) of + (EQ, yz) -> xz === yz + (xy, EQ) -> xz === xy + (LT, LT) -> xz === LT + (GT, GT) -> xz === GT + (LT, GT) -> property True + (GT, LT) -> property True + where + xz = modelUnorderedCompare xs zs + +pUnorderedCompare :: [Int] -> [Int] -> Property +pUnorderedCompare xs ys = + unorderedCompare compare xs ys === modelUnorderedCompare xs ys diff --git a/tests/Regressions.hs b/tests/Regressions.hs --- a/tests/Regressions.hs +++ b/tests/Regressions.hs @@ -1,32 +1,33 @@ +{-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -module Main where +{-# LANGUAGE UnboxedTuples #-} +module Regressions (tests) where -import Control.Exception (evaluate) -import Control.Monad (replicateM) -import Data.Hashable (Hashable(..)) -import qualified Data.HashMap.Strict as HM -import qualified Data.HashMap.Lazy as HML -import Data.List (delete) -import Data.Maybe -import GHC.Exts (touch#) -import GHC.IO (IO (..)) -import System.Mem (performGC) -import System.Mem.Weak (mkWeakPtr, deRefWeak) -import System.Random (randomIO) -import Test.HUnit (Assertion, assert) -import Test.Framework (Test, defaultMain) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) +import Control.Exception (evaluate) +import Control.Monad (replicateM) +import Data.Hashable (Hashable (..)) +import Data.List (delete) +import Data.Maybe (isJust, isNothing) +import GHC.Exts (touch#) +import GHC.IO (IO (..)) +import System.Mem (performGC) +import System.Mem.Weak (deRefWeak, mkWeakPtr) +import System.Random (randomIO) +import Test.HUnit (Assertion, assert) import Test.QuickCheck +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) +import Test.Tasty.QuickCheck (testProperty) +import qualified Data.HashMap.Lazy as HML +import qualified Data.HashMap.Strict as HMS + issue32 :: Assertion -issue32 = assert $ isJust $ HM.lookup 7 m' +issue32 = assert $ isJust $ HMS.lookup 7 m' where ns = [0..16] :: [Int] - m = HM.fromList (zip ns (repeat [])) - m' = HM.delete 10 m + m = HMS.fromList (zip ns (repeat [])) + m' = HMS.delete 10 m ------------------------------------------------------------------------ -- Issue #39 @@ -36,8 +37,8 @@ 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 ..]) + hm1 = HMS.fromList ([a, b] `zip` [1, 1 :: Int ..]) + hm2 = HMS.fromList ([b, a] `zip` [1, 1 :: Int ..]) a = (1, -1) :: (Int, Int) b = (-1, 1) :: (Int, Int) @@ -76,10 +77,10 @@ propEqAfterDelete (Keys keys) = let keyMap = mapFromKeys keys k = head keys - in HM.delete k keyMap == mapFromKeys (delete k keys) + in HMS.delete k keyMap == mapFromKeys (delete k keys) -mapFromKeys :: [Int] -> HM.HashMap Int () -mapFromKeys keys = HM.fromList (zip keys (repeat ())) +mapFromKeys :: [Int] -> HMS.HashMap Int () +mapFromKeys keys = HMS.fromList (zip keys (repeat ())) ------------------------------------------------------------------------ -- Issue #254 @@ -117,7 +118,7 @@ i :: Int <- randomIO let oldV = show i weakV <- mkWeakPtr oldV Nothing - mp <- evaluate $ HM.insert (KC 1) "3" $ HM.fromList [(KC 0, "1"), (KC 1, oldV)] + mp <- evaluate $ HMS.insert (KC 1) "3" $ HMS.fromList [(KC 0, "1"), (KC 1, oldV)] performGC res <- deRefWeak weakV touch mp @@ -126,8 +127,8 @@ ------------------------------------------------------------------------ -- * Test list -tests :: [Test] -tests = +tests :: TestTree +tests = testGroup "Regression tests" [ testCase "issue32" issue32 , testCase "issue39a" issue39 @@ -135,9 +136,3 @@ , testCase "issue254 lazy" issue254Lazy , testCase "issue254 strict" issue254Strict ] - ------------------------------------------------------------------------- --- * Test harness - -main :: IO () -main = defaultMain tests diff --git a/tests/Strictness.hs b/tests/Strictness.hs --- a/tests/Strictness.hs +++ b/tests/Strictness.hs @@ -1,21 +1,24 @@ -{-# LANGUAGE CPP, FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Main (main) where +module Strictness (tests) where -import Data.Hashable (Hashable(hashWithSalt)) +import Control.Arrow (second) +import Control.Monad (guard) +import Data.Foldable (foldl') +import Data.HashMap.Strict (HashMap) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.Maybe (fromMaybe, isJust) import Test.ChasingBottoms.IsBottom -import Test.Framework (Test, defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Arbitrary(arbitrary), Property, (===), (.&&.)) +import Test.QuickCheck (Arbitrary (arbitrary), Property, (.&&.), + (===)) import Test.QuickCheck.Function -import Test.QuickCheck.Poly (A) -import Data.Maybe (fromMaybe, isJust) -import Control.Arrow (second) -import Control.Monad (guard) -import Data.Foldable (foldl') +import Test.QuickCheck.Poly (A) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) -import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM -- Key type that generates more hash collisions. @@ -149,8 +152,8 @@ ------------------------------------------------------------------------ -- * Test list -tests :: [Test] -tests = +tests :: TestTree +tests = testGroup "Strictness" [ -- Basic interface testGroup "HashMap.Strict" @@ -174,12 +177,6 @@ , testProperty "fromListWith is value-strict" pFromListWithValueResultStrict ] ] - ------------------------------------------------------------------------- --- * Test harness - -main :: IO () -main = defaultMain tests ------------------------------------------------------------------------ -- * Utilities diff --git a/unordered-containers.cabal b/unordered-containers.cabal --- a/unordered-containers.cabal +++ b/unordered-containers.cabal @@ -1,5 +1,5 @@ name: unordered-containers -version: 0.2.16.0 +version: 0.2.17.0 synopsis: Efficient hashing-based container types description: Efficient hashing-based container types. The containers have been @@ -18,7 +18,7 @@ license: BSD3 license-file: LICENSE author: Johan Tibell -maintainer: johan.tibell@gmail.com, David.Feuer@gmail.com +maintainer: simon.jakobi@gmail.com, David.Feuer@gmail.com Homepage: https://github.com/haskell-unordered-containers/unordered-containers bug-reports: https://github.com/haskell-unordered-containers/unordered-containers/issues copyright: 2010-2014 Johan Tibell @@ -30,13 +30,12 @@ tested-with: GHC ==9.2.1 - || ==9.0.1 + || ==9.0.2 || ==8.10.7 || ==8.8.4 || ==8.6.5 || ==8.4.4 || ==8.2.2 - || ==8.0.2 flag debug description: Enable debug support @@ -54,9 +53,10 @@ Data.HashSet.Internal build-depends: - base >= 4.9 && < 5, - deepseq >= 1.1, - hashable >= 1.0.1.1 && < 1.5 + base >= 4.10 && < 5, + deepseq >= 1.4.3, + hashable >= 1.2.5 && < 1.5, + template-haskell < 2.19 default-language: Haskell2010 @@ -69,119 +69,33 @@ ghc-options: -Wall -O2 -fwarn-tabs -ferror-spans - if impl (ghc < 8.2) - -- This is absolutely necessary (but not sufficient) for correctness due to - -- the referential-transparency-breaking mutability in unsafeInsertWith. See - -- #147 and GHC #13615 for details. The bug was fixed in GHC 8.2. - ghc-options: -feager-blackholing 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.5.8, - hashable >= 1.0.1.1, - QuickCheck >= 2.4.0.1, - test-framework >= 0.3.3, - test-framework-quickcheck2 >= 0.2.9, - unordered-containers - - default-language: Haskell2010 - 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.5.8, - hashable >= 1.0.1.1, - QuickCheck >= 2.4.0.1, - test-framework >= 0.3.3, - test-framework-quickcheck2 >= 0.2.9, - unordered-containers - - default-language: Haskell2010 - ghc-options: -Wall - cpp-options: -DASSERTS -DSTRICT - -test-suite hashset-properties +test-suite unordered-containers-tests hs-source-dirs: tests - main-is: HashSetProperties.hs + main-is: Main.hs type: exitcode-stdio-1.0 - - build-depends: - base, - containers >= 0.4.2.0, - hashable >= 1.0.1.1, - QuickCheck >= 2.4.0.1, - test-framework >= 0.3.3, - test-framework-quickcheck2 >= 0.2.9, - unordered-containers - - default-language: Haskell2010 - ghc-options: -Wall - cpp-options: -DASSERTS - -test-suite list-tests - hs-source-dirs: tests . - main-is: List.hs other-modules: - Data.HashMap.Internal.List - type: exitcode-stdio-1.0 - - build-depends: - base, - containers >= 0.4, - QuickCheck >= 2.4.0.1, - test-framework >= 0.3.3, - test-framework-quickcheck2 >= 0.2.9 - - default-language: Haskell2010 - ghc-options: -Wall - cpp-options: -DASSERTS - -test-suite regressions - hs-source-dirs: tests - main-is: Regressions.hs - type: exitcode-stdio-1.0 + Regressions + Properties + Properties.HashMapLazy + Properties.HashMapStrict + Properties.HashSet + Properties.List + Strictness build-depends: base, - hashable >= 1.0.1.1, + ChasingBottoms, + containers >= 0.5.8, + hashable, HUnit, QuickCheck >= 2.4.0.1, random, - test-framework >= 0.3.3, - test-framework-hunit, - test-framework-quickcheck2, - unordered-containers - - default-language: Haskell2010 - 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, + tasty >= 1.4.0.3, + tasty-hunit >= 0.10.0.3, + tasty-quickcheck >= 0.10.1.2, unordered-containers default-language: Haskell2010 @@ -202,16 +116,19 @@ base >= 4.8.0, bytestring >= 0.10.0.0, containers, - gauge >= 0.2.5 && < 0.3, - deepseq >= 1.4, - hashable >= 1.0.1.1, + deepseq, + hashable, hashmap, mtl, random, + tasty-bench >= 0.3.1, unordered-containers default-language: Haskell2010 - ghc-options: -Wall -O2 -rtsopts -fwarn-tabs -ferror-spans + ghc-options: -Wall -O2 -rtsopts -with-rtsopts=-A32m + if impl(ghc >= 8.10) + ghc-options: "-with-rtsopts=-A32m --nonmoving-gc" + -- cpp-options: -DBENCH_containers_Map -DBENCH_containers_IntMap -DBENCH_hashmap_Map source-repository head type: git