Add Expr to make better generator for tests

Author: phadej

tests/HashMapProperties.hs

@@ -21,12 +21,7 @@ import Test.QuickCheck (Arbitrary, Property, (==>), (===))
 import Test.Framework (Test, defaultMain, testGroup)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
 
--- Key type that generates more hash collisions.
-newtype Key = K { unK :: Int }
-            deriving (Arbitrary, Eq, Ord, Read, Show)
-
-instance Hashable Key where
-    hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20
+import Utils
 
 ------------------------------------------------------------------------
 -- * Properties

tests/HashSetProperties.hs

@@ -11,25 +11,20 @@ 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.QuickCheck (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
+import Utils
 
 ------------------------------------------------------------------------
 -- * Properties
 
 ------------------------------------------------------------------------
 -- ** Instances
 
-pEq :: [Key] -> [Key] -> Bool
-pEq xs = (Set.fromList xs ==) `eq` (S.fromList xs ==)
+pEq :: Expr Key () -> Expr Key () -> Bool
+pEq xs = (evalExprOrdSet xs ==) `eqExpr` (evalExprSet xs ==)
 
 pNeq :: [Key] -> [Key] -> Bool
 pNeq xs = (Set.fromList xs /=) `eq` (S.fromList xs /=)
@@ -225,6 +220,16 @@ eq :: (Eq a, Hashable a, Ord a, Eq b)
    -> Bool                -- ^ True if the functions are equivalent
 eq f g xs = g (S.fromList xs) == f (Set.fromList xs)
 
+-- | Check that a function operating on a 'HashMap' is equivalent to
+-- one operating on a 'Model'.
+eqExpr :: (Eq a, Hashable a, Ord a, Eq b, Show b)
+   => (Model a -> b)      -- ^ Function that modifies a 'Model' in the same
+                          -- way
+   -> (S.HashSet a -> b)  -- ^ Function that modified a 'HashSet'
+   -> Expr a ()           -- ^ Initial content of the 'HashSet' and 'Model'
+   -> Property            -- ^ True if the functions are equivalent
+eqExpr f g xs = g (evalExprSet xs) === f (evalExprOrdSet 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

tests/Strictness.hs

@@ -3,7 +3,7 @@
 
 module Main (main) where
 
-import Data.Hashable (Hashable(hashWithSalt))
+import Data.Hashable (Hashable)
 import Test.ChasingBottoms.IsBottom
 import Test.Framework (Test, defaultMain, testGroup)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
@@ -23,16 +23,11 @@ import Prelude hiding (all)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HM
 
--- Key type that generates more hash collisions.
-newtype Key = K { unK :: Int }
-            deriving (Arbitrary, Eq, Ord, Show)
-
-instance Hashable Key where
-    hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20
+import Utils
 
 instance (Arbitrary k, Arbitrary v, Eq k, Hashable k) =>
          Arbitrary (HashMap k v) where
-    arbitrary = HM.fromList `fmap` arbitrary
+    arbitrary = evalExprStrict `fmap` arbitrary
 
 instance Show (Int -> Int) where
     show _ = "<function>"

tests/Utils.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-- | Test utilities
+module Utils
+    ( Key (..)
+    , Expr (..)
+    , evalExprStrict
+    , evalExprLazy
+    , evalExprSet
+    , evalExprOrdSet
+    ) where
+
+import Control.Applicative (liftA2, liftA3)
+import Data.Hashable (Hashable(hashWithSalt))
+import Test.QuickCheck (Arbitrary(arbitrary,shrink), oneof, sized)
+
+import qualified Data.HashMap.Strict as HMS
+import qualified Data.HashMap.Lazy as HML
+import qualified Data.HashSet as HS
+import qualified Data.Set as Set
+
+-- | A key with collision-prone Hashable instance
+------------------------------------------------------------------------
+
+-- Key type that generates more hash collisions.
+newtype Key = K { unK :: Int }
+   deriving (Arbitrary, Enum, Eq, Ord, Read, Show, Integral, Num, Real)
+
+instance Hashable Key where
+    hashWithSalt salt k = hashWithSalt salt (unK k) `mod` 20
+
+-- | A HashMap/HashSet building expression
+------------------------------------------------------------------------
+
+data Expr k v
+    = ExprEmpty
+    | ExprSingleton k v
+    | ExprInsert k v (Expr k v)
+    | ExprDelete k (Expr k v)
+    | ExprUnion (Expr k v) (Expr k v)
+  deriving Show
+
+instance (Arbitrary k, Arbitrary v) => Arbitrary (Expr k v) where
+    arbitrary = sized arb
+      where
+        arb n | n <= 0 = oneof leafs
+        arb n = oneof $ leafs ++
+            [ liftA3 ExprInsert arbitrary arbitrary (arb (n - 1))
+            , liftA2 ExprDelete arbitrary (arb (n - 1))
+            , liftA2 ExprUnion (arb (n `div` 2)) (arb (n - n `div` 2))
+            ]
+
+        leafs =
+            [ return ExprEmpty
+            , liftA2 ExprSingleton arbitrary arbitrary
+            ]
+
+    shrink ExprEmpty
+        = []
+    shrink (ExprSingleton k v) =
+        ExprEmpty : uncurry ExprSingleton `map` shrink (k, v)
+    shrink (ExprInsert k v e) =
+        ExprEmpty : e : uncurry3 ExprInsert `map` shrink (k, v, e)
+    shrink (ExprDelete k e) =
+        ExprEmpty : e : uncurry ExprDelete `map` shrink (k, e)
+    shrink (ExprUnion a b) =
+        ExprEmpty : a : b : uncurry ExprUnion `map` shrink (a, b)
+
+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
+uncurry3 f (a, b, c) = f a b c
+
+evalExprStrict :: (Eq k, Hashable k) => Expr k v -> HMS.HashMap k v
+evalExprStrict = go
+  where
+    go ExprEmpty           = HMS.empty
+    go (ExprSingleton k v) = HMS.singleton k v
+    go (ExprInsert k v e)  = HMS.insert k v (go e)
+    go (ExprDelete k e)    = HMS.delete k (go e)
+    go (ExprUnion a b)     = HMS.union (go a) (go b)
+
+evalExprLazy :: (Eq k, Hashable k) => Expr k v -> HML.HashMap k v
+evalExprLazy = go
+  where
+    go ExprEmpty           = HML.empty
+    go (ExprSingleton k v) = HML.singleton k v
+    go (ExprInsert k v e)  = HML.insert k v (go e)
+    go (ExprDelete k e)    = HML.delete k (go e)
+    go (ExprUnion a b)     = HML.union (go a) (go b)
+
+evalExprSet :: (Eq k, Hashable k) => Expr k () -> HS.HashSet k
+evalExprSet = go
+  where
+    go ExprEmpty           = HS.empty
+    go (ExprSingleton k _) = HS.singleton k
+    go (ExprInsert k _ e)  = HS.insert k (go e)
+    go (ExprDelete k e)    = HS.delete k (go e)
+    go (ExprUnion a b)     = HS.union (go a) (go b)
+
+evalExprOrdSet :: (Ord k) => Expr k () -> Set.Set k
+evalExprOrdSet = go
+  where
+    go ExprEmpty           = Set.empty
+    go (ExprSingleton k _) = Set.singleton k
+    go (ExprInsert k _ e)  = Set.insert k (go e)
+    go (ExprDelete k e)    = Set.delete k (go e)
+    go (ExprUnion a b)     = Set.union (go a) (go b)

unordered-containers.cabal

@@ -61,6 +61,7 @@ library
 test-suite hashmap-lazy-properties
   hs-source-dirs: tests
   main-is: HashMapProperties.hs
+  other-modules: Utils
   type: exitcode-stdio-1.0
 
   build-depends:
@@ -78,6 +79,7 @@ test-suite hashmap-lazy-properties
 test-suite hashmap-strict-properties
   hs-source-dirs: tests
   main-is: HashMapProperties.hs
+  other-modules: Utils
   type: exitcode-stdio-1.0
 
   build-depends:
@@ -95,6 +97,7 @@ test-suite hashmap-strict-properties
 test-suite hashset-properties
   hs-source-dirs: tests
   main-is: HashSetProperties.hs
+  other-modules: Utils
   type: exitcode-stdio-1.0
 
   build-depends:
@@ -147,6 +150,7 @@ test-suite regressions
 test-suite strictness-properties
   hs-source-dirs: tests
   main-is: Strictness.hs
+  other-modules: Utils
   type: exitcode-stdio-1.0
 
   build-depends: