hashable 1.2.4.0 → 1.2.5.0

raw patch · 10 files changed

+626/−54 lines, 10 filesdep ~basenew-component:exe:hashable-examplesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGES.md +8/−0
• Data/Hashable.hs +8/−0
• Data/Hashable/Class.hs +290/−26
• Data/Hashable/Generic.hs +38/−24
• Data/Hashable/Lifted.hs +96/−0
• benchmarks/Benchmarks.hs +28/−1
• benchmarks/cbits/siphash.h +68/−0
• examples/Main.hs +50/−0
• hashable.cabal +27/−2
• tests/Properties.hs +13/−1

@@ -1,3 +1,11 @@+## Version 1.2.5.0++  * Add `Hashable1` and `Hashable2`++  * Add instances for: `Eq1`, `Ord1`, `Show1`, `Ptr`, `FunPtr`, `IntPtr`, `WordPtr`++  * Add `Hashed` type for caching the `hash` function result.+ ## Version 1.2.4.0   * Add instances for: Unique, Version, Fixed, NonEmpty, Min, Max, Arg,

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif@@ -63,9 +64,16 @@     , hashByteArray     , hashByteArrayWithSalt #endif+    -- * Caching hashes+    , Hashed+    , hashed+    , unhashed+    , mapHashed+    , traverseHashed     ) where  import Data.Hashable.Class+ #ifdef GENERICS import Data.Hashable.Generic () #endif

@@ -1,7 +1,8 @@ {-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, MagicHash,-             ScopedTypeVariables, UnliftedFFITypes #-}+             ScopedTypeVariables, UnliftedFFITypes, DeriveDataTypeable #-} #ifdef GENERICS-{-# LANGUAGE DefaultSignatures, FlexibleContexts #-}+{-# LANGUAGE DefaultSignatures, FlexibleContexts, GADTs,+    MultiParamTypeClasses, EmptyDataDecls #-} #endif  ------------------------------------------------------------------------@@ -24,9 +25,14 @@     (       -- * Computing hash values       Hashable(..)+    , Hashable1(..)+    , Hashable2(..) #ifdef GENERICS       -- ** Support for generics     , GHashable(..)+    , HashArgs(..)+    , Zero+    , One #endif        -- * Creating new instances@@ -35,8 +41,20 @@     , hashPtrWithSalt     , hashByteArray     , hashByteArrayWithSalt+    , defaultHashWithSalt+      -- * Higher Rank Functions+    , hashWithSalt1+    , hashWithSalt2+    , defaultLiftHashWithSalt+    -- * Caching hashes+    , Hashed+    , hashed+    , unhashed+    , mapHashed+    , traverseHashed     ) where +import Control.Applicative (Const(..)) import Control.Exception (assert) import Data.Bits (shiftL, shiftR, xor) import qualified Data.ByteString as B@@ -50,12 +68,12 @@ import qualified Data.Text.Array as TA import qualified Data.Text.Internal as T import qualified Data.Text.Lazy as TL-import Data.Typeable+import Data.Typeable (Typeable, TypeRep) import Data.Version (Version(..)) import Data.Word (Word8, Word16, Word32, Word64) import Foreign.C (CString) import Foreign.Marshal.Utils (with)-import Foreign.Ptr (Ptr, castPtr)+import Foreign.Ptr (Ptr, FunPtr, IntPtr, WordPtr, castPtr, castFunPtrToPtr, ptrToIntPtr) import Foreign.Storable (alignment, peek, sizeOf) import GHC.Base (ByteArray#) import GHC.Conc (ThreadId(..))@@ -64,19 +82,33 @@ import System.Mem.StableName import Data.Unique (Unique, hashUnique) +-- As we use qualified F.Foldable, we don't get warnings with newer base+import qualified Data.Foldable as F+ #if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,7,0) import Data.Fixed (Fixed(..)) #endif +#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity(..))+#endif+ #ifdef GENERICS import GHC.Generics #endif  #if __GLASGOW_HASKELL__ >= 710+import Data.Typeable (typeRepFingerprint) import GHC.Fingerprint.Type(Fingerprint(..)) #elif __GLASGOW_HASKELL__ >= 702-import Data.Typeable.Internal(TypeRep(..))+import Data.Typeable.Internal (TypeRep (..)) import GHC.Fingerprint.Type(Fingerprint(..))+#elif __GLASGOW_HASKELL__ >= 606+import Data.Typeable (typeRepKey) #endif  #if __GLASGOW_HASKELL__ >= 703@@ -128,8 +160,15 @@ #if MIN_VERSION_base(4,9,0) import qualified Data.List.NonEmpty as NE import Data.Semigroup+import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),showsUnaryWith)++import Data.Functor.Compose (Compose(..))+import qualified Data.Functor.Product as FP+import qualified Data.Functor.Sum as FS #endif +import Data.String (IsString(..))+ #include "MachDeps.h"  infixl 0 `hashWithSalt`@@ -182,14 +221,52 @@     hash = hashWithSalt defaultSalt  #ifdef GENERICS-    default hashWithSalt :: (Generic a, GHashable (Rep a)) => Int -> a -> Int-    hashWithSalt salt = ghashWithSalt salt . from+    default hashWithSalt :: (Generic a, GHashable Zero (Rep a)) => Int -> a -> Int+    hashWithSalt salt = ghashWithSalt HashArgs0 salt . from +data Zero+data One++data HashArgs arity a where+    HashArgs0 :: HashArgs Zero a+    HashArgs1 :: (Int -> a -> Int) -> HashArgs One a+ -- | The class of types that can be generically hashed.-class GHashable f where-    ghashWithSalt :: Int -> f a -> Int+class GHashable arity f where+    ghashWithSalt :: HashArgs arity a -> Int -> f a -> Int+ #endif +class Hashable1 t where+    -- | Lift a hashing function through the type constructor.+    liftHashWithSalt :: (Int -> a -> Int) -> Int -> t a -> Int+#ifdef GENERICS+    default liftHashWithSalt :: (Generic1 t, GHashable One (Rep1 t)) => (Int -> a -> Int) -> Int -> t a -> Int+    liftHashWithSalt h salt = ghashWithSalt (HashArgs1 h) salt . from1+#endif++class Hashable2 t where+    -- | Lift a hashing function through the binary type constructor.+    liftHashWithSalt2 :: (Int -> a -> Int) -> (Int -> b -> Int) -> Int -> t a b -> Int++-- | Lift the 'hashWithSalt' function through the type constructor.+--+-- > hashWithSalt1 = liftHashWithSalt hashWithSalt+hashWithSalt1 :: (Hashable1 f, Hashable a) => Int -> f a -> Int+hashWithSalt1 = liftHashWithSalt hashWithSalt++-- | Lift the 'hashWithSalt' function through the type constructor.+--+-- > hashWithSalt2 = liftHashWithSalt2 hashWithSalt hashWithSalt+hashWithSalt2 :: (Hashable2 f, Hashable a, Hashable b) => Int -> f a b -> Int+hashWithSalt2 = liftHashWithSalt2 hashWithSalt hashWithSalt++-- | Lift the 'hashWithSalt' function halfway through the type constructor.+-- This function makes a suitable default implementation of 'liftHashWithSalt',+-- given that the type constructor @t@ in question can unify with @f a@.+defaultLiftHashWithSalt :: (Hashable2 f, Hashable a) => (Int -> b -> Int) -> Int -> f a b -> Int+defaultLiftHashWithSalt h = liftHashWithSalt2 hashWithSalt h+ -- Since we support a generic implementation of 'hashWithSalt' we -- cannot also provide a default implementation for that method for -- the non-generic instance use case. Instead we provide@@ -389,49 +466,94 @@ instance Hashable a => Hashable (Maybe a) where     hash Nothing = 0     hash (Just a) = distinguisher `hashWithSalt` a-    hashWithSalt s Nothing = s `combine` 0-    hashWithSalt s (Just a) = s `combine` distinguisher `hashWithSalt` a+    hashWithSalt = hashWithSalt1 +instance Hashable1 Maybe where+    liftHashWithSalt _ s Nothing = s `combine` 0+    liftHashWithSalt h s (Just a) = s `combine` distinguisher `h` a+ instance (Hashable a, Hashable b) => Hashable (Either a b) where     hash (Left a)  = 0 `hashWithSalt` a     hash (Right b) = distinguisher `hashWithSalt` b-    hashWithSalt s (Left a)  = s `combine` 0 `hashWithSalt` a-    hashWithSalt s (Right b) = s `combine` distinguisher `hashWithSalt` b+    hashWithSalt = hashWithSalt1 +instance Hashable a => Hashable1 (Either a) where+    liftHashWithSalt = defaultLiftHashWithSalt++instance Hashable2 Either where+    liftHashWithSalt2 h _ s (Left a) = s `combine` 0 `h` a+    liftHashWithSalt2 _ h s (Right b) = s `combine` distinguisher `h` b+ instance (Hashable a1, Hashable a2) => Hashable (a1, a2) where     hash (a1, a2) = hash a1 `hashWithSalt` a2-    hashWithSalt s (a1, a2) = s `hashWithSalt` a1 `hashWithSalt` a2+    hashWithSalt = hashWithSalt1 +instance Hashable a1 => Hashable1 ((,) a1) where+    liftHashWithSalt = defaultLiftHashWithSalt++instance Hashable2 (,) where+    liftHashWithSalt2 h1 h2 s (a1, a2) = s `h1` a1 `h2` a2+ instance (Hashable a1, Hashable a2, Hashable a3) => Hashable (a1, a2, a3) where     hash (a1, a2, a3) = hash a1 `hashWithSalt` a2 `hashWithSalt` a3-    hashWithSalt s (a1, a2, a3) = s `hashWithSalt` a1 `hashWithSalt` a2-                        `hashWithSalt` a3+    hashWithSalt = hashWithSalt1 +instance (Hashable a1, Hashable a2) => Hashable1 ((,,) a1 a2) where+    liftHashWithSalt = defaultLiftHashWithSalt++instance Hashable a1 => Hashable2 ((,,) a1) where+    liftHashWithSalt2 h1 h2 s (a1, a2, a3) =+      (s `hashWithSalt` a1) `h1` a2 `h2` a3+ instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4) =>          Hashable (a1, a2, a3, a4) where     hash (a1, a2, a3, a4) = hash a1 `hashWithSalt` a2                             `hashWithSalt` a3 `hashWithSalt` a4-    hashWithSalt s (a1, a2, a3, a4) = s `hashWithSalt` a1 `hashWithSalt` a2-                            `hashWithSalt` a3 `hashWithSalt` a4+    hashWithSalt = hashWithSalt1 +instance (Hashable a1, Hashable a2, Hashable a3) => Hashable1 ((,,,) a1 a2 a3) where+    liftHashWithSalt = defaultLiftHashWithSalt++instance (Hashable a1, Hashable a2) => Hashable2 ((,,,) a1 a2) where+    liftHashWithSalt2 h1 h2 s (a1, a2, a3, a4) =+      (s `hashWithSalt` a1 `hashWithSalt` a2) `h1` a3 `h2` a4+ instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5)       => Hashable (a1, a2, a3, a4, a5) where     hash (a1, a2, a3, a4, a5) =         hash a1 `hashWithSalt` a2 `hashWithSalt` a3         `hashWithSalt` a4 `hashWithSalt` a5-    hashWithSalt s (a1, a2, a3, a4, a5) =-        s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3-        `hashWithSalt` a4 `hashWithSalt` a5+    hashWithSalt = hashWithSalt1 +instance (Hashable a1, Hashable a2, Hashable a3,+          Hashable a4) => Hashable1 ((,,,,) a1 a2 a3 a4) where+    liftHashWithSalt = defaultLiftHashWithSalt++instance (Hashable a1, Hashable a2, Hashable a3)+      => Hashable2 ((,,,,) a1 a2 a3) where+    liftHashWithSalt2 h1 h2 s (a1, a2, a3, a4, a5) =+      (s `hashWithSalt` a1 `hashWithSalt` a2+         `hashWithSalt` a3) `h1` a4 `h2` a5++ instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5,           Hashable a6) => Hashable (a1, a2, a3, a4, a5, a6) where     hash (a1, a2, a3, a4, a5, a6) =         hash a1 `hashWithSalt` a2 `hashWithSalt` a3         `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6-    hashWithSalt s (a1, a2, a3, a4, a5, a6) =-        s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3-        `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6+    hashWithSalt = hashWithSalt1 +instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4,+          Hashable a5) => Hashable1 ((,,,,,) a1 a2 a3 a4 a5) where+    liftHashWithSalt = defaultLiftHashWithSalt++instance (Hashable a1, Hashable a2, Hashable a3,+          Hashable a4) => Hashable2 ((,,,,,) a1 a2 a3 a4) where+    liftHashWithSalt2 h1 h2 s (a1, a2, a3, a4, a5, a6) =+      (s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3+         `hashWithSalt` a4) `h1` a5 `h2` a6++ instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5,           Hashable a6, Hashable a7) =>          Hashable (a1, a2, a3, a4, a5, a6, a7) where@@ -442,6 +564,15 @@         s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3         `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6 `hashWithSalt` a7 +instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5, Hashable a6) => Hashable1 ((,,,,,,) a1 a2 a3 a4 a5 a6) where+    liftHashWithSalt = defaultLiftHashWithSalt++instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4,+          Hashable a5) => Hashable2 ((,,,,,,) a1 a2 a3 a4 a5) where+    liftHashWithSalt2 h1 h2 s (a1, a2, a3, a4, a5, a6, a7) =+      (s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3+         `hashWithSalt` a4 `hashWithSalt` a5) `h1` a6 `h2` a7+ instance Hashable (StableName a) where     hash = hashStableName     hashWithSalt = defaultHashWithSalt@@ -451,10 +582,13 @@  instance Hashable a => Hashable [a] where     {-# SPECIALIZE instance Hashable [Char] #-}-    hashWithSalt salt arr = finalise (foldl' step (SP salt 0) arr)+    hashWithSalt = hashWithSalt1++instance Hashable1 [] where+    liftHashWithSalt h salt arr = finalise (foldl' step (SP salt 0) arr)       where         finalise (SP s l) = hashWithSalt s l-        step (SP s l) x   = SP (hashWithSalt s x) (l + 1)+        step (SP s l) x   = SP (h s x) (l + 1)  instance Hashable B.ByteString where     hashWithSalt salt bs = B.inlinePerformIO $@@ -493,6 +627,20 @@     hash = hashThreadId     hashWithSalt = defaultHashWithSalt +instance Hashable (Ptr a) where+    hashWithSalt salt p = hashWithSalt salt $ ptrToIntPtr p++instance Hashable (FunPtr a) where+    hashWithSalt salt p = hashWithSalt salt $ castFunPtrToPtr p++instance Hashable IntPtr where+    hash n = fromIntegral n+    hashWithSalt = defaultHashWithSalt++instance Hashable WordPtr where+    hash n = fromIntegral n+    hashWithSalt = defaultHashWithSalt+ -- | Compute the hash of a TypeRep, in various GHC versions we can do this quickly. hashTypeRep :: TypeRep -> Int {-# INLINE hashTypeRep #-}@@ -583,10 +731,39 @@         salt `hashWithSalt` branch `hashWithSalt` tags  #if MIN_VERSION_base(4,7,0)+-- Using hashWithSalt1 would cause needless constraint instance Hashable (Fixed a) where     hashWithSalt salt (MkFixed i) = hashWithSalt salt i+instance Hashable1 Fixed where+    liftHashWithSalt _ salt (MkFixed i) = hashWithSalt salt i #endif +#if MIN_VERSION_base(4,8,0)+instance Hashable a => Hashable (Identity a) where+    hashWithSalt = hashWithSalt1+instance Hashable1 Identity where+    liftHashWithSalt h salt (Identity x) = h salt x+#endif++-- Using hashWithSalt1 would cause needless constraint+instance Hashable a => Hashable (Const a b) where+    hashWithSalt salt (Const x) = hashWithSalt salt x++instance Hashable a => Hashable1 (Const a) where+    liftHashWithSalt = defaultLiftHashWithSalt++instance Hashable2 Const where+    liftHashWithSalt2 f _ salt (Const x) = f salt x++#if MIN_VERSION_base(4,7,0)+instance Hashable (Proxy a) where+    hash _ = 0+    hashWithSalt s _ = s++instance Hashable1 Proxy where+    liftHashWithSalt _ s _ = s+#endif+ -- instances formerly provided by 'semigroups' package #if MIN_VERSION_base(4,9,0) instance Hashable a => Hashable (NE.NonEmpty a) where@@ -613,3 +790,90 @@ instance Hashable a => Hashable (Option a) where     hashWithSalt p (Option a) = hashWithSalt p a #endif++-- instances for @Data.Functor.{Product,Sum,Compose}@, present+-- in base-4.9 and onward.+#if MIN_VERSION_base(4,9,0)+-- | In general, @hash (Compose x) ≠ hash x@. However, @hashWithSalt@ satisfies+-- its variant of this equivalence.+instance (Hashable1 f, Hashable1 g, Hashable a) => Hashable (Compose f g a) where+    hashWithSalt = hashWithSalt1++instance (Hashable1 f, Hashable1 g) => Hashable1 (Compose f g) where+    liftHashWithSalt h s = liftHashWithSalt (liftHashWithSalt h) s . getCompose++instance (Hashable1 f, Hashable1 g) => Hashable1 (FP.Product f g) where+    liftHashWithSalt h s (FP.Pair a b) = liftHashWithSalt h (liftHashWithSalt h s a) b++instance (Hashable1 f, Hashable1 g, Hashable a) => Hashable (FP.Product f g a) where+    hashWithSalt = hashWithSalt1++instance (Hashable1 f, Hashable1 g) => Hashable1 (FS.Sum f g) where+    liftHashWithSalt h s (FS.InL a) = liftHashWithSalt h (s `combine` 0) a+    liftHashWithSalt h s (FS.InR a) = liftHashWithSalt h (s `combine` distinguisher) a++instance (Hashable1 f, Hashable1 g, Hashable a) => Hashable (FS.Sum f g a) where+    hashWithSalt = hashWithSalt1+#endif++-- | A hashable value along with the result of the 'hash' function.+data Hashed a = Hashed a {-# UNPACK #-} !Int+  deriving (Typeable)++-- | Wrap a hashable value, caching the 'hash' function result.+hashed :: Hashable a => a -> Hashed a+hashed a = Hashed a (hash a)++-- | Unwrap hashed value.+unhashed :: Hashed a -> a+unhashed (Hashed a _) = a++-- | Uses precomputed hash to detect inequality faster+instance Eq a => Eq (Hashed a) where+  Hashed a ha == Hashed b hb = ha == hb && a == b++instance Ord a => Ord (Hashed a) where+  Hashed a _ `compare` Hashed b _ = a `compare` b++instance Show a => Show (Hashed a) where+  showsPrec d (Hashed a _) = showParen (d > 10) $+    showString "hashed" . showChar ' ' . showsPrec 11 a++instance Hashable (Hashed a) where+  hashWithSalt = defaultHashWithSalt+  hash (Hashed _ h) = h++-- This instance is a little unsettling. It is unusal for+-- 'liftHashWithSalt' to ignore its first argument when a+-- value is actually available for it to work on.+instance Hashable1 Hashed where+  liftHashWithSalt _ s (Hashed _ h) = defaultHashWithSalt s h++instance (IsString a, Hashable a) => IsString (Hashed a) where+  fromString s = let r = fromString s in Hashed r (hash r)++instance F.Foldable Hashed where+  foldr f acc (Hashed a _) = f a acc++-- | 'Hashed' cannot be 'Functor'+mapHashed :: Hashable b => (a -> b) -> Hashed a -> Hashed b+mapHashed f (Hashed a _) = hashed (f a)++-- | 'Hashed' cannot be 'Traversable'+traverseHashed :: (Hashable b, Functor f) => (a -> f b) -> Hashed a -> f (Hashed b)+traverseHashed f (Hashed a _) = fmap hashed (f a)++-- instances for @Data.Functor.Classes@ higher rank typeclasses+-- in base-4.9 and onward.+#if MIN_VERSION_base(4,9,0)+instance Eq1 Hashed where+  liftEq f (Hashed a ha) (Hashed b hb) = ha == hb && f a b++instance Ord1 Hashed where+  liftCompare f (Hashed a _) (Hashed b _) = f a b++instance Show1 Hashed where+  liftShowsPrec sp _ d (Hashed a _) = showsUnaryWith sp "hashed" d a+#endif++

@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns, FlexibleInstances, KindSignatures,-             ScopedTypeVariables, TypeOperators #-}+             ScopedTypeVariables, TypeOperators,+             MultiParamTypeClasses, GADTs, FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  ------------------------------------------------------------------------@@ -21,43 +22,55 @@ import Data.Hashable.Class import GHC.Generics + -- Type without constructors-instance GHashable V1 where-    ghashWithSalt salt _ = hashWithSalt salt ()+instance GHashable arity V1 where+    ghashWithSalt _ salt _ = hashWithSalt salt ()  -- Constructor without arguments-instance GHashable U1 where-    ghashWithSalt salt U1 = hashWithSalt salt ()+instance GHashable arity U1 where+    ghashWithSalt _ salt U1 = hashWithSalt salt () -instance (GHashable a, GHashable b) => GHashable (a :*: b) where-    ghashWithSalt salt (x :*: y) = salt `ghashWithSalt` x `ghashWithSalt` y+instance (GHashable arity a, GHashable arity b) => GHashable arity (a :*: b) where+    ghashWithSalt toHash salt (x :*: y) =+      (ghashWithSalt toHash (ghashWithSalt toHash salt x) y)  -- Metadata (constructor name, etc)-instance GHashable a => GHashable (M1 i c a) where-    ghashWithSalt salt = ghashWithSalt salt . unM1+instance GHashable arity a => GHashable arity (M1 i c a) where+    ghashWithSalt targs salt = ghashWithSalt targs salt . unM1  -- Constants, additional parameters, and rank-1 recursion-instance Hashable a => GHashable (K1 i a) where-    ghashWithSalt = hashUsing unK1+instance Hashable a => GHashable arity (K1 i a) where+    ghashWithSalt _ = hashUsing unK1 -class GSum f where-    hashSum :: Int -> Int -> Int -> f a -> Int+instance GHashable One Par1 where+    ghashWithSalt (HashArgs1 h) salt = h salt . unPar1 -instance (GSum a, GSum b, SumSize a, SumSize b) => GHashable (a :+: b) where-    ghashWithSalt salt = hashSum salt 0 size+instance Hashable1 f => GHashable One (Rec1 f) where+    ghashWithSalt (HashArgs1 h) salt = liftHashWithSalt h salt . unRec1++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++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 a, GSum b) => GSum (a :+: b) where-    hashSum !salt !code !size s = case s of-                                    L1 x -> hashSum salt code           sizeL x-                                    R1 x -> hashSum salt (code + sizeL) sizeR x-        where-          sizeL = size `shiftR` 1-          sizeR = size - sizeL+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+      where+        sizeL = size `shiftR` 1+        sizeR = size - sizeL     {-# INLINE hashSum #-} -instance GHashable a => GSum (C1 c a) where-    hashSum !salt !code _ x = salt `hashWithSalt` code `ghashWithSalt` x+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)     {-# INLINE hashSum #-}  class SumSize f where@@ -71,3 +84,4 @@  instance SumSize (C1 c a) where     sumSize = Tagged 1+

@@ -0,0 +1,96 @@+------------------------------------------------------------------------+-- |+-- Module      :  Data.Hashable.Class+-- Copyright   :  (c) Milan Straka 2010+--                (c) Johan Tibell 2011+--                (c) Bryan O'Sullivan 2011, 2012+-- License     :  BSD-style+-- Maintainer  :  johan.tibell@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Lifting of the 'Hashable' class to unary and binary type constructors.+-- These classes are needed to express the constraints on arguments of+-- types that are parameterized by type constructors. Fixed-point data+-- types and monad transformers are such types.++module Data.Hashable.Lifted+    ( -- * Type Classes+      Hashable1(..)+    , Hashable2(..)+      -- * Auxiliary Functions+    , hashWithSalt1+    , hashWithSalt2+    , defaultLiftHashWithSalt+      -- * Motivation+      -- $motivation+    ) where++import Data.Hashable.Class++-- $motivation+--+-- This type classes provided in this module are used to express constraints+-- on type constructors in a Haskell98-compatible fashion. As an example, consider+-- the following two types (Note that these instances are not actually provided+-- because @hashable@ does not have @transformers@ or @free@ as a dependency):+--+-- > newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }+-- > data Free f a = Pure a | Free (f (Free f a))+--+-- The 'Hashable1' instances for @WriterT@ and @Free@ could be written as:+--+-- > instance (Hashable w, Hashable1 m) => Hashable1 (WriterT w m) where+-- >     liftHashWithSalt h s (WriterT m) =+-- >         liftHashWithSalt (liftHashWithSalt2 h hashWithSalt) s m+-- > instance Hashable1 f => Hashable1 (Free f) where+-- >     liftHashWithSalt h = go where+-- >         go s x = case x of+-- >             Pure a -> h s a+-- >             Free p -> liftHashWithSalt go s p+--+-- The 'Hashable' instances for these types can be trivially recovered with+-- 'hashWithSalt1':+--+-- > instance (Hashable w, Hashable1 m, Hashable a) => Hashable (WriterT w m a) where+-- >     hashWithSalt = hashWithSalt1+-- > instance (Hashable1 f, Hashable a) => Hashable (Free f a) where+-- >     hashWithSalt = hashWithSalt1++--+-- $discussion+--+-- Regardless of whether 'hashWithSalt1' is used to provide an implementation+-- of 'hashWithSalt', they should produce the same hash when called with+-- the same arguments. This is the only law that 'Hashable1' and 'Hashable2'+-- are expected to follow.+--+-- The typeclasses in this module only provide lifting for 'hashWithSalt', not+-- for 'hash'. This is because such liftings cannot be defined in a way that+-- would satisfy the @liftHash@ variant of the above law. As an illustration+-- of the problem we run into, let us assume that 'Hashable1' were+-- given a 'liftHash' method:+--+-- > class Hashable1 t where+-- >     liftHash :: (Int -> a) -> t a -> Int+-- >     liftHashWithSalt :: (Int -> a -> Int) -> Int -> t a -> Int+--+-- Even for a type as simple as 'Maybe', the problem manifests itself. The+-- 'Hashable' instance for 'Maybe' is:+--+-- > distinguisher :: Int+-- > distinguisher = ...+-- >+-- > instance Hashable a => Hashable (Maybe a) where+-- >     hash Nothing = 0+-- >     hash (Just a) = distinguisher `hashWithSalt` a+-- >     hashWithSalt s Nothing = ...+-- >     hashWithSalt s (Just a) = ...+--+-- The implementation of 'hash' calls 'hashWithSalt' on @a@. The hypothetical+-- @liftHash@ defined earlier only accepts an argument that corresponds to+-- the implementation of 'hash' for @a@. Consequently, this formulation of+-- @liftHash@ would not provide a way to match the current behavior of 'hash'+-- for 'Maybe'. This problem gets worse when 'Either' and @[]@ are considered.+-- The solution adopted in this library is to omit @liftHash@ entirely.+

@@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, MagicHash,-    UnboxedTuples #-}+    UnboxedTuples, DeriveGeneric #-}  module Main (main) where @@ -15,6 +15,7 @@ import Foreign.C.Types (CInt(..), CLong(..), CSize(..)) import Foreign.Ptr import Data.ByteString.Internal+import GHC.Generics (Generic) import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.Lazy as TL@@ -35,6 +36,10 @@     let !mb = 2^(20 :: Int)  -- 1 Mb     fp1Mb <- mallocForeignPtrBytes mb +    let exP = P 22.0203 234.19 'x' 6424+        exS = S3+        exPS = PS3 'z' 7715+     -- We don't care about the contents of these either.     let !ba5 = new 5;     !ba8 = new 8;     !ba11 = new 11; !ba40 = new 40         !ba128 = new 128; !ba512 = new 512; !ba1Mb = new mb@@ -251,6 +256,11 @@           , bench "jenkins32a" $ whnf hash_jenkins_32a 0xdeadbeef           , bench "jenkins32b" $ whnf hash_jenkins_32b 0xdeadbeef           ]+        , bgroup "Generic"+          [ bench "product" $ whnf hash exP+          , bench "sum" $ whnf hash exS+          , bench "product and sum" $ whnf hash exPS+          ]         ]  data ByteArray = BA { unBA :: !ByteArray# }@@ -285,3 +295,20 @@     :: Word32 -> Word32 foreign import ccall unsafe "hash_jenkins_32b" hash_jenkins_32b     :: Word32 -> Word32++data PS+  = PS1 Int Char Bool+  | PS2 String ()+  | PS3 Char Int+  deriving (Generic)++data P = P Double Float Char Int+  deriving (Generic)++data S = S1 | S2 | S3 | S4 | S5+  deriving (Generic)++instance Hashable PS+instance Hashable P+instance Hashable S+

@@ -0,0 +1,68 @@+#ifndef _hashable_siphash_h+#define _hashable_siphash_h++#include <stdint.h>+#include <stdlib.h>++typedef uint64_t u64;+typedef uint32_t u32;+typedef uint16_t u16;+typedef uint8_t u8;++#define SIPHASH_ROUNDS 2+#define SIPHASH_FINALROUNDS 4++u64 hashable_siphash(int, int, u64, u64, const u8 *, size_t);+u64 hashable_siphash24(u64, u64, const u8 *, size_t);++#if defined(__i386)++/* To use SSE instructions, we have to adjust the stack from its+   default of 4-byte alignment to use 16-byte alignment. */++# define ALIGNED_STACK __attribute__((force_align_arg_pointer))++u64 hashable_siphash24_sse2(u64, u64, const u8 *, size_t) ALIGNED_STACK;+u64 hashable_siphash24_sse41(u64, u64, const u8 *, size_t) ALIGNED_STACK;+#endif++#if defined(_WIN32)+# define __LITTLE_ENDIAN 1234+# define __BIG_ENDIAN 4321+# define __BYTE_ORDER __LITTLE_ENDIAN++#elif (defined(__FreeBSD__) && __FreeBSD_version >= 470000) || defined(__OpenBSD__) || defined(__NetBSD__)+# include <sys/endian.h>+# define __BIG_ENDIAN BIG_ENDIAN+# define __LITTLE_ENDIAN LITTLE_ENDIAN+# define __BYTE_ORDER BYTE_ORDER++#elif (defined(BSD) && (BSD >= 199103)) || defined(__APPLE__)+# include <machine/endian.h>+# define __BIG_ENDIAN BIG_ENDIAN+# define __LITTLE_ENDIAN LITTLE_ENDIAN+# define __BYTE_ORDER BYTE_ORDER++#elif defined(__linux__)+# include <endian.h>+#endif++static inline u64 peek_u64le(const u64 *p)+{+    u64 x = *p;++#if __BYTE_ORDER == __BIG_ENDIAN+    x = ((x & 0xff00000000000000ull) >> 56) |+	((x & 0x00ff000000000000ull) >> 40) |+	((x & 0x0000ff0000000000ull) >> 24) |+	((x & 0x000000ff00000000ull) >> 8) |+	((x & 0x00000000ff000000ull) << 8) |+	((x & 0x0000000000ff0000ull) << 24) |+	((x & 0x000000000000ff00ull) << 40) |+	((x & 0x00000000000000ffull) << 56);+#endif++    return x;+}++#endif /* _hashable_siphash_h */

@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveGeneric #-}+import Data.Hashable+import Data.Hashable.Lifted+import GHC.Generics (Generic)++data Foo+  = Foo1 Int Char Bool+  | Foo2 String ()+  deriving (Generic)++instance Hashable Foo++data Bar = Bar Double Float+  deriving (Generic)++instance Hashable Bar++-- printHash :: (Hashable a, Show a) => a -> IO ()+-- printHash = print . hash++main :: IO ()+main = do+  putStrLn "Hashing Foo1"+  print . hash $ Foo1 22 'y' True+  putStrLn "Hashing Foo2"+  print . hash $ Foo2 "hello" ()+  putStrLn "Hashing Bar"+  print . hash $ Bar 55.50 9.125++-----------------------------------+-- Higher Rank Hashable Examples --+-----------------------------------++newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }+data Free f a = Pure a | Free (f (Free f a))++instance (Hashable w, Hashable1 m) => Hashable1 (WriterT w m) where+    liftHashWithSalt h s (WriterT m) =+        liftHashWithSalt (liftHashWithSalt2 h hashWithSalt) s m+instance Hashable1 f => Hashable1 (Free f) where+    liftHashWithSalt h = go where+        go s x = case x of+            Pure a -> h s a+            Free p -> liftHashWithSalt go s p++instance (Hashable w, Hashable1 m, Hashable a) => Hashable (WriterT w m a) where+    hashWithSalt = hashWithSalt1+instance (Hashable1 f, Hashable a) => Hashable (Free f a) where+    hashWithSalt = hashWithSalt1+

@@ -1,5 +1,5 @@ Name:                hashable-Version:             1.2.4.0+Version:             1.2.5.0 Synopsis:            A class for types that can be converted to a hash value Description:         This package defines a class, 'Hashable', for types that                      can be converted to a hash value.  This class@@ -20,7 +20,8 @@ -- tests/Properties.hs shouldn't have to go here, but the source files -- for the test-suite stanzas don't get picked up by `cabal sdist`. Extra-source-files:-  CHANGES.md, README.md, tests/Properties.hs, benchmarks/Benchmarks.hs+  CHANGES.md, README.md, tests/Properties.hs,+  benchmarks/Benchmarks.hs, benchmarks/cbits/*.c, benchmarks/cbits/*.h  Flag integer-gmp   Description: Are we using integer-gmp to provide fast Integer instances?@@ -36,8 +37,14 @@   Default: False   Manual: True +Flag examples+  Description: Build example modules+  Default: False+  Manual: True+ Library   Exposed-modules:   Data.Hashable+                     Data.Hashable.Lifted   Other-modules:     Data.Hashable.Class   Build-depends:     base >= 4.0 && < 4.10,                      bytestring >= 0.9 && < 0.11@@ -115,6 +122,15 @@   if impl(ghc) && flag(integer-gmp)     Build-depends:   integer-gmp >= 0.2 +  if impl(ghc >= 7.2.1)+    CPP-Options:     -DGENERICS++  include-dirs:+    benchmarks/cbits++  includes:+    siphash.h+   c-sources:     benchmarks/cbits/inthash.c     benchmarks/cbits/siphash.c@@ -139,6 +155,15 @@     other-modules:     Data.Hashable.RandomSource     if os(windows)       extra-libraries: advapi32+++Executable hashable-examples+  if flag(examples)+    build-depends: base, hashable+  else+    buildable: False+  hs-source-dirs: examples+  main-is: Main.hs  source-repository head   type:     git

@@ -9,7 +9,9 @@  module Properties (properties) where -import Data.Hashable (Hashable, hash, hashByteArray, hashPtr)+import Data.Hashable (Hashable, hash, hashByteArray, hashPtr,+         Hashed, hashed, unhashed, hashWithSalt)+import Data.Hashable.Lifted (hashWithSalt1) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T@@ -208,6 +210,13 @@  #endif +instance (Arbitrary a, Hashable a) => Arbitrary (Hashed a) where+  arbitrary = fmap hashed arbitrary+  shrink xs = map hashed $ shrink $ unhashed xs++pLiftedHashed :: Int -> Hashed (Either Int String) -> Bool+pLiftedHashed s h = hashWithSalt s h == hashWithSalt1 s h+ properties :: [Test] properties =     [ testProperty "bernstein" pHash@@ -239,6 +248,9 @@       , testProperty "sum3_differ" pSum3_differ       ] #endif+    , testGroup "lifted law"+      [ testProperty "Hashed" pLiftedHashed+      ]     ]  ------------------------------------------------------------------------