Rework the Generic hashable for sums

Author: phadej

Data/Hashable/Generic.hs

@@ -22,7 +22,6 @@ import Data.Bits (shiftR)
 import Data.Hashable.Class
 import GHC.Generics
 
-
 -- Type without constructors
 instance GHashable arity V1 where
     ghashWithSalt _ salt _ = hashWithSalt salt ()
@@ -52,25 +51,23 @@ instance Hashable1 f => GHashable One (Rec1 f) where
 instance (Hashable1 f, GHashable One g) => GHashable One (f :.: g) where
     ghashWithSalt targs salt = liftHashWithSalt (ghashWithSalt targs) salt . unComp1
 
-class GSum arity f where
-    hashSum :: HashArgs arity a -> Int -> Int -> Int -> f a -> Int
+class SumSize f => GSum arity f where
+    hashSum :: HashArgs arity a -> Int -> Int -> f a -> Int
+    -- hashSum args salt offset value = ...
 
-instance (GSum arity a, GSum arity b, SumSize a, SumSize b) => GHashable arity (a :+: b) where
-    ghashWithSalt toHash salt = hashSum toHash salt 0 size
-        where size = unTagged (sumSize :: Tagged (a :+: b))
+instance (GSum arity a, GSum arity b) => GHashable arity (a :+: b) where
+    ghashWithSalt toHash salt = hashSum toHash salt 0
 
 instance (GSum arity a, GSum arity b) => GSum arity (a :+: b) where
-    hashSum toHash !salt !code !size s = case s of
-        L1 x -> hashSum toHash salt code           sizeL x
-        R1 x -> hashSum toHash salt (code + sizeL) sizeR x
+    hashSum toHash !salt !offset s = case s of
+        L1 x -> hashSum toHash salt offset x
+        R1 x -> hashSum toHash salt (offset + sizeL) x
       where
-        sizeL = size `shiftR` 1
-        sizeR = size - sizeL
+        sizeL = unTagged (sumSize :: Tagged a)
     {-# INLINE hashSum #-}
 
 instance GHashable arity a => GSum arity (C1 c a) where
-    -- hashSum toHash !salt !code _ (M1 x) = ghashWithSalt toHash (hashWithSalt salt code) x
-    hashSum toHash !salt !code _ (M1 x) = hashWithSalt salt (ghashWithSalt toHash code x)
+    hashSum toHash !salt !offset (M1 x) = ghashWithSalt toHash (hashWithSalt salt offset) x
     {-# INLINE hashSum #-}
 
 class SumSize f where

tests/Regress.hs

@@ -1,15 +1,47 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveGeneric #-}
 
 module Regress (regressions) where
 
 import qualified Test.Framework as F
+import Test.Framework.Providers.HUnit (testCase)
+import Test.HUnit ((@=?))
+import GHC.Generics (Generic)
+import Data.List (nub)
 
 #ifdef HAVE_MMAP
 import qualified Regress.Mmap as Mmap
 #endif
 
+import Data.Hashable
+
 regressions :: [F.Test]
-regressions = []
+regressions = [] ++
 #ifdef HAVE_MMAP
-              ++ Mmap.regressions
+    Mmap.regressions ++
 #endif
+    [ F.testGroup "Generic: sum of nullary constructors"
+        [ testCase "0" $ nullaryCase 0 S0
+        , testCase "1" $ nullaryCase 1 S1
+        , testCase "2" $ nullaryCase 2 S2
+        , testCase "3" $ nullaryCase 3 S3
+        , testCase "4" $ nullaryCase 4 S4
+        ]
+    , testCase "Generic: Peano https://github.com/tibbe/hashable/issues/135" $ do
+        let ns = take 20 $ iterate S Z
+        let hs = map hash ns
+        hs @=? nub hs
+    ]
+  where
+    nullaryCase :: Int -> SumOfNullary -> IO ()
+    nullaryCase n s = do
+        let salt = 42
+        let expected = salt `hashWithSalt` n `hashWithSalt` ()
+        let actual = hashWithSalt salt s
+        expected @=? actual
+
+data SumOfNullary = S0 | S1 | S2 | S3 | S4 deriving (Generic)
+instance Hashable SumOfNullary
+
+data Nat = Z | S Nat deriving (Generic)
+instance Hashable Nat