Add tests to size invariant

tests/Size.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
+
+-- | Tests for size field invariant in 'HashMap' wrapper introduced in GitHub
+-- PR #170.
+
+module Main (main) where
+
+import Control.Monad.ST (ST)
+#if defined(STRICT)
+import qualified Data.HashMap.Strict as HM
+#else
+import qualified Data.HashMap.Lazy as HM
+#endif
+import Data.List (scanl')
+
+import Test.QuickCheck (Arbitrary, Property, conjoin, oneof)
+import Test.Framework (Test, defaultMain, testGroup)
+
+-- 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
+
+-- Datatype representing the actions that can potentially change a hashmap's
+-- size modulo repetition i.e. 'mapMaybe' and 'filter' are essentially
+-- equivalent in how they modify a hashmap, so only one ('filter') is tested.
+data HashMapAction =
+    | Insert Key Int
+    | Delete Key
+    | Union (HM.HashMap Key Int)
+    | Intersection (HM.HashMap Key Int)
+    | Difference (HM.HashMap Key Int)
+    | Filter (Int -> Bool)
+
+instance Arbitrary HashMapAction where
+    arbitrary = oneof
+        [ Insert <$> arbitrary <*> arbitrary
+        , Delete <$> arbitrary
+        , Union <$> arbitrary
+        , Intersection <$> arbitrary
+        , Difference <$> arbitrary
+        , pure $ Filter even
+        ]
+
+-- Simple way of representing a hashmap and its size without having to
+-- use 'size', which is the function to be tested. As such, its use is
+-- avoided and the 'Int' field of the tuple is used instead.
+type HashMapSt = (Int, HM.HashMap Key Int)
+
+-- | Applies a 'HashMapAction' to 'HashMapSt', updating the hashmap's
+-- size after the operation.
+applyActionToState :: HashMapSt -> HashMapAction -> HashMapSt
+applyActionToState  p@(sz, hm) (Insert k v)
+    | HM.member k hm = (sz + 1, HM.insert k v hm)
+    | otherwise      = p
+applyActionToState p@(sz, hm) (Delete k)
+    | HM.member k hm = p
+        Nothing -> p
+    | otherwise      = (sz - 1, HM.delete k hm)
+applyActionToState (sz, hm) (Union hm') =
+    let sz'          = length $ HM.toList hm'
+        lenIntersect = length [ k | k <- HM.keys hm, HM.member k hm' ]
+        newLen       = sz + sz' - lenIntersect
+    in (newLen, HM.union hm hm')
+applyActionToState (sz, hm) (Intersection hm') =
+    let lenIntersect = length [ k | k <- HM.keys hm, HM.member k hm' ]
+    in (lenIntersect, HM.intersect hm hm')
+applyActionToState (sz, hm) (Difference hm')=
+    let lenDiff = length [ k | k <- HM.keys hm, not $ HM.member k hm' ]
+        (lenDiff, HM.difference hm hm')
+applyActionToState (sz, hm) (Filter pred) =
+    let lenFilter = length [ (k, v) | (k, v) <- HM.elems hm, pred v ]
+    in (lenFilter, HM.filter pred hm)
+
+-- | Property to check that after each operation that may change a hashmap's
+-- size, the 'Int' field in the 'HashMap' wrapper always correctly represents
+-- the hashmap's size.
+sizeInvariantProperty :: [HashMapAction] -> Property
+sizeInvariantProperty actionList =
+    conjoin .
+    map (\(sz, hm) -> sz == HM.size hm) .
+    scanl' applyActionToState (0, mempty) $ actionList
+
+------------------------------------------------------------------------
+-- * Test list
+
+tests :: [Test]
+tests = [
+          testGroup "size invariant checks"
+          [ sizeInvariantProperty
+          ]
+        ]
+
+------------------------------------------------------------------------
+-- * Test harness
+
+main :: IO ()
+main = defaultMain tests

unordered-containers.cabal

@@ -85,6 +85,23 @@ test-suite hashmap-strict-properties
   ghc-options: -Wall
   cpp-options: -DASSERTS -DSTRICT
 
+test-suite hashmap-size-invariant
+  hs-source-dirs: tests
+  main-is: Size.hs
+  type: exitcode-stdio-1.0
+
+  build-depends:
+    base,
+    containers >= 0.4,
+    hashable >= 1.0.1.1,
+    QuickCheck >= 2.4.0.1,
+    test-framework >= 0.3.3,
+    test-framework-quickcheck2 >= 0.2.9,
+    unordered-containers
+
+  ghc-options: -Wall
+  cpp-options: -DASSERTS -DSTRICT
+
 test-suite hashset-properties
   hs-source-dirs: tests
   main-is: HashSetProperties.hs