Skip to content

Commit 2b07cc7

Browse files
rockbmbrockbmb
committed
Add tests to size-modifying operations
* to make sure the size field's invariant (it always represents the hashmap's size) is kept, tests were added that generate random hashmap "programs" (i.e. valid sequences of size changing operations on hashmaps: insertion, insertion with a function to combine values, deletion, union, intersection, difference, filtering) and verify that the invariant is kept. For more information on this, see the "Testing Monadic Code With QuickCheck" paper. Other tests for `fromList/fromListWith` were also added.
1 parent a928518 commit 2b07cc7

File tree

2 files changed

+265
-0
lines changed

2 files changed

+265
-0
lines changed

‎tests/Size.hs

Lines changed: 246 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,246 @@
1+
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE DeriveGeneric #-}
3+
{-# LANGUAGE FlexibleInstances #-}
4+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+
{-# LANGUAGE RecordWildCards #-}
6+
7+
-- | Tests for size field invariant in @HashMap@ wrapper introduced in GitHub
8+
-- PR #170.
9+
10+
module Main (main) where
11+
12+
import Data.Hashable (Hashable(hashWithSalt))
13+
import Data.Maybe (isJust, isNothing)
14+
#if defined(STRICT)
15+
import qualified Data.HashMap.Strict as HM
16+
#else
17+
import qualified Data.HashMap.Lazy as HM
18+
#endif
19+
import qualified Data.Map as M
20+
#if !MIN_VERSION_base(4,8,0)
21+
import Control.Applicative (pure, (<*>))
22+
import Data.Functor ((<$>))
23+
import Data.Monoid (mempty)
24+
#endif
25+
import GHC.Generics (Generic)
26+
27+
import Test.QuickCheck (Arbitrary (..), Property, conjoin, frequency, (===),
28+
genericShrink)
29+
import Test.Framework (Test, defaultMain, testGroup)
30+
import Test.Framework.Providers.QuickCheck2 (testProperty)
31+
32+
-- Key type that generates more hash collisions.
33+
newtype Key = K { unK :: Int }
34+
deriving (Arbitrary, Eq, Ord, Read, Show, Generic)
35+
36+
instance Hashable Key where
37+
hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20
38+
39+
-- | Property to check that the hashmap built by @fromList@ applied to a list
40+
-- without repeating keys will have the right size i.e. equal to the list's
41+
-- length.
42+
fromListProperty :: M.Map Key Int -> Bool
43+
fromListProperty m =
44+
let sz = M.size m
45+
list = M.toList m
46+
hm = HM.fromList list
47+
in sz == HM.size hm
48+
49+
-- | Property to check that the hashmap built by @fromListWith@ applied to a
50+
--list without repeating keys will have the right size i.e. equal to the list's
51+
-- length.
52+
fromListWithProperty :: M.Map Key Int -> Bool
53+
fromListWithProperty m =
54+
let sz = M.size m
55+
list = M.toList m
56+
hm = HM.fromListWith (+) list
57+
in sz == HM.size hm
58+
59+
{- Note on @HashMapAction@ datatype
60+
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
61+
62+
Some actions correspond to functions from @Data.HashMap.Base@ that require
63+
function arguments i.e. @insertWith@ requires a @v -> v -> v@ argument.
64+
However, function values do not have a @Show@ instance, which is undesirable because if QuickCheck fails it'll print the values for which a certain test failed.
65+
To get around this, simple functions like @(+)@ are used instead.
66+
67+
Furthermore, when functions have a @Bool@ or a @Maybe v@ argument and/or
68+
result value, simple predicates like @even/odd@ are used to "mimic" such
69+
functions. An example: @mapMaybe@ has an argument @f::(a -> Maybe b)@, but in
70+
these tests all hashmaps are instantiated as @HashMap Key Int@, so no parameter
71+
is passed to @MapMaybe@ in @HashMapAction@ and @f = \v -> if odd v then Just
72+
(succ v) else Nothing@ is used instead.
73+
-}
74+
75+
-- Datatype representing the actions that can potentially change a hashmap's
76+
-- size.
77+
data HashMapAction
78+
= Insert Key Int
79+
| InsertWith Key Int
80+
| Adjust Key
81+
| Update (Maybe Int) Key
82+
| Alter (Maybe Int) Key
83+
| Delete Key
84+
| Union (HM.HashMap Key Int)
85+
| UnionWith (HM.HashMap Key Int)
86+
| UnionWithKey (HM.HashMap Key Int)
87+
| Intersection (HM.HashMap Key Int)
88+
| IntersectionWith (HM.HashMap Key Int)
89+
| IntersectionWithKey (HM.HashMap Key Int)
90+
| Difference (HM.HashMap Key Int)
91+
| DifferenceWith (HM.HashMap Key Int)
92+
| Filter
93+
| FilterWithKey
94+
| Map
95+
| MapMaybe
96+
| MapMaybeWithKey
97+
deriving (Eq, Show, Generic)
98+
99+
instance Arbitrary (HM.HashMap Key Int) where
100+
arbitrary = HM.fromList <$> arbitrary
101+
102+
-- Here, higher weights are used for operations that increase the size of the
103+
-- hashmap so that its size is more likely to grow instead of nearing and
104+
-- staying 0, creating more interesting sequences of actions to be tested.
105+
instance Arbitrary HashMapAction where
106+
arbitrary = frequency
107+
[ (4, Insert <$> arbitrary <*> arbitrary)
108+
, (4, InsertWith <$> arbitrary <*> arbitrary)
109+
, (4, Union <$> arbitrary)
110+
, (4, UnionWith <$> arbitrary)
111+
, (4, UnionWithKey <$> arbitrary)
112+
, (1, Adjust <$> arbitrary)
113+
, (1, Update <$> arbitrary <*> arbitrary)
114+
, (1, Alter <$> arbitrary <*> arbitrary)
115+
, (1, Delete <$> arbitrary)
116+
, (1, Intersection <$> arbitrary)
117+
, (1, IntersectionWith <$> arbitrary)
118+
, (1, IntersectionWithKey <$> arbitrary)
119+
, (1, Difference <$> arbitrary)
120+
, (1, DifferenceWith <$> arbitrary)
121+
, (1, pure Filter)
122+
, (1, pure FilterWithKey)
123+
, (1, pure Map)
124+
, (1, pure MapMaybe)
125+
, (1, pure MapMaybeWithKey)
126+
]
127+
shrink = genericShrink
128+
129+
-- Simple way of representing a hashmap and its size without having to
130+
-- use @size@, which is the function to be tested. As such, its use is
131+
-- avoided and the @Int@ field of the tuple is used instead.
132+
data HashMapState = HashMapState
133+
{ sz :: Int -- ^ The size of the @hm@ hashmap, also in this
134+
-- datatype, obtained without using @size@.
135+
, hm :: HM.HashMap Key Int -- ^ The hashmap resultant of every
136+
-- @HashMapAction@ from the start of the test.
137+
} deriving (Show, Eq)
138+
139+
-- | Applies a @HashMapAction@ to @HashMapState@, updating the hashmap's
140+
-- size after the operation.
141+
applyActionToState :: HashMapState -> HashMapAction -> HashMapState
142+
applyActionToState HashMapState {..} (Insert k v)
143+
| HM.member k hm = HashMapState sz hm'
144+
| otherwise = HashMapState (sz + 1) hm'
145+
where
146+
hm' = HM.insert k v hm
147+
applyActionToState HashMapState {..} (InsertWith k v)
148+
| HM.member k hm = HashMapState sz hm'
149+
| otherwise = HashMapState (sz + 1) hm'
150+
where
151+
hm' = HM.insertWith (+) k v hm
152+
applyActionToState HashMapState {..} (Adjust k) = HashMapState sz (HM.adjust succ k hm)
153+
applyActionToState HashMapState {..} (Update mk k)
154+
| HM.member k hm && isNothing mk = HashMapState (sz - 1) hm'
155+
| otherwise = HashMapState sz hm'
156+
where
157+
hm' = HM.update (const mk) k hm
158+
applyActionToState HashMapState {..} (Alter mv k) =
159+
case (HM.member k hm, mv) of
160+
(True, Just _) -> HashMapState sz hm'
161+
(True, Nothing) -> HashMapState (sz - 1) hm'
162+
(False, Just _) -> HashMapState (sz + 1) hm'
163+
(False, Nothing) -> HashMapState sz hm'
164+
where
165+
func = const mv
166+
hm' = HM.alter func k hm
167+
applyActionToState HashMapState {..} (Delete k)
168+
| HM.member k hm = HashMapState (sz - 1) hm'
169+
| otherwise = HashMapState sz hm'
170+
where
171+
hm' = HM.delete k hm
172+
applyActionToState HashMapState {..} (Union hm') =
173+
let sz' = length $ HM.toList hm'
174+
lenIntersect = length [ k | k <- HM.keys hm, HM.member k hm' ]
175+
newLen = sz + sz' - lenIntersect
176+
in HashMapState newLen (HM.union hm hm')
177+
applyActionToState HashMapState {..} (UnionWith hm') =
178+
let sz' = length $ HM.toList hm'
179+
lenIntersect = length [ k | k <- HM.keys hm, HM.member k hm' ]
180+
newLen = sz + sz' - lenIntersect
181+
in HashMapState newLen (HM.unionWith (+) hm hm')
182+
applyActionToState HashMapState {..} (UnionWithKey hm') =
183+
let sz' = length $ HM.toList hm'
184+
lenIntersect = length [ k | k <- HM.keys hm, HM.member k hm' ]
185+
newLen = sz + sz' - lenIntersect
186+
fun k v1 v2 = unK k + v1 + v2
187+
in HashMapState newLen (HM.unionWithKey fun hm hm')
188+
applyActionToState HashMapState {..} (Intersection hm') =
189+
let lenIntersect = length [ k | k <- HM.keys hm, HM.member k hm' ]
190+
in HashMapState lenIntersect (HM.intersection hm hm')
191+
applyActionToState HashMapState {..} (IntersectionWith hm') =
192+
let lenIntersect = length [ k | k <- HM.keys hm, HM.member k hm' ]
193+
in HashMapState lenIntersect (HM.intersectionWith (+) hm hm')
194+
applyActionToState HashMapState {..} (IntersectionWithKey hm') =
195+
let lenIntersect = length [ k | k <- HM.keys hm, HM.member k hm' ]
196+
fun k v1 v2 = unK k + v1 + v2
197+
in HashMapState lenIntersect (HM.intersectionWithKey fun hm hm')
198+
applyActionToState HashMapState {..} (Difference hm') =
199+
let lenDiff = length [ k | k <- HM.keys hm, not $ HM.member k hm' ]
200+
in HashMapState lenDiff (HM.difference hm hm')
201+
applyActionToState HashMapState {..} (DifferenceWith hm') =
202+
let fun v w = if odd v then Just (v + w) else Nothing
203+
lenDiff = length [ k | (k, v) <- HM.toList hm, not $ HM.member k hm' && even v]
204+
in HashMapState lenDiff (HM.differenceWith fun hm hm')
205+
applyActionToState HashMapState {..} Filter =
206+
let lenFilter = length [ (k, v) | (k, v) <- HM.toList hm, even v ]
207+
in HashMapState lenFilter (HM.filter even hm)
208+
applyActionToState HashMapState {..} FilterWithKey =
209+
let lenFilter = length [ (k, v) | (k, v) <- HM.toList hm, even $ (unK k) + v ]
210+
in HashMapState lenFilter (HM.filterWithKey (\k -> even . (+) (unK k)) hm)
211+
applyActionToState HashMapState {..} Map = HashMapState sz (HM.map succ hm)
212+
applyActionToState HashMapState {..} MapMaybe =
213+
let mapFun v = if odd v then Just (succ v) else Nothing
214+
lenMapMaybe = length [ (k, v) | (k, v) <- HM.toList hm, isJust (mapFun v)]
215+
in HashMapState lenMapMaybe (HM.mapMaybe mapFun hm)
216+
applyActionToState HashMapState {..} MapMaybeWithKey =
217+
let mapFun k v = if odd v then Just (unK k + succ v) else Nothing
218+
lenMapMaybe = length [ (k, v) | (k, v) <- HM.toList hm, isJust (mapFun k v)]
219+
in HashMapState lenMapMaybe (HM.mapMaybeWithKey mapFun hm)
220+
221+
-- | Property to check that after each operation that may change a hashmap's
222+
-- size, the @Int@ field in the @HashMap@ wrapper always correctly represents
223+
-- the hashmap's size.
224+
sizeInvariantProperty :: [HashMapAction] -> Property
225+
sizeInvariantProperty actionList =
226+
conjoin .
227+
map (\HashMapState {..} -> sz === HM.size hm) .
228+
scanl applyActionToState (HashMapState 0 mempty) $ actionList
229+
230+
------------------------------------------------------------------------
231+
-- * Test list
232+
233+
tests :: [Test]
234+
tests = [
235+
testGroup "size invariant checks"
236+
[ testProperty "size" sizeInvariantProperty
237+
, testProperty "fromList" fromListProperty
238+
, testProperty "fromListWith" fromListWithProperty
239+
]
240+
]
241+
242+
------------------------------------------------------------------------
243+
-- * Test harness
244+
245+
main :: IO ()
246+
main = defaultMain tests

‎unordered-containers.cabal

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -100,6 +100,24 @@ test-suite hashmap-strict-properties
100100
ghc-options: -Wall
101101
cpp-options: -DASSERTS -DSTRICT
102102

103+
test-suite hashmap-size-invariant
104+
hs-source-dirs: tests
105+
main-is: Size.hs
106+
type: exitcode-stdio-1.0
107+
108+
build-depends:
109+
base,
110+
containers >= 0.4,
111+
hashable >= 1.0.1.1,
112+
QuickCheck >= 2.4.0.1,
113+
test-framework >= 0.3.3,
114+
test-framework-quickcheck2 >= 0.2.9,
115+
unordered-containers
116+
117+
default-language: Haskell2010
118+
ghc-options: -Wall
119+
cpp-options: -DASSERTS -DSTRICT
120+
103121
test-suite hashset-properties
104122
hs-source-dirs: tests
105123
main-is: HashSetProperties.hs
@@ -200,6 +218,7 @@ benchmark benchmarks
200218
base >= 4.8.0,
201219
bytestring,
202220
containers,
221+
vector,
203222
criterion >= 1.0 && < 1.3,
204223
deepseq >= 1.1,
205224
deepseq-generics,

0 commit comments

Comments
 (0)