Merge pull request #111 from phadej/hashable-instances-fix

Hashable instances fix

Author: tibbe

.gitignore

@@ -6,3 +6,5 @@
 .hpc/
 /benchmarks/dist/*
 /dist/*
+.cabal-sandbox
+cabal.sandbox.config

Data/HashMap/Base.hs

@@ -201,9 +201,6 @@ instance Traversable (HashMap k) where
 instance (Eq k, Eq v) => Eq (HashMap k v) where
     (==) = equal
 
-instance (Hashable k, Hashable v) => Hashable (HashMap k v) where
-    hashWithSalt = foldlWithKey' (\h k v -> h `H.hashWithSalt` k `H.hashWithSalt` v)
-
 equal :: (Eq k, Eq v) => HashMap k v -> HashMap k v -> Bool
 equal t1 t2 = go (toList' t1 []) (toList' t2 [])
   where
@@ -221,11 +218,39 @@ equal t1 t2 = go (toList' t1 []) (toList' t2 [])
     go [] [] = True
     go _  _  = False
 
-    toList' (BitmapIndexed _ ary) a = A.foldr toList' a ary
-    toList' (Full ary)            a = A.foldr toList' a ary
-    toList' l@(Leaf _ _)          a = l : a
-    toList' c@(Collision _ _)     a = c : a
-    toList' Empty                 a = a
+instance (Hashable k, Hashable v) => Hashable (HashMap k v) where
+    hashWithSalt salt hm = go salt (toList' hm [])
+      where
+        go :: Int -> [HashMap k v] -> Int
+        go s [] = s
+        go s (Leaf _ l : tl)
+          = s `hashLeafWithSalt` l `go` tl
+        -- For collisions we hashmix hash value
+        -- and then array of values' hashes sorted
+        go s (Collision h a : tl)
+          = (s `H.hashWithSalt` h) `hashCollisionWithSalt` a `go` tl
+        go s (_ : tl) = s `go` tl
+
+        hashLeafWithSalt :: Int -> Leaf k v -> Int
+        hashLeafWithSalt s (L k v) = s `H.hashWithSalt` k `H.hashWithSalt` v
+
+        hashCollisionWithSalt :: Int -> A.Array (Leaf k v) -> Int
+        hashCollisionWithSalt s
+          = L.foldl' H.hashWithSalt s . arrayHashesSorted
+
+        arrayHashesSorted :: A.Array (Leaf k v) -> [Int]
+        arrayHashesSorted = L.sort . L.map leafValueHash . A.toList
+
+        leafValueHash :: Leaf k v -> Int
+        leafValueHash (L _ v) = H.hash v
+
+  -- Helper to get 'Leaf's and 'Collision's as a list.
+toList' :: HashMap k v -> [HashMap k v] -> [HashMap k v]
+toList' (BitmapIndexed _ ary) a = A.foldr toList' a ary
+toList' (Full ary)            a = A.foldr toList' a ary
+toList' l@(Leaf _ _)          a = l : a
+toList' c@(Collision _ _)     a = c : a
+toList' Empty                 a = a
 
 -- Helper function to detect 'Leaf's and 'Collision's.
 isLeafOrCollision :: HashMap k v -> Bool

Data/HashSet.hs

@@ -137,7 +137,7 @@ instance (Data a, Eq a, Hashable a) => Data (HashSet a) where
     dataCast1 f    = gcast1 f
 
 instance (Hashable a) => Hashable (HashSet a) where
-    hashWithSalt = foldl' hashWithSalt
+    hashWithSalt salt = hashWithSalt salt . asMap
 
 fromListConstr :: Constr
 fromListConstr = mkConstr hashSetDataType "fromList" [] Prefix

tests/HashMapProperties.hs

@@ -10,13 +10,14 @@ import qualified Data.Foldable as Foldable
 import Data.Function (on)
 import Data.Hashable (Hashable(hashWithSalt))
 import qualified Data.List as L
+import Data.Ord (comparing)
 #if defined(STRICT)
 import qualified Data.HashMap.Strict as HM
 #else
 import qualified Data.HashMap.Lazy as HM
 #endif
 import qualified Data.Map as M
-import Test.QuickCheck (Arbitrary, Property, (==>))
+import Test.QuickCheck (Arbitrary, Property, (==>), (===))
 import Test.Framework (Test, defaultMain, testGroup)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
 
@@ -49,6 +50,19 @@ 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
+    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
 
@@ -229,6 +243,7 @@ tests =
       , testProperty "Read/Show" pReadShow
       , testProperty "Functor" pFunctor
       , testProperty "Foldable" pFoldable
+      , testProperty "Hashable" pHashable
       ]
     -- Basic interface
     , testGroup "basic interface"

tests/HashSetProperties.hs

@@ -10,7 +10,8 @@ import Data.Hashable (Hashable(hashWithSalt))
 import qualified Data.List as L
 import qualified Data.HashSet as S
 import qualified Data.Set as Set
-import Test.QuickCheck (Arbitrary)
+import Data.Ord (comparing)
+import Test.QuickCheck (Arbitrary, Property, (==>), (===))
 import Test.Framework (Test, defaultMain, testGroup)
 import Test.Framework.Providers.QuickCheck2 (testProperty)
 
@@ -40,6 +41,25 @@ 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
+    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
 
@@ -113,9 +133,11 @@ tests =
     -- Instances
       testGroup "instances"
       [ testProperty "==" pEq
+      , testProperty "Permutation ==" pPermutationEq
       , testProperty "/=" pNeq
       , testProperty "Read/Show" pReadShow
       , testProperty "Foldable" pFoldable
+      , testProperty "Hashable" pHashable
       ]
     -- Basic interface
     , testGroup "basic interface"