diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,15 @@ See also https://pvp.haskell.org/faq +## Version 1.3.1.0 + + * Add `Hashable1` instances to `semigroups` types. + + * Use `ghc-bignum` with GHC-9.0 + + * Use FNV-1 constants. + + * Make `hashable-examples` a test-suite + ## Version 1.3.0.0 * Semantic change of `Hashable Arg` instance to *not* hash the second diff --git a/Data/Hashable.hs b/Data/Hashable.hs deleted file mode 100644 --- a/Data/Hashable.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------- --- | --- Module : Data.Hashable --- Copyright : (c) Milan Straka 2010 --- (c) Johan Tibell 2011 --- (c) Bryan O'Sullivan 2011, 2012 --- SPDX-License-Identifier : BSD-3-Clause --- Maintainer : johan.tibell@gmail.com --- Stability : provisional --- Portability : portable --- --- This module defines a class, 'Hashable', for types that can be --- converted to a hash value. This class exists for the benefit of --- hashing-based data structures. The module provides instances for --- most standard types. Efficient instances for other types can be --- generated automatically and effortlessly using the generics support --- in GHC 7.4 and above. --- --- The easiest way to get started is to use the 'hash' function. Here --- is an example session with @ghci@. --- --- > ghci> import Data.Hashable --- > ghci> hash "foo" --- > 60853164 - -module Data.Hashable - ( - -- * Hashing and security - -- $security - - -- * Computing hash values - Hashable(..) - - -- * Creating new instances - -- | There are two ways to create new instances: by deriving - -- instances automatically using GHC's generic programming - -- support or by writing instances manually. - - -- ** Generic instances - -- $generics - - -- *** Understanding a compiler error - -- $generic_err - - -- ** Writing instances by hand - -- $blocks - - -- *** Hashing contructors with multiple fields - -- $multiple-fields - - -- *** Hashing types with multiple constructors - -- $multiple-ctors - - , hashUsing - , hashPtr - , hashPtrWithSalt - , hashByteArray - , hashByteArrayWithSalt - - -- * Caching hashes - , Hashed - , hashed - , unhashed - , mapHashed - , traverseHashed - ) where - -import Data.Hashable.Class -import Data.Hashable.Generic () - --- $security --- #security# --- --- Applications that use hash-based data structures to store input --- from untrusted users can be susceptible to \"hash DoS\", a class of --- denial-of-service attack that uses deliberately chosen colliding --- inputs to force an application into unexpectedly behaving with --- quadratic time complexity. --- --- At this time, the string hashing functions used in this library are --- susceptible to such attacks and users are recommended to either use --- a 'Data.Map' to store keys derived from untrusted input or to use a --- hash function (e.g. SipHash) that's resistant to such attacks. A --- future version of this library might ship with such hash functions. - --- $generics --- --- The recommended way to make instances of --- 'Hashable' for most types is to use the compiler's support for --- automatically generating default instances using "GHC.Generics". --- --- > {-# LANGUAGE DeriveGeneric #-} --- > --- > import GHC.Generics (Generic) --- > import Data.Hashable --- > --- > data Foo a = Foo a String --- > deriving (Eq, Generic) --- > --- > instance Hashable a => Hashable (Foo a) --- > --- > data Colour = Red | Green | Blue --- > deriving Generic --- > --- > instance Hashable Colour --- --- If you omit a body for the instance declaration, GHC will generate --- a default instance that correctly and efficiently hashes every --- constructor and parameter. --- --- The default implementations are provided by --- 'genericHashWithSalt' and 'genericLiftHashWithSalt'; those together with --- the generic type class 'GHashable' and auxiliary functions are exported --- from the "Data.Hashable.Generic" module. - --- $generic_err --- --- Suppose you intend to use the generic machinery to automatically --- generate a 'Hashable' instance. --- --- > data Oops = Oops --- > -- forgot to add "deriving Generic" here! --- > --- > instance Hashable Oops --- --- And imagine that, as in the example above, you forget to add a --- \"@deriving 'Generic'@\" clause to your data type. At compile time, --- you will get an error message from GHC that begins roughly as --- follows: --- --- > No instance for (GHashable (Rep Oops)) --- --- This error can be confusing, as 'GHashable' is not exported (it is --- an internal typeclass used by this library's generics machinery). --- The correct fix is simply to add the missing \"@deriving --- 'Generic'@\". - --- $blocks --- --- To maintain high quality hashes, new 'Hashable' instances should be --- built using existing 'Hashable' instances, combinators, and hash --- functions. --- --- The functions below can be used when creating new instances of --- 'Hashable'. For example, for many string-like types the --- 'hashWithSalt' method can be defined in terms of either --- 'hashPtrWithSalt' or 'hashByteArrayWithSalt'. Here's how you could --- implement an instance for the 'B.ByteString' data type, from the --- @bytestring@ package: --- --- > import qualified Data.ByteString as B --- > import qualified Data.ByteString.Internal as B --- > import qualified Data.ByteString.Unsafe as B --- > import Data.Hashable --- > import Foreign.Ptr (castPtr) --- > --- > instance Hashable B.ByteString where --- > hashWithSalt salt bs = B.inlinePerformIO $ --- > B.unsafeUseAsCStringLen bs $ \(p, len) -> --- > hashPtrWithSalt p (fromIntegral len) salt - --- $multiple-fields --- --- Hash constructors with multiple fields by chaining 'hashWithSalt': --- --- > data Date = Date Int Int Int --- > --- > instance Hashable Date where --- > hashWithSalt s (Date yr mo dy) = --- > s `hashWithSalt` --- > yr `hashWithSalt` --- > mo `hashWithSalt` dy --- --- If you need to chain hashes together, use 'hashWithSalt' and follow --- this recipe: --- --- > combineTwo h1 h2 = h1 `hashWithSalt` h2 - --- $multiple-ctors --- --- For a type with several value constructors, there are a few --- possible approaches to writing a 'Hashable' instance. --- --- If the type is an instance of 'Enum', the easiest path is to --- convert it to an 'Int', and use the existing 'Hashable' instance --- for 'Int'. --- --- > data Color = Red | Green | Blue --- > deriving Enum --- > --- > instance Hashable Color where --- > hashWithSalt = hashUsing fromEnum --- --- If the type's constructors accept parameters, it is important to --- distinguish the constructors. To distinguish the constructors, add --- a different integer to the hash computation of each constructor: --- --- > data Time = Days Int --- > | Weeks Int --- > | Months Int --- > --- > instance Hashable Time where --- > hashWithSalt s (Days n) = s `hashWithSalt` --- > (0::Int) `hashWithSalt` n --- > hashWithSalt s (Weeks n) = s `hashWithSalt` --- > (1::Int) `hashWithSalt` n --- > hashWithSalt s (Months n) = s `hashWithSalt` --- > (2::Int) `hashWithSalt` n diff --git a/Data/Hashable/Class.hs b/Data/Hashable/Class.hs deleted file mode 100644 --- a/Data/Hashable/Class.hs +++ /dev/null @@ -1,940 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, - ScopedTypeVariables, UnliftedFFITypes, DeriveDataTypeable, - DefaultSignatures, FlexibleContexts, TypeFamilies, - MultiParamTypeClasses #-} - -#if __GLASGOW_HASKELL__ >= 801 -{-# LANGUAGE PolyKinds #-} -- For TypeRep instances -#endif - ------------------------------------------------------------------------- --- | --- Module : Data.Hashable.Class --- Copyright : (c) Milan Straka 2010 --- (c) Johan Tibell 2011 --- (c) Bryan O'Sullivan 2011, 2012 --- SPDX-License-Identifier : BSD-3-Clause --- Maintainer : johan.tibell@gmail.com --- Stability : provisional --- Portability : portable --- --- This module defines a class, 'Hashable', for types that can be --- converted to a hash value. This class exists for the benefit of --- hashing-based data structures. The module provides instances for --- most standard types. - -module Data.Hashable.Class - ( - -- * Computing hash values - Hashable(..) - , Hashable1(..) - , Hashable2(..) - - -- ** Support for generics - , genericHashWithSalt - , genericLiftHashWithSalt - , GHashable(..) - , HashArgs(..) - , Zero - , One - - -- * Creating new instances - , hashUsing - , hashPtr - , 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 Control.DeepSeq (NFData(rnf)) -import Data.Bits (shiftL, shiftR, xor) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Unsafe as B -import Data.Complex (Complex(..)) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.List (foldl') -import Data.Ratio (Ratio, denominator, numerator) -import qualified Data.Text as T -import qualified Data.Text.Array as TA -import qualified Data.Text.Internal as T -import qualified Data.Text.Lazy as TL -import Data.Version (Version(..)) -import Data.Word (Word8, Word16, Word32, Word64) -import Foreign.C (CString) -import Foreign.Marshal.Utils (with) -import Foreign.Ptr (Ptr, FunPtr, IntPtr, WordPtr, castPtr, castFunPtrToPtr, ptrToIntPtr) -import Foreign.Storable (alignment, peek, sizeOf) -import GHC.Base (ByteArray#) -import GHC.Conc (ThreadId(..)) -import GHC.Prim (ThreadId#) -import System.IO.Unsafe (unsafeDupablePerformIO) -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 - -import GHC.Generics - -#if MIN_VERSION_base(4,10,0) -import Type.Reflection (Typeable, TypeRep, SomeTypeRep(..)) -import Type.Reflection.Unsafe (typeRepFingerprint) -import GHC.Fingerprint.Type(Fingerprint(..)) -#elif MIN_VERSION_base(4,8,0) -import Data.Typeable (typeRepFingerprint, Typeable, TypeRep) -import GHC.Fingerprint.Type(Fingerprint(..)) -#else -import Data.Typeable.Internal (Typeable, TypeRep (..)) -import GHC.Fingerprint.Type(Fingerprint(..)) -#endif - -#if MIN_VERSION_base(4,5,0) -import Foreign.C (CLong(..)) -import Foreign.C.Types (CInt(..)) -#else -import Foreign.C (CLong) -import Foreign.C.Types (CInt) -#endif - -#if !(MIN_VERSION_base(4,8,0)) -import Data.Word (Word) -#endif - -#if MIN_VERSION_base(4,7,0) -import Data.Bits (finiteBitSize) -#else -import Data.Bits (bitSize) -#endif - -#if !(MIN_VERSION_bytestring(0,10,0)) -import qualified Data.ByteString.Lazy.Internal as BL -- foldlChunks -#endif - -#if MIN_VERSION_bytestring(0,10,4) -import qualified Data.ByteString.Short.Internal as BSI -#endif - -#ifdef VERSION_integer_gmp - -# if MIN_VERSION_integer_gmp(1,0,0) -# define MIN_VERSION_integer_gmp_1_0_0 -# endif - -import GHC.Exts (Int(..)) -import GHC.Integer.GMP.Internals (Integer(..)) -# if defined(MIN_VERSION_integer_gmp_1_0_0) -import GHC.Exts (sizeofByteArray#) -import GHC.Integer.GMP.Internals (BigNat(BN#)) -# endif -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Void (Void, absurd) -import GHC.Natural (Natural(..)) -import GHC.Exts (Word(..)) -#endif - -#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` - ------------------------------------------------------------------------- --- * Computing hash values - --- | A default salt used in the implementation of 'hash'. -defaultSalt :: Int -#if WORD_SIZE_IN_BITS == 64 -defaultSalt = -2578643520546668380 -- 0xdc36d1615b7400a4 -#else -defaultSalt = 0x087fc72c -#endif -{-# INLINE defaultSalt #-} - --- | The class of types that can be converted to a hash value. --- --- Minimal implementation: 'hashWithSalt'. -class Hashable a where - -- | Return a hash value for the argument, using the given salt. - -- - -- The general contract of 'hashWithSalt' is: - -- - -- * If two values are equal according to the '==' method, then - -- applying the 'hashWithSalt' method on each of the two values - -- /must/ produce the same integer result if the same salt is - -- used in each case. - -- - -- * It is /not/ required that if two values are unequal - -- according to the '==' method, then applying the - -- 'hashWithSalt' method on each of the two values must produce - -- distinct integer results. However, the programmer should be - -- aware that producing distinct integer results for unequal - -- values may improve the performance of hashing-based data - -- structures. - -- - -- * This method can be used to compute different hash values for - -- the same input by providing a different salt in each - -- application of the method. This implies that any instance - -- that defines 'hashWithSalt' /must/ make use of the salt in - -- its implementation. - hashWithSalt :: Int -> a -> Int - - -- | Like 'hashWithSalt', but no salt is used. The default - -- implementation uses 'hashWithSalt' with some default salt. - -- Instances might want to implement this method to provide a more - -- efficient implementation than the default implementation. - hash :: a -> Int - hash = hashWithSalt defaultSalt - - default hashWithSalt :: (Generic a, GHashable Zero (Rep a)) => Int -> a -> Int - hashWithSalt = genericHashWithSalt - {-# INLINE hashWithSalt #-} - --- | Generic 'hashWithSalt'. --- --- @since 1.3.0.0 -genericHashWithSalt :: (Generic a, GHashable Zero (Rep a)) => Int -> a -> Int -genericHashWithSalt = \salt -> ghashWithSalt HashArgs0 salt . from -{-# INLINE genericHashWithSalt #-} - -data Zero -data One - -data family HashArgs arity a :: * -data instance HashArgs Zero a = HashArgs0 -newtype instance HashArgs One a = HashArgs1 (Int -> a -> Int) - --- | The class of types that can be generically hashed. -class GHashable arity f where - ghashWithSalt :: HashArgs arity a -> Int -> f a -> Int - -class Hashable1 t where - -- | Lift a hashing function through the type constructor. - liftHashWithSalt :: (Int -> a -> Int) -> Int -> t a -> Int - - default liftHashWithSalt :: (Generic1 t, GHashable One (Rep1 t)) => (Int -> a -> Int) -> Int -> t a -> Int - liftHashWithSalt = genericLiftHashWithSalt - {-# INLINE liftHashWithSalt #-} - --- | Generic 'liftHashWithSalt'. --- --- @since 1.3.0.0 -genericLiftHashWithSalt :: (Generic1 t, GHashable One (Rep1 t)) => (Int -> a -> Int) -> Int -> t a -> Int -genericLiftHashWithSalt = \h salt -> ghashWithSalt (HashArgs1 h) salt . from1 -{-# INLINE genericLiftHashWithSalt #-} - -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 --- 'defaultHashWith'. -defaultHashWithSalt :: Hashable a => Int -> a -> Int -defaultHashWithSalt salt x = salt `combine` hash x - --- | Transform a value into a 'Hashable' value, then hash the --- transformed value using the given salt. --- --- This is a useful shorthand in cases where a type can easily be --- mapped to another type that is already an instance of 'Hashable'. --- Example: --- --- > data Foo = Foo | Bar --- > deriving (Enum) --- > --- > instance Hashable Foo where --- > hashWithSalt = hashUsing fromEnum -hashUsing :: (Hashable b) => - (a -> b) -- ^ Transformation function. - -> Int -- ^ Salt. - -> a -- ^ Value to transform. - -> Int -hashUsing f salt x = hashWithSalt salt (f x) -{-# INLINE hashUsing #-} - -instance Hashable Int where - hash = id - hashWithSalt = defaultHashWithSalt - -instance Hashable Int8 where - hash = fromIntegral - hashWithSalt = defaultHashWithSalt - -instance Hashable Int16 where - hash = fromIntegral - hashWithSalt = defaultHashWithSalt - -instance Hashable Int32 where - hash = fromIntegral - hashWithSalt = defaultHashWithSalt - -instance Hashable Int64 where - hash n -#if MIN_VERSION_base(4,7,0) - | finiteBitSize (undefined :: Int) == 64 = fromIntegral n -#else - | bitSize (undefined :: Int) == 64 = fromIntegral n -#endif - | otherwise = fromIntegral (fromIntegral n `xor` - (fromIntegral n `shiftR` 32 :: Word64)) - hashWithSalt = defaultHashWithSalt - -instance Hashable Word where - hash = fromIntegral - hashWithSalt = defaultHashWithSalt - -instance Hashable Word8 where - hash = fromIntegral - hashWithSalt = defaultHashWithSalt - -instance Hashable Word16 where - hash = fromIntegral - hashWithSalt = defaultHashWithSalt - -instance Hashable Word32 where - hash = fromIntegral - hashWithSalt = defaultHashWithSalt - -instance Hashable Word64 where - hash n -#if MIN_VERSION_base(4,7,0) - | finiteBitSize (undefined :: Int) == 64 = fromIntegral n -#else - | bitSize (undefined :: Int) == 64 = fromIntegral n -#endif - | otherwise = fromIntegral (n `xor` (n `shiftR` 32)) - hashWithSalt = defaultHashWithSalt - -instance Hashable () where - hash = fromEnum - hashWithSalt = defaultHashWithSalt - -instance Hashable Bool where - hash = fromEnum - hashWithSalt = defaultHashWithSalt - -instance Hashable Ordering where - hash = fromEnum - hashWithSalt = defaultHashWithSalt - -instance Hashable Char where - hash = fromEnum - hashWithSalt = defaultHashWithSalt - -#if defined(MIN_VERSION_integer_gmp_1_0_0) -instance Hashable BigNat where - hashWithSalt salt (BN# ba) = hashByteArrayWithSalt ba 0 numBytes salt - `hashWithSalt` size - where - size = numBytes `quot` SIZEOF_HSWORD - numBytes = I# (sizeofByteArray# ba) -#endif - -#if MIN_VERSION_base(4,8,0) -instance Hashable Natural where -# if defined(MIN_VERSION_integer_gmp_1_0_0) - hash (NatS# n) = hash (W# n) - hash (NatJ# bn) = hash bn - - hashWithSalt salt (NatS# n) = hashWithSalt salt (W# n) - hashWithSalt salt (NatJ# bn) = hashWithSalt salt bn -# else - hash (Natural n) = hash n - - hashWithSalt salt (Natural n) = hashWithSalt salt n -# endif -#endif - -instance Hashable Integer where -#if defined(VERSION_integer_gmp) -# if defined(MIN_VERSION_integer_gmp_1_0_0) - hash (S# n) = (I# n) - hash (Jp# bn) = hash bn - hash (Jn# bn) = negate (hash bn) - - hashWithSalt salt (S# n) = hashWithSalt salt (I# n) - hashWithSalt salt (Jp# bn) = hashWithSalt salt bn - hashWithSalt salt (Jn# bn) = negate (hashWithSalt salt bn) -# else - hash (S# int) = I# int - hash n@(J# size# byteArray) - | n >= minInt && n <= maxInt = fromInteger n :: Int - | otherwise = let size = I# size# - numBytes = SIZEOF_HSWORD * abs size - in hashByteArrayWithSalt byteArray 0 numBytes defaultSalt - `hashWithSalt` size - where minInt = fromIntegral (minBound :: Int) - maxInt = fromIntegral (maxBound :: Int) - - hashWithSalt salt (S# n) = hashWithSalt salt (I# n) - hashWithSalt salt n@(J# size# byteArray) - | n >= minInt && n <= maxInt = hashWithSalt salt (fromInteger n :: Int) - | otherwise = let size = I# size# - numBytes = SIZEOF_HSWORD * abs size - in hashByteArrayWithSalt byteArray 0 numBytes salt - `hashWithSalt` size - where minInt = fromIntegral (minBound :: Int) - maxInt = fromIntegral (maxBound :: Int) -# endif -#else - hashWithSalt salt = foldl' hashWithSalt salt . go - where - go n | inBounds n = [fromIntegral n :: Int] - | otherwise = fromIntegral n : go (n `shiftR` WORD_SIZE_IN_BITS) - maxInt = fromIntegral (maxBound :: Int) - inBounds x = x >= fromIntegral (minBound :: Int) && x <= maxInt -#endif - -instance Hashable a => Hashable (Complex a) where - {-# SPECIALIZE instance Hashable (Complex Double) #-} - {-# SPECIALIZE instance Hashable (Complex Float) #-} - hash (r :+ i) = hash r `hashWithSalt` i - hashWithSalt = hashWithSalt1 -instance Hashable1 Complex where - liftHashWithSalt h s (r :+ i) = s `h` r `h` i - -#if MIN_VERSION_base(4,9,0) --- Starting with base-4.9, numerator/denominator don't need 'Integral' anymore -instance Hashable a => Hashable (Ratio a) where -#else -instance (Integral a, Hashable a) => Hashable (Ratio a) where -#endif - {-# SPECIALIZE instance Hashable (Ratio Integer) #-} - hash a = hash (numerator a) `hashWithSalt` denominator a - hashWithSalt s a = s `hashWithSalt` numerator a `hashWithSalt` denominator a - --- | __Note__: prior to @hashable-1.3.0.0@, @hash 0.0 /= hash (-0.0)@ --- --- The 'hash' of NaN is not well defined. --- --- @since 1.3.0.0 -instance Hashable Float where - hash x - | x == -0.0 || x == 0.0 = 0 -- see note in 'Hashable Double' - | isIEEE x = - assert (sizeOf x >= sizeOf (0::Word32) && - alignment x >= alignment (0::Word32)) $ - hash ((unsafeDupablePerformIO $ with x $ peek . castPtr) :: Word32) - | otherwise = hash (show x) - hashWithSalt = defaultHashWithSalt - --- | __Note__: prior to @hashable-1.3.0.0@, @hash 0.0 /= hash (-0.0)@ --- --- The 'hash' of NaN is not well defined. --- --- @since 1.3.0.0 -instance Hashable Double where - hash x - | x == -0.0 || x == 0.0 = 0 -- s.t. @hash -0.0 == hash 0.0@ ; see #173 - | isIEEE x = - assert (sizeOf x >= sizeOf (0::Word64) && - alignment x >= alignment (0::Word64)) $ - hash ((unsafeDupablePerformIO $ with x $ peek . castPtr) :: Word64) - | otherwise = hash (show x) - hashWithSalt = defaultHashWithSalt - --- | A value with bit pattern (01)* (or 5* in hexa), for any size of Int. --- It is used as data constructor distinguisher. GHC computes its value during --- compilation. -distinguisher :: Int -distinguisher = fromIntegral $ (maxBound :: Word) `quot` 3 -{-# INLINE distinguisher #-} - -instance Hashable a => Hashable (Maybe a) where - hash Nothing = 0 - hash (Just a) = 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 = 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 = 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 = 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 = 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 = 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 = 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 - hash (a1, a2, a3, a4, a5, a6, a7) = - hash a1 `hashWithSalt` a2 `hashWithSalt` a3 - `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6 `hashWithSalt` a7 - hashWithSalt s (a1, a2, a3, a4, a5, a6, a7) = - 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 - --- Auxillary type for Hashable [a] definition -data SPInt = SP !Int !Int - -instance Hashable a => Hashable [a] where - {-# SPECIALIZE instance Hashable [Char] #-} - 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 (h s x) (l + 1) - -instance Hashable B.ByteString where - hashWithSalt salt bs = unsafeDupablePerformIO $ - B.unsafeUseAsCStringLen bs $ \(p, len) -> - hashPtrWithSalt p (fromIntegral len) salt - -instance Hashable BL.ByteString where - hashWithSalt = BL.foldlChunks hashWithSalt - -#if MIN_VERSION_bytestring(0,10,4) -instance Hashable BSI.ShortByteString where - hashWithSalt salt sbs@(BSI.SBS ba) = - hashByteArrayWithSalt ba 0 (BSI.length sbs) salt -#endif - -instance Hashable T.Text where - hashWithSalt salt (T.Text arr off len) = - hashByteArrayWithSalt (TA.aBA arr) (off `shiftL` 1) (len `shiftL` 1) - salt - -instance Hashable TL.Text where - hashWithSalt = TL.foldlChunks hashWithSalt - --- | Compute the hash of a ThreadId. -hashThreadId :: ThreadId -> Int -hashThreadId (ThreadId t) = hash (fromIntegral (getThreadId t) :: Int) - -foreign import ccall unsafe "rts_getThreadId" getThreadId - :: ThreadId# -> CInt - -instance Hashable ThreadId where - 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 - ----------------------------------------------------------------------------- --- Fingerprint & TypeRep instances - --- | @since 1.3.0.0 -instance Hashable Fingerprint where - hash (Fingerprint x _) = fromIntegral x - hashWithSalt = defaultHashWithSalt - {-# INLINE hash #-} - -#if MIN_VERSION_base(4,10,0) - -hashTypeRep :: Type.Reflection.TypeRep a -> Int -hashTypeRep tr = - let Fingerprint x _ = typeRepFingerprint tr in fromIntegral x - -instance Hashable Type.Reflection.SomeTypeRep where - hash (Type.Reflection.SomeTypeRep r) = hashTypeRep r - hashWithSalt = defaultHashWithSalt - {-# INLINE hash #-} - -instance Hashable (Type.Reflection.TypeRep a) where - hash = hashTypeRep - hashWithSalt = defaultHashWithSalt - {-# INLINE hash #-} - -#else - --- | Compute the hash of a TypeRep, in various GHC versions we can do this quickly. -hashTypeRep :: TypeRep -> Int -{-# INLINE hashTypeRep #-} -#if MIN_VERSION_base(4,8,0) --- Fingerprint is just the MD5, so taking any Int from it is fine -hashTypeRep tr = let Fingerprint x _ = typeRepFingerprint tr in fromIntegral x -#else --- Fingerprint is just the MD5, so taking any Int from it is fine -hashTypeRep (TypeRep (Fingerprint x _) _ _) = fromIntegral x -#endif - -instance Hashable TypeRep where - hash = hashTypeRep - hashWithSalt = defaultHashWithSalt - {-# INLINE hash #-} - -#endif - ----------------------------------------------------------------------------- - -#if MIN_VERSION_base(4,8,0) -instance Hashable Void where - hashWithSalt _ = absurd -#endif - --- | Compute a hash value for the content of this pointer. -hashPtr :: Ptr a -- ^ pointer to the data to hash - -> Int -- ^ length, in bytes - -> IO Int -- ^ hash value -hashPtr p len = hashPtrWithSalt p len defaultSalt - --- | Compute a hash value for the content of this pointer, using an --- initial salt. --- --- This function can for example be used to hash non-contiguous --- segments of memory as if they were one contiguous segment, by using --- the output of one hash as the salt for the next. -hashPtrWithSalt :: Ptr a -- ^ pointer to the data to hash - -> Int -- ^ length, in bytes - -> Int -- ^ salt - -> IO Int -- ^ hash value -hashPtrWithSalt p len salt = - fromIntegral `fmap` c_hashCString (castPtr p) (fromIntegral len) - (fromIntegral salt) - -foreign import ccall unsafe "hashable_fnv_hash" c_hashCString - :: CString -> CLong -> CLong -> IO CLong - --- | Compute a hash value for the content of this 'ByteArray#', --- beginning at the specified offset, using specified number of bytes. -hashByteArray :: ByteArray# -- ^ data to hash - -> Int -- ^ offset, in bytes - -> Int -- ^ length, in bytes - -> Int -- ^ hash value -hashByteArray ba0 off len = hashByteArrayWithSalt ba0 off len defaultSalt -{-# INLINE hashByteArray #-} - --- | Compute a hash value for the content of this 'ByteArray#', using --- an initial salt. --- --- This function can for example be used to hash non-contiguous --- segments of memory as if they were one contiguous segment, by using --- the output of one hash as the salt for the next. -hashByteArrayWithSalt - :: ByteArray# -- ^ data to hash - -> Int -- ^ offset, in bytes - -> Int -- ^ length, in bytes - -> Int -- ^ salt - -> Int -- ^ hash value -hashByteArrayWithSalt ba !off !len !h = - fromIntegral $ c_hashByteArray ba (fromIntegral off) (fromIntegral len) - (fromIntegral h) - -foreign import ccall unsafe "hashable_fnv_hash_offset" c_hashByteArray - :: ByteArray# -> CLong -> CLong -> CLong -> CLong - --- | Combine two given hash values. 'combine' has zero as a left --- identity. -combine :: Int -> Int -> Int -combine h1 h2 = (h1 * 16777619) `xor` h2 - -instance Hashable Unique where - hash = hashUnique - hashWithSalt = defaultHashWithSalt - -instance Hashable Version where - hashWithSalt salt (Version branch tags) = - 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 - hashWithSalt p (a NE.:| as) = p `hashWithSalt` a `hashWithSalt` as - -instance Hashable a => Hashable (Min a) where - hashWithSalt p (Min a) = hashWithSalt p a - -instance Hashable a => Hashable (Max a) where - hashWithSalt p (Max a) = hashWithSalt p a - --- | __Note__: Prior to @hashable-1.3.0.0@ the hash computation included the second argument of 'Arg' which wasn't consistent with its 'Eq' instance. --- --- @since 1.3.0.0 -instance Hashable a => Hashable (Arg a b) where - hashWithSalt p (Arg a _) = hashWithSalt p a - -instance Hashable a => Hashable (First a) where - hashWithSalt p (First a) = hashWithSalt p a - -instance Hashable a => Hashable (Last a) where - hashWithSalt p (Last a) = hashWithSalt p a - -instance Hashable a => Hashable (WrappedMonoid a) where - hashWithSalt p (WrapMonoid a) = hashWithSalt p a - -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 - -instance NFData a => NFData (Hashed a) where - rnf = rnf . unhashed - --- | '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 diff --git a/Data/Hashable/Generic.hs b/Data/Hashable/Generic.hs deleted file mode 100644 --- a/Data/Hashable/Generic.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - --- | --- Module : Data.Hashable.Generic --- SPDX-License-Identifier : BSD-3-Clause --- Stability : provisional --- Portability : GHC >= 7.4 --- --- Hashable support for GHC generics. --- --- @since 1.3.0.0 -module Data.Hashable.Generic - ( - -- * Implementation using Generics. - genericHashWithSalt - , genericLiftHashWithSalt - -- * Constraints - , GHashable (..) - , One - , Zero - , HashArgs (..) - ) where - -import Data.Hashable.Generic.Instances () -import Data.Hashable.Class diff --git a/Data/Hashable/Generic/Instances.hs b/Data/Hashable/Generic/Instances.hs deleted file mode 100644 --- a/Data/Hashable/Generic/Instances.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE BangPatterns, FlexibleInstances, KindSignatures, - ScopedTypeVariables, TypeOperators, - MultiParamTypeClasses, GADTs, FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ------------------------------------------------------------------------- --- | --- Module : Data.Hashable.Generic.Instances --- Copyright : (c) Bryan O'Sullivan 2012 --- SPDX-License-Identifier : BSD-3-Clause --- Maintainer : bos@serpentine.com --- Stability : provisional --- Portability : GHC >= 7.4 --- --- Internal module defining orphan instances for "GHC.Generics" --- -module Data.Hashable.Generic.Instances () where - -import Data.Hashable.Class -import GHC.Generics - --- Type without constructors -instance GHashable arity V1 where - ghashWithSalt _ salt _ = hashWithSalt salt () - --- Constructor without arguments -instance GHashable arity U1 where - ghashWithSalt _ salt U1 = hashWithSalt salt () - -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 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 arity (K1 i a) where - ghashWithSalt _ = hashUsing unK1 - -instance GHashable One Par1 where - ghashWithSalt (HashArgs1 h) salt = h salt . unPar1 - -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 SumSize f => GSum arity f where - hashSum :: HashArgs arity a -> Int -> Int -> f a -> Int - -- hashSum args salt index value = ... - --- [Note: Hashing a sum type] --- --- The tree structure is used in GHC.Generics to represent the sum (and --- product) part of the generic represention of the type, e.g.: --- --- (C0 ... :+: C1 ...) :+: (C2 ... :+: (C3 ... :+: C4 ...)) --- --- The value constructed with C2 constructor is represented as (R1 (L1 ...)). --- Yet, if we think that this tree is a flat (heterogenous) list: --- --- [C0 ..., C1 ..., C2 ..., C3 ..., C4... ] --- --- then the value constructed with C2 is a (dependent) pair (2, ...), and --- hashing it is simple: --- --- salt `hashWithSalt` (2 :: Int) `hashWithSalt` ... --- --- This is what we do below. When drilling down the tree, we count how many --- leafs are to the left (`index` variable). At the leaf case C1, we'll have an --- actual index into the sum. --- --- This works well for balanced data. However for recursive types like: --- --- data Nat = Z | S Nat --- --- the `hashWithSalt salt (S (S (S Z)))` is --- --- salt `hashWithSalt` (1 :: Int) -- first S --- `hashWithSalt` (1 :: Int) -- second S --- `hashWithSalt` (1 :: Int) -- third S --- `hashWithSalt` (0 :: Int) -- Z --- `hashWithSalt` () -- U1 --- --- For that type the manual implementation: --- --- instance Hashable Nat where --- hashWithSalt salt n = hashWithSalt salt (natToInteger n) --- --- would be better performing CPU and hash-quality wise (assuming that --- Integer's Hashable is of high quality). --- -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 !index s = case s of - L1 x -> hashSum toHash salt index x - R1 x -> hashSum toHash salt (index + sizeL) x - where - sizeL = unTagged (sumSize :: Tagged a) - {-# INLINE hashSum #-} - -instance GHashable arity a => GSum arity (C1 c a) where - hashSum toHash !salt !index (M1 x) = ghashWithSalt toHash (hashWithSalt salt index) x - {-# INLINE hashSum #-} - -class SumSize f where - sumSize :: Tagged f - -newtype Tagged (s :: * -> *) = Tagged {unTagged :: Int} - -instance (SumSize a, SumSize b) => SumSize (a :+: b) where - sumSize = Tagged $ unTagged (sumSize :: Tagged a) + - unTagged (sumSize :: Tagged b) - -instance SumSize (C1 c a) where - sumSize = Tagged 1 diff --git a/Data/Hashable/Lifted.hs b/Data/Hashable/Lifted.hs deleted file mode 100644 --- a/Data/Hashable/Lifted.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE Trustworthy #-} - ------------------------------------------------------------------------- --- | --- Module : Data.Hashable.Lifted --- Copyright : (c) Milan Straka 2010 --- (c) Johan Tibell 2011 --- (c) Bryan O'Sullivan 2011, 2012 --- SPDX-License-Identifier : BSD-3-Clause --- 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 :: (a -> Int) -> 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. - diff --git a/Data/Hashable/RandomSource.hs b/Data/Hashable/RandomSource.hs deleted file mode 100644 --- a/Data/Hashable/RandomSource.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif - -module Data.Hashable.RandomSource - ( - getRandomBytes - , getRandomBytes_ - ) where - -import Data.ByteString as B -import Data.ByteString.Internal (create) -import Foreign.C.Error (throwErrnoIfMinus1_) -#if MIN_VERSION_base(4,5,0) -import Foreign.C.Types (CInt(CInt)) -#else -import Foreign.C.Types (CInt) -#endif -import Foreign.Ptr (Ptr) - -getRandomBytes :: Int -> IO ByteString -getRandomBytes nbytes - | nbytes <= 0 = return B.empty - | otherwise = create nbytes $ flip (getRandomBytes_ "getRandomBytes") nbytes - -getRandomBytes_ :: String -> Ptr a -> Int -> IO () -getRandomBytes_ what ptr nbytes = do - throwErrnoIfMinus1_ what $ c_getRandomBytes ptr (fromIntegral nbytes) - -foreign import ccall unsafe "hashable_getRandomBytes" c_getRandomBytes - :: Ptr a -> CInt -> IO CInt diff --git a/Data/Hashable/SipHash.hs b/Data/Hashable/SipHash.hs deleted file mode 100644 --- a/Data/Hashable/SipHash.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -module Data.Hashable.SipHash - ( - LE64 - , Sip - , fromWord64 - , fullBlock - , lastBlock - , finalize - , hashByteString - ) where - -#include "MachDeps.h" - -import Data.Bits ((.|.), (.&.), rotateL, shiftL, xor) -#if MIN_VERSION_base(4,5,0) -import Data.Bits (unsafeShiftL) -#endif -import Data.Word (Word8, Word64) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr, castPtr, plusPtr) -import Data.ByteString.Internal (ByteString(PS), inlinePerformIO) -import Foreign.Storable (peek) -import Numeric (showHex) - -newtype LE64 = LE64 { fromLE64 :: Word64 } - deriving (Eq) - -instance Show LE64 where - show (LE64 !v) = let s = showHex v "" - in "0x" ++ replicate (16 - length s) '0' ++ s - -data Sip = Sip { - v0 :: {-# UNPACK #-} !Word64, v1 :: {-# UNPACK #-} !Word64 - , v2 :: {-# UNPACK #-} !Word64, v3 :: {-# UNPACK #-} !Word64 - } - -fromWord64 :: Word64 -> LE64 -#ifndef WORDS_BIGENDIAN -fromWord64 = LE64 -#else -#error big endian support TBD -#endif - -initState :: (Sip -> r) -> Word64 -> Word64 -> r -initState k k0 k1 = k (Sip s0 s1 s2 s3) - where !s0 = (k0 `xor` 0x736f6d6570736575) - !s1 = (k1 `xor` 0x646f72616e646f6d) - !s2 = (k0 `xor` 0x6c7967656e657261) - !s3 = (k1 `xor` 0x7465646279746573) - -sipRound :: (Sip -> r) -> Sip -> r -sipRound k Sip{..} = k (Sip v0_c v1_d v2_c v3_d) - where v0_a = v0 + v1 - v2_a = v2 + v3 - v1_a = v1 `rotateL` 13 - v3_a = v3 `rotateL` 16 - v1_b = v1_a `xor` v0_a - v3_b = v3_a `xor` v2_a - v0_b = v0_a `rotateL` 32 - v2_b = v2_a + v1_b - v0_c = v0_b + v3_b - v1_c = v1_b `rotateL` 17 - v3_c = v3_b `rotateL` 21 - v1_d = v1_c `xor` v2_b - v3_d = v3_c `xor` v0_c - v2_c = v2_b `rotateL` 32 - -fullBlock :: Int -> LE64 -> (Sip -> r) -> Sip -> r -fullBlock c m k st@Sip{..} - | c == 2 = sipRound (sipRound k') st' - | otherwise = runRounds c k' st' - where k' st1@Sip{..} = k st1{ v0 = v0 `xor` fromLE64 m } - st' = st{ v3 = v3 `xor` fromLE64 m } -{-# INLINE fullBlock #-} - -runRounds :: Int -> (Sip -> r) -> Sip -> r -runRounds c k = go 0 - where go i st - | i < c = sipRound (go (i+1)) st - | otherwise = k st -{-# INLINE runRounds #-} - -lastBlock :: Int -> Int -> LE64 -> (Sip -> r) -> Sip -> r -lastBlock !c !len !m k st = -#ifndef WORDS_BIGENDIAN - fullBlock c (LE64 m') k st -#else -#error big endian support TBD -#endif - where m' = fromLE64 m .|. ((fromIntegral len .&. 0xff) `shiftL` 56) -{-# INLINE lastBlock #-} - -finalize :: Int -> (Word64 -> r) -> Sip -> r -finalize d k st@Sip{..} - | d == 4 = sipRound (sipRound (sipRound (sipRound k'))) st' - | otherwise = runRounds d k' st' - where k' Sip{..} = k $! v0 `xor` v1 `xor` v2 `xor` v3 - st' = st{ v2 = v2 `xor` 0xff } -{-# INLINE finalize #-} - -hashByteString :: Int -> Int -> Word64 -> Word64 -> ByteString -> Word64 -hashByteString !c !d k0 k1 (PS fp off len) = - inlinePerformIO . withForeignPtr fp $ \basePtr -> - let ptr0 = basePtr `plusPtr` off - scant = len .&. 7 - endBlocks = ptr0 `plusPtr` (len - scant) - go !ptr st - | ptr == endBlocks = readLast ptr - | otherwise = do - m <- peekLE64 ptr - fullBlock c m (go (ptr `plusPtr` 8)) st - where - zero !m _ _ = lastBlock c len (LE64 m) (finalize d return) st - one k m p s = do - w <- fromIntegral `fmap` peekByte p - k (m .|. (w `unsafeShiftL` s)) (p `plusPtr` 1) (s+8) - readLast p = - case scant of - 0 -> zero 0 p (0::Int) - 1 -> one zero 0 p 0 - 2 -> one (one zero) 0 p 0 - 3 -> one (one (one zero)) 0 p 0 - 4 -> one (one (one (one zero))) 0 p 0 - 5 -> one (one (one (one (one zero)))) 0 p 0 - 6 -> one (one (one (one (one (one zero))))) 0 p 0 - _ -> one (one (one (one (one (one (one zero)))))) 0 p 0 - in initState (go ptr0) k0 k1 - -peekByte :: Ptr Word8 -> IO Word8 -peekByte = peek - -peekLE64 :: Ptr Word8 -> IO LE64 -#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH) --- platforms on which unaligned loads are legal and usually fast -peekLE64 p = LE64 `fmap` peek (castPtr p) -#else -peekLE64 p = do - let peek8 d = fromIntegral `fmap` peekByte (p `plusPtr` d) - b0 <- peek8 0 - b1 <- peek8 1 - b2 <- peek8 2 - b3 <- peek8 3 - b4 <- peek8 4 - b5 <- peek8 5 - b6 <- peek8 6 - b7 <- peek8 7 - let !w = (b7 `shiftL` 56) .|. (b6 `shiftL` 48) .|. (b5 `shiftL` 40) .|. - (b4 `shiftL` 32) .|. (b3 `shiftL` 24) .|. (b2 `shiftL` 16) .|. - (b1 `shiftL` 8) .|. b0 - return (fromWord64 w) -#endif - -#if !(MIN_VERSION_base(4,5,0)) -unsafeShiftL :: Word64 -> Int -> Word64 -unsafeShiftL = shiftL -#endif diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs deleted file mode 100644 --- a/benchmarks/Benchmarks.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, MagicHash, - UnboxedTuples, DeriveGeneric #-} - -module Main (main) where - -import Control.Monad.ST -import Criterion.Main -import Data.Hashable -import Data.Hashable.SipHash -import Data.Int -import Foreign.ForeignPtr -import GHC.Exts -import GHC.ST (ST(..)) -import Data.Word -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 -import qualified Crypto.MAC.SipHash as HS -import qualified Data.ByteString.Char8 as B8 - --- Benchmark English words (5 and 8), base64 encoded integers (11), --- SHA1 hashes as hex (40), and large blobs (1 Mb). -main :: IO () -main = do - -- We do not actually care about the contents of these pointers. - fp5 <- mallocForeignPtrBytes 5 - fp8 <- mallocForeignPtrBytes 8 - fp11 <- mallocForeignPtrBytes 11 - fp40 <- mallocForeignPtrBytes 40 - fp128 <- mallocForeignPtrBytes 128 - fp512 <- mallocForeignPtrBytes 512 - 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 - - s5 = ['\0'..'\4']; s8 = ['\0'..'\7']; s11 = ['\0'..'\10'] - s40 = ['\0'..'\39']; s128 = ['\0'..'\127']; s512 = ['\0'..'\511'] - s1Mb = ['\0'..'\999999'] - - !bs5 = B8.pack s5; !bs8 = B8.pack s8; !bs11 = B8.pack s11 - !bs40 = B8.pack s40; !bs128 = B8.pack s128; !bs512 = B8.pack s512 - !bs1Mb = B8.pack s1Mb - - blmeg = BL.take (fromIntegral mb) . BL.fromChunks . repeat - bl5 = BL.fromChunks [bs5]; bl8 = BL.fromChunks [bs8] - bl11 = BL.fromChunks [bs11]; bl40 = BL.fromChunks [bs40] - bl128 = BL.fromChunks [bs128]; bl512 = BL.fromChunks [bs512] - bl1Mb_40 = blmeg bs40; bl1Mb_128 = blmeg bs128 - bl1Mb_64k = blmeg (B8.take 65536 bs1Mb) - - !t5 = T.pack s5; !t8 = T.pack s8; !t11 = T.pack s11 - !t40 = T.pack s40; !t128 = T.pack s128; !t512 = T.pack s512 - !t1Mb = T.pack s1Mb - - tlmeg = TL.take (fromIntegral mb) . TL.fromChunks . repeat - tl5 = TL.fromStrict t5; tl8 = TL.fromStrict t8 - tl11 = TL.fromStrict t11; tl40 = TL.fromStrict t40 - tl128 = TL.fromStrict t128; tl512 = TL.fromChunks (replicate 4 t128) - tl1Mb_40 = tlmeg t40; tl1Mb_128 = tlmeg t128 - tl1Mb_64k = tlmeg (T.take 65536 t1Mb) - - let k0 = 0x4a7330fae70f52e8 - k1 = 0x919ea5953a9a1ec9 - sipHash = hashByteString 2 4 k0 k1 - hsSipHash = HS.hash (HS.SipKey k0 k1) - cSipHash (PS fp off len) = - inlinePerformIO . withForeignPtr fp $ \ptr -> - return $! c_siphash 2 4 k0 k1 (ptr `plusPtr` off) (fromIntegral len) - cSipHash24 (PS fp off len) = - inlinePerformIO . withForeignPtr fp $ \ptr -> - return $! c_siphash24 k0 k1 (ptr `plusPtr` off) (fromIntegral len) - fnvHash (PS fp off len) = - inlinePerformIO . withForeignPtr fp $ \ptr -> - return $! fnv_hash (ptr `plusPtr` off) (fromIntegral len) 2166136261 -#ifdef HAVE_SSE2 - sse2SipHash (PS fp off len) = - inlinePerformIO . withForeignPtr fp $ \ptr -> - return $! sse2_siphash k0 k1 (ptr `plusPtr` off) (fromIntegral len) -#endif -#ifdef HAVE_SSE41 - sse41SipHash (PS fp off len) = - inlinePerformIO . withForeignPtr fp $ \ptr -> - return $! sse41_siphash k0 k1 (ptr `plusPtr` off) (fromIntegral len) -#endif - - withForeignPtr fp5 $ \ p5 -> - withForeignPtr fp8 $ \ p8 -> - withForeignPtr fp11 $ \ p11 -> - withForeignPtr fp40 $ \ p40 -> - withForeignPtr fp128 $ \ p128 -> - withForeignPtr fp512 $ \ p512 -> - withForeignPtr fp1Mb $ \ p1Mb -> - defaultMain - [ bgroup "hashPtr" - [ bench "5" $ whnfIO $ hashPtr p5 5 - , bench "8" $ whnfIO $ hashPtr p8 8 - , bench "11" $ whnfIO $ hashPtr p11 11 - , bench "40" $ whnfIO $ hashPtr p40 40 - , bench "128" $ whnfIO $ hashPtr p128 128 - , bench "512" $ whnfIO $ hashPtr p512 512 - , bench "2^20" $ whnfIO $ hashPtr p1Mb mb - ] - , bgroup "hashByteArray" - [ bench "5" $ whnf (hashByteArray ba5 0) 5 - , bench "8" $ whnf (hashByteArray ba8 0) 8 - , bench "11" $ whnf (hashByteArray ba11 0) 11 - , bench "40" $ whnf (hashByteArray ba40 0) 40 - , bench "128" $ whnf (hashByteArray ba128 0) 128 - , bench "512" $ whnf (hashByteArray ba512 0) 512 - , bench "2^20" $ whnf (hashByteArray ba1Mb 0) mb - ] - , bgroup "hash" - [ bgroup "ByteString" - [ bgroup "strict" - [ bench "5" $ whnf hash bs5 - , bench "8" $ whnf hash bs8 - , bench "11" $ whnf hash bs11 - , bench "40" $ whnf hash bs40 - , bench "128" $ whnf hash bs128 - , bench "512" $ whnf hash bs512 - , bench "2^20" $ whnf hash bs1Mb - ] - , bgroup "lazy" - [ bench "5" $ whnf hash bl5 - , bench "8" $ whnf hash bl8 - , bench "11" $ whnf hash bl11 - , bench "40" $ whnf hash bl40 - , bench "128" $ whnf hash bl128 - , bench "512" $ whnf hash bl512 - , bench "2^20_40" $ whnf hash bl1Mb_40 - , bench "2^20_128" $ whnf hash bl1Mb_128 - , bench "2^20_64k" $ whnf hash bl1Mb_64k - ] - ] - , bgroup "String" - [ bench "5" $ whnf hash s5 - , bench "8" $ whnf hash s8 - , bench "11" $ whnf hash s11 - , bench "40" $ whnf hash s40 - , bench "128" $ whnf hash s128 - , bench "512" $ whnf hash s512 - , bench "2^20" $ whnf hash s1Mb - ] - , bgroup "Text" - [ bgroup "strict" - [ bench "5" $ whnf hash t5 - , bench "8" $ whnf hash t8 - , bench "11" $ whnf hash t11 - , bench "40" $ whnf hash t40 - , bench "128" $ whnf hash t128 - , bench "512" $ whnf hash t512 - , bench "2^20" $ whnf hash t1Mb - ] - , bgroup "lazy" - [ bench "5" $ whnf hash tl5 - , bench "8" $ whnf hash tl8 - , bench "11" $ whnf hash tl11 - , bench "40" $ whnf hash tl40 - , bench "128" $ whnf hash tl128 - , bench "512" $ whnf hash tl512 - , bench "2^20_40" $ whnf hash tl1Mb_40 - , bench "2^20_128" $ whnf hash tl1Mb_128 - , bench "2^20_64k" $ whnf hash tl1Mb_64k - ] - ] - , bench "Int8" $ whnf hash (0xef :: Int8) - , bench "Int16" $ whnf hash (0x7eef :: Int16) - , bench "Int32" $ whnf hash (0x7eadbeef :: Int32) - , bench "Int" $ whnf hash (0x7eadbeefdeadbeef :: Int) - , bench "Int64" $ whnf hash (0x7eadbeefdeadbeef :: Int64) - , bench "Double" $ whnf hash (0.3780675796601578 :: Double) - ] - , bgroup "sipHash" - [ bench "5" $ whnf sipHash bs5 - , bench "8" $ whnf sipHash bs8 - , bench "11" $ whnf sipHash bs11 - , bench "40" $ whnf sipHash bs40 - , bench "128" $ whnf sipHash bs128 - , bench "512" $ whnf sipHash bs512 - , bench "2^20" $ whnf sipHash bs1Mb - ] - , bgroup "cSipHash" - [ bench "5" $ whnf cSipHash bs5 - , bench "8" $ whnf cSipHash bs8 - , bench "11" $ whnf cSipHash bs11 - , bench "40" $ whnf cSipHash bs40 - , bench "128" $ whnf cSipHash bs128 - , bench "512" $ whnf cSipHash bs512 - , bench "2^20" $ whnf cSipHash bs1Mb - ] - , bgroup "cSipHash24" - [ bench "5" $ whnf cSipHash24 bs5 - , bench "8" $ whnf cSipHash24 bs8 - , bench "11" $ whnf cSipHash24 bs11 - , bench "40" $ whnf cSipHash24 bs40 - , bench "128" $ whnf cSipHash24 bs128 - , bench "512" $ whnf cSipHash24 bs512 - , bench "2^20" $ whnf cSipHash24 bs1Mb - ] -#ifdef HAVE_SSE2 - , bgroup "sse2SipHash" - [ bench "5" $ whnf sse2SipHash bs5 - , bench "8" $ whnf sse2SipHash bs8 - , bench "11" $ whnf sse2SipHash bs11 - , bench "40" $ whnf sse2SipHash bs40 - , bench "128" $ whnf sse2SipHash bs128 - , bench "512" $ whnf sse2SipHash bs512 - , bench "2^20" $ whnf sse2SipHash bs1Mb - ] -#endif -#ifdef HAVE_SSE41 - , bgroup "sse41SipHash" - [ bench "5" $ whnf sse41SipHash bs5 - , bench "8" $ whnf sse41SipHash bs8 - , bench "11" $ whnf sse41SipHash bs11 - , bench "40" $ whnf sse41SipHash bs40 - , bench "128" $ whnf sse41SipHash bs128 - , bench "512" $ whnf sse41SipHash bs512 - , bench "2^20" $ whnf sse41SipHash bs1Mb - ] -#endif - , bgroup "pkgSipHash" - [ bench "5" $ whnf hsSipHash bs5 - , bench "8" $ whnf hsSipHash bs8 - , bench "11" $ whnf hsSipHash bs11 - , bench "40" $ whnf hsSipHash bs40 - , bench "128" $ whnf hsSipHash bs128 - , bench "512" $ whnf hsSipHash bs512 - , bench "2^20" $ whnf hsSipHash bs1Mb - ] - , bgroup "fnv" - [ bench "5" $ whnf fnvHash bs5 - , bench "8" $ whnf fnvHash bs8 - , bench "11" $ whnf fnvHash bs11 - , bench "40" $ whnf fnvHash bs40 - , bench "128" $ whnf fnvHash bs128 - , bench "512" $ whnf fnvHash bs512 - , bench "2^20" $ whnf fnvHash bs1Mb - ] - , bgroup "Int" - [ bench "id32" $ whnf id (0x7eadbeef :: Int32) - , bench "id64" $ whnf id (0x7eadbeefdeadbeef :: Int64) - , bench "wang32" $ whnf hash_wang_32 0xdeadbeef - , bench "wang64" $ whnf hash_wang_64 0xdeadbeefdeadbeef - , 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# } - -new :: Int -> ByteArray# -new (I# n#) = unBA (runST $ ST $ \s1 -> - case newByteArray# n# s1 of - (# s2, ary #) -> case unsafeFreezeByteArray# ary s2 of - (# s3, ba #) -> (# s3, BA ba #)) - -foreign import ccall unsafe "hashable_siphash" c_siphash - :: CInt -> CInt -> Word64 -> Word64 -> Ptr Word8 -> CSize -> Word64 -foreign import ccall unsafe "hashable_siphash24" c_siphash24 - :: Word64 -> Word64 -> Ptr Word8 -> CSize -> Word64 -#ifdef HAVE_SSE2 -foreign import ccall unsafe "hashable_siphash24_sse2" sse2_siphash - :: Word64 -> Word64 -> Ptr Word8 -> CSize -> Word64 -#endif -#ifdef HAVE_SSE41 -foreign import ccall unsafe "hashable_siphash24_sse41" sse41_siphash - :: Word64 -> Word64 -> Ptr Word8 -> CSize -> Word64 -#endif - -foreign import ccall unsafe "hashable_fnv_hash" fnv_hash - :: Ptr Word8 -> CLong -> CLong -> CLong - -foreign import ccall unsafe "hashable_wang_32" hash_wang_32 - :: Word32 -> Word32 -foreign import ccall unsafe "hashable_wang_64" hash_wang_64 - :: Word64 -> Word64 -foreign import ccall unsafe "hash_jenkins_32a" hash_jenkins_32a - :: 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 - diff --git a/benchmarks/cbits/inthash.c b/benchmarks/cbits/inthash.c deleted file mode 100644 --- a/benchmarks/cbits/inthash.c +++ /dev/null @@ -1,28 +0,0 @@ -#include - -/* - * 32-bit hashes by Bob Jenkins. - */ - -uint32_t hash_jenkins_32a(uint32_t a) -{ - a = (a+0x7ed55d16) + (a<<12); - a = (a^0xc761c23c) ^ (a>>19); - a = (a+0x165667b1) + (a<<5); - a = (a+0xd3a2646c) ^ (a<<9); - a = (a+0xfd7046c5) + (a<<3); - a = (a^0xb55a4f09) ^ (a>>16); - return a; -} - -uint32_t hash_jenkins_32b(uint32_t a) -{ - a -= (a<<6); - a ^= (a>>17); - a -= (a<<9); - a ^= (a<<4); - a -= (a<<3); - a ^= (a<<10); - a ^= (a>>15); - return a; -} diff --git a/benchmarks/cbits/siphash-sse2.c b/benchmarks/cbits/siphash-sse2.c deleted file mode 100644 --- a/benchmarks/cbits/siphash-sse2.c +++ /dev/null @@ -1,129 +0,0 @@ -/* - * The original code was developed by Samuel Neves, and has been - * only lightly modified. - * - * Used with permission. - */ -#pragma GCC target("sse2") - -#include -#include "siphash.h" - -#define _mm_roti_epi64(x, c) ((16 == (c)) ? _mm_shufflelo_epi16((x), _MM_SHUFFLE(2,1,0,3)) : _mm_xor_si128(_mm_slli_epi64((x), (c)), _mm_srli_epi64((x), 64-(c)))) - -u64 hashable_siphash24_sse2(u64 ik0, u64 ik1, const u8 *m, size_t n) -{ - __m128i v0, v1, v2, v3; - __m128i k0, k1; - __m128i mi, mask, len; - size_t i, k; - union { u64 gpr; __m128i xmm; } hash; - const u8 *p; - - /* We used to use the _mm_seti_epi32 intrinsic to initialize - SSE2 registers. This compiles to a movdqa instruction, - which requires 16-byte alignment. On 32-bit Windows, it - looks like ghc's runtime linker doesn't align ".rdata" - sections as requested, so we got segfaults for our trouble. - - Now we use an intrinsic that cares less about alignment - (_mm_loadu_si128, aka movdqu) instead, and all seems - happy. */ - - static const u32 const iv[6][4] = { - { 0x70736575, 0x736f6d65, 0, 0 }, - { 0x6e646f6d, 0x646f7261, 0, 0 }, - { 0x6e657261, 0x6c796765, 0, 0 }, - { 0x79746573, 0x74656462, 0, 0 }, - { -1, -1, 0, 0 }, - { 255, 0, 0, 0 }, - }; - - k0 = _mm_loadl_epi64((__m128i*)(&ik0)); - k1 = _mm_loadl_epi64((__m128i*)(&ik1)); - - v0 = _mm_xor_si128(k0, _mm_loadu_si128((__m128i*) &iv[0])); - v1 = _mm_xor_si128(k1, _mm_loadu_si128((__m128i*) &iv[1])); - v2 = _mm_xor_si128(k0, _mm_loadu_si128((__m128i*) &iv[2])); - v3 = _mm_xor_si128(k1, _mm_loadu_si128((__m128i*) &iv[3])); - -#define HALF_ROUND(a,b,c,d,s,t) \ - do \ - { \ - a = _mm_add_epi64(a, b); c = _mm_add_epi64(c, d); \ - b = _mm_roti_epi64(b, s); d = _mm_roti_epi64(d, t); \ - b = _mm_xor_si128(b, a); d = _mm_xor_si128(d, c); \ - } while(0) - -#define COMPRESS(v0,v1,v2,v3) \ - do \ - { \ - HALF_ROUND(v0,v1,v2,v3,13,16); \ - v0 = _mm_shufflelo_epi16(v0, _MM_SHUFFLE(1,0,3,2)); \ - HALF_ROUND(v2,v1,v0,v3,17,21); \ - v2 = _mm_shufflelo_epi16(v2, _MM_SHUFFLE(1,0,3,2)); \ - } while(0) - - for(i = 0; i < (n-n%8); i += 8) - { - mi = _mm_loadl_epi64((__m128i*)(m + i)); - v3 = _mm_xor_si128(v3, mi); - if (SIPHASH_ROUNDS == 2) { - COMPRESS(v0,v1,v2,v3); COMPRESS(v0,v1,v2,v3); - } else { - for (k = 0; k < SIPHASH_ROUNDS; ++k) - COMPRESS(v0,v1,v2,v3); - } - v0 = _mm_xor_si128(v0, mi); - } - - p = m + n; - - /* We must be careful to not trigger a segfault by reading an - unmapped page. So where is the end of our input? */ - - if (((uintptr_t) p & 4095) == 0) - /* Exactly at a page boundary: do not read past the end. */ - mi = _mm_setzero_si128(); - else if (((uintptr_t) p & 4095) <= 4088) - /* Inside a page: safe to read past the end, as we'll - mask out any bits we shouldn't have looked at below. */ - mi = _mm_loadl_epi64((__m128i*)(m + i)); - else - /* Within 8 bytes of the end of a page: ensure that - our final read re-reads some bytes so that we do - not cross the page boundary, then shift our result - right so that the re-read bytes vanish. */ - mi = _mm_srli_epi64(_mm_loadl_epi64((__m128i*)(((uintptr_t) m + i) & ~7)), - 8 * (((uintptr_t) m + i) % 8)); - - len = _mm_set_epi32(0, 0, (n&0xff) << 24, 0); - mask = _mm_srli_epi64(_mm_loadu_si128((__m128i*) &iv[4]), 8*(8-n%8)); - mi = _mm_xor_si128(_mm_and_si128(mi, mask), len); - - v3 = _mm_xor_si128(v3, mi); - if (SIPHASH_ROUNDS == 2) { - COMPRESS(v0,v1,v2,v3); COMPRESS(v0,v1,v2,v3); - } else { - for (k = 0; k < SIPHASH_ROUNDS; ++k) - COMPRESS(v0,v1,v2,v3); - } - v0 = _mm_xor_si128(v0, mi); - - v2 = _mm_xor_si128(v2, _mm_loadu_si128((__m128i*) &iv[5])); - if (SIPHASH_FINALROUNDS == 4) { - COMPRESS(v0,v1,v2,v3); COMPRESS(v0,v1,v2,v3); - COMPRESS(v0,v1,v2,v3); COMPRESS(v0,v1,v2,v3); - } else { - for (k = 0; k < SIPHASH_FINALROUNDS; ++k) - COMPRESS(v0,v1,v2,v3); - } - - v0 = _mm_xor_si128(_mm_xor_si128(v0, v1), _mm_xor_si128(v2, v3)); - hash.xmm = v0; - -#undef COMPRESS -#undef HALF_ROUND - //return _mm_extract_epi32(v0, 0) | (((u64)_mm_extract_epi32(v0, 1)) << 32); - return hash.gpr; -} diff --git a/benchmarks/cbits/siphash-sse41.c b/benchmarks/cbits/siphash-sse41.c deleted file mode 100644 --- a/benchmarks/cbits/siphash-sse41.c +++ /dev/null @@ -1,86 +0,0 @@ -/* - * The original code was developed by Samuel Neves, and has been - * only lightly modified. - * - * Used with permission. - */ -#pragma GCC target("sse4.1") - -#include -#include "siphash.h" - -// Specialized for siphash, do not reuse -#define rotate16(x) _mm_shufflehi_epi16((x), _MM_SHUFFLE(2,1,0,3)) - -#define _mm_roti_epi64(x, c) (((c) == 16) ? rotate16((x)) : _mm_xor_si128(_mm_slli_epi64((x), (c)), _mm_srli_epi64((x), 64-(c)))) -//#define _mm_roti_epi64(x, c) _mm_xor_si128(_mm_slli_epi64((x), (c)), _mm_srli_epi64((x), 64-(c))) - - -u64 hashable_siphash24_sse41(u64 _k0, u64 _k1, const unsigned char *m, size_t n) -{ - __m128i v0, v1, v02, v13; - __m128i k0; - __m128i mi, mask, len, h; - const __m128i zero = _mm_setzero_si128(); - size_t i, k; - union { u64 gpr; __m128i xmm; } hash; - unsigned char key[16]; - - ((u64 *)key)[0] = _k0; - ((u64 *)key)[1] = _k1; - - k0 = _mm_loadu_si128((__m128i*)(key + 0)); - - v0 = _mm_xor_si128(k0, _mm_set_epi32(0x646f7261, 0x6e646f6d, 0x736f6d65, 0x70736575)); - v1 = _mm_xor_si128(k0, _mm_set_epi32(0x74656462, 0x79746573, 0x6c796765, 0x6e657261)); - - v02 = _mm_unpacklo_epi64(v0, v1); - v13 = _mm_unpackhi_epi64(v0, v1); - -#define HALF_ROUND(a,b,s,t) \ -do \ -{ \ - __m128i b1,b2; \ - a = _mm_add_epi64(a, b); \ - b1 = _mm_roti_epi64(b, s); b2 = _mm_roti_epi64(b, t); b = _mm_blend_epi16(b1, b2, 0xF0); \ - b = _mm_xor_si128(b, a); \ -} while(0) - -#define COMPRESS(v02,v13) \ - do \ - { \ - HALF_ROUND(v02,v13,13,16); \ - v02 = _mm_shuffle_epi32(v02, _MM_SHUFFLE(0,1,3,2)); \ - HALF_ROUND(v02,v13,17,21); \ - v02 = _mm_shuffle_epi32(v02, _MM_SHUFFLE(0,1,3,2)); \ - } while(0) - - for(i = 0; i < (n-n%8); i += 8) - { - mi = _mm_loadl_epi64((__m128i*)(m + i)); - v13 = _mm_xor_si128(v13, _mm_unpacklo_epi64(zero, mi)); - for(k = 0; k < SIPHASH_ROUNDS; ++k) COMPRESS(v02,v13); - v02 = _mm_xor_si128(v02, mi); - } - - mi = _mm_loadl_epi64((__m128i*)(m + i)); - len = _mm_set_epi32(0, 0, (n&0xff) << 24, 0); - mask = _mm_srli_epi64(_mm_set_epi32(0, 0, 0xffffffff, 0xffffffff), 8*(8-n%8)); - mi = _mm_xor_si128(_mm_and_si128(mi, mask), len); - - v13 = _mm_xor_si128(v13, _mm_unpacklo_epi64(zero, mi)); - for(k = 0; k < SIPHASH_ROUNDS; ++k) COMPRESS(v02,v13); - v02 = _mm_xor_si128(v02, mi); - - v02 = _mm_xor_si128(v02, _mm_set_epi32(0, 0xff, 0, 0)); - for(k = 0; k < SIPHASH_FINALROUNDS; ++k) COMPRESS(v02,v13); - - v0 = _mm_xor_si128(v02, v13); - v0 = _mm_xor_si128(v0, _mm_castps_si128(_mm_movehl_ps(_mm_castsi128_ps(zero), _mm_castsi128_ps(v0)))); - hash.xmm = v0; - -#undef COMPRESS -#undef HALF_ROUND - //return _mm_extract_epi32(v0, 0) | (((u64)_mm_extract_epi32(v0, 1)) << 32); - return hash.gpr; -} diff --git a/benchmarks/cbits/siphash.c b/benchmarks/cbits/siphash.c deleted file mode 100644 --- a/benchmarks/cbits/siphash.c +++ /dev/null @@ -1,262 +0,0 @@ -/* Almost a verbatim copy of the reference implementation. */ - -#include -#include "siphash.h" - -#define ROTL(x,b) (u64)(((x) << (b)) | ((x) >> (64 - (b)))) - -#define SIPROUND \ - do { \ - v0 += v1; v1=ROTL(v1,13); v1 ^= v0; v0=ROTL(v0,32); \ - v2 += v3; v3=ROTL(v3,16); v3 ^= v2; \ - v0 += v3; v3=ROTL(v3,21); v3 ^= v0; \ - v2 += v1; v1=ROTL(v1,17); v1 ^= v2; v2=ROTL(v2,32); \ - } while(0) - -#if defined(__i386) -# define _siphash24 plain_siphash24 -#endif - -static inline u64 odd_read(const u8 *p, int count, u64 val, int shift) -{ - switch (count) { - case 7: val |= ((u64)p[6]) << (shift + 48); - case 6: val |= ((u64)p[5]) << (shift + 40); - case 5: val |= ((u64)p[4]) << (shift + 32); - case 4: val |= ((u64)p[3]) << (shift + 24); - case 3: val |= ((u64)p[2]) << (shift + 16); - case 2: val |= ((u64)p[1]) << (shift + 8); - case 1: val |= ((u64)p[0]) << shift; - } - return val; -} - -static inline u64 _siphash(int c, int d, u64 k0, u64 k1, - const u8 *str, size_t len) -{ - u64 v0 = 0x736f6d6570736575ull ^ k0; - u64 v1 = 0x646f72616e646f6dull ^ k1; - u64 v2 = 0x6c7967656e657261ull ^ k0; - u64 v3 = 0x7465646279746573ull ^ k1; - const u8 *end, *p; - u64 b; - int i; - - for (p = str, end = str + (len & ~7); p < end; p += 8) { - u64 m = peek_u64le((u64 *) p); - v3 ^= m; - if (c == 2) { - SIPROUND; - SIPROUND; - } else { - for (i = 0; i < c; i++) - SIPROUND; - } - v0 ^= m; - } - - b = odd_read(p, len & 7, ((u64) len) << 56, 0); - - v3 ^= b; - if (c == 2) { - SIPROUND; - SIPROUND; - } else { - for (i = 0; i < c; i++) - SIPROUND; - } - v0 ^= b; - - v2 ^= 0xff; - if (d == 4) { - SIPROUND; - SIPROUND; - SIPROUND; - SIPROUND; - } else { - for (i = 0; i < d; i++) - SIPROUND; - } - b = v0 ^ v1 ^ v2 ^ v3; - return b; -} - - -static inline u64 _siphash24(u64 k0, u64 k1, const u8 *str, size_t len) -{ - return _siphash(2, 4, k0, k1, str, len); -} - -#if defined(__i386) -# undef _siphash24 - -static u64 (*_siphash24)(u64 k0, u64 k1, const u8 *, size_t); - -static void maybe_use_sse() - __attribute__((constructor)); - -static void maybe_use_sse() -{ - uint32_t eax = 1, ebx, ecx, edx; - - __asm volatile - ("mov %%ebx, %%edi;" /* 32bit PIC: don't clobber ebx */ - "cpuid;" - "mov %%ebx, %%esi;" - "mov %%edi, %%ebx;" - :"+a" (eax), "=S" (ebx), "=c" (ecx), "=d" (edx) - : :"edi"); - -#if defined(HAVE_SSE2) - if (edx & (1 << 26)) - _siphash24 = hashable_siphash24_sse2; -#if defined(HAVE_SSE41) - else if (ecx & (1 << 19)) - _siphash24 = hashable_siphash24_sse41; -#endif - else -#endif - _siphash24 = plain_siphash24; -} - -#endif - -/* ghci's linker fails to call static initializers. */ -static inline void ensure_sse_init() -{ -#if defined(__i386) - if (_siphash24 == NULL) - maybe_use_sse(); -#endif -} - -u64 hashable_siphash(int c, int d, u64 k0, u64 k1, const u8 *str, size_t len) -{ - return _siphash(c, d, k0, k1, str, len); -} - -u64 hashable_siphash24(u64 k0, u64 k1, const u8 *str, size_t len) -{ - ensure_sse_init(); - return _siphash24(k0, k1, str, len); -} - -/* Used for ByteArray#s. We can't treat them like pointers in - native Haskell, but we can in unsafe FFI calls. - */ -u64 hashable_siphash24_offset(u64 k0, u64 k1, - const u8 *str, size_t off, size_t len) -{ - ensure_sse_init(); - return _siphash24(k0, k1, str + off, len); -} - -static int _siphash_chunk(int c, int d, int buffered, u64 v[5], - const u8 *str, size_t len, size_t totallen) -{ - u64 v0 = v[0], v1 = v[1], v2 = v[2], v3 = v[3], m, b; - const u8 *p, *end; - u64 carry = 0; - int i; - - if (buffered > 0) { - int unbuffered = 8 - buffered; - int tobuffer = unbuffered > len ? len : unbuffered; - int shift = buffered << 3; - - m = odd_read(str, tobuffer, v[4], shift); - str += tobuffer; - buffered += tobuffer; - len -= tobuffer; - - if (buffered < 8) - carry = m; - else { - v3 ^= m; - if (c == 2) { - SIPROUND; - SIPROUND; - } else { - for (i = 0; i < c; i++) - SIPROUND; - } - v0 ^= m; - buffered = 0; - m = 0; - } - } - - for (p = str, end = str + (len & ~7); p < end; p += 8) { - m = peek_u64le((u64 *) p); - v3 ^= m; - if (c == 2) { - SIPROUND; - SIPROUND; - } else { - for (i = 0; i < c; i++) - SIPROUND; - } - v0 ^= m; - } - - b = odd_read(p, len & 7, 0, 0); - - if (totallen == -1) { - v[0] = v0; - v[1] = v1; - v[2] = v2; - v[3] = v3; - v[4] = b | carry; - - return buffered + (len & 7); - } - - b |= ((u64) totallen) << 56; - - v3 ^= b; - if (c == 2) { - SIPROUND; - SIPROUND; - } else { - for (i = 0; i < c; i++) - SIPROUND; - } - v0 ^= b; - - v2 ^= 0xff; - if (d == 4) { - SIPROUND; - SIPROUND; - SIPROUND; - SIPROUND; - } else { - for (i = 0; i < d; i++) - SIPROUND; - } - v[4] = v0 ^ v1 ^ v2 ^ v3; - return 0; -} - -void hashable_siphash_init(u64 k0, u64 k1, u64 *v) -{ - v[0] = 0x736f6d6570736575ull ^ k0; - v[1] = 0x646f72616e646f6dull ^ k1; - v[2] = 0x6c7967656e657261ull ^ k0; - v[3] = 0x7465646279746573ull ^ k1; - v[4] = 0; -} - -int hashable_siphash24_chunk(int buffered, u64 v[5], const u8 *str, - size_t len, size_t totallen) -{ - return _siphash_chunk(2, 4, buffered, v, str, len, totallen); -} - -/* - * Used for ByteArray#. - */ -int hashable_siphash24_chunk_offset(int buffered, u64 v[5], const u8 *str, - size_t off, size_t len, size_t totallen) -{ - return _siphash_chunk(2, 4, buffered, v, str + off, len, totallen); -} diff --git a/benchmarks/cbits/wang.c b/benchmarks/cbits/wang.c deleted file mode 100644 --- a/benchmarks/cbits/wang.c +++ /dev/null @@ -1,29 +0,0 @@ -/* - * These hash functions were developed by Thomas Wang. - * - * http://www.concentric.net/~ttwang/tech/inthash.htm - */ - -#include - -uint32_t hashable_wang_32(uint32_t a) -{ - a = (a ^ 61) ^ (a >> 16); - a = a + (a << 3); - a = a ^ (a >> 4); - a = a * 0x27d4eb2d; - a = a ^ (a >> 15); - return a; -} - -uint64_t hashable_wang_64(uint64_t key) -{ - key = (~key) + (key << 21); // key = (key << 21) - key - 1; - key = key ^ ((key >> 24) | (key << 40)); - key = (key + (key << 3)) + (key << 8); // key * 265 - key = key ^ ((key >> 14) | (key << 50)); - key = (key + (key << 2)) + (key << 4); // key * 21 - key = key ^ ((key >> 28) | (key << 36)); - key = key + (key << 31); - return key; -} diff --git a/cbits/fnv.c b/cbits/fnv.c --- a/cbits/fnv.c +++ b/cbits/fnv.c @@ -31,6 +31,14 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS == 64 +#define FNV_PRIME 1099511628211 +#else +#define FNV_PRIME 16777619 +#endif + /* FNV-1 hash * * The FNV-1 hash description: http://isthe.com/chongo/tech/comp/fnv/ diff --git a/cbits/getRandomBytes.c b/cbits/getRandomBytes.c deleted file mode 100644 --- a/cbits/getRandomBytes.c +++ /dev/null @@ -1,93 +0,0 @@ -/* -Copyright Bryan O'Sullivan 2012 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Johan Tibell nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -*/ - -#include "MachDeps.h" - -int hashable_getRandomBytes(unsigned char *dest, int nbytes); - -#if defined(mingw32_HOST_OS) || defined(__MINGW32__) - -#include -#include - -int hashable_getRandomBytes(unsigned char *dest, int nbytes) -{ - HCRYPTPROV hCryptProv; - int ret; - - if (!CryptAcquireContextA(&hCryptProv, NULL, NULL, PROV_RSA_FULL, - CRYPT_VERIFYCONTEXT)) - return -1; - - ret = CryptGenRandom(hCryptProv, (DWORD) nbytes, (BYTE *) dest) ? nbytes : -1; - - CryptReleaseContext(hCryptProv, 0); - - bail: - return ret; -} - -#else - -#include -#include -#include - -/* Assumptions: /dev/urandom exists and does something sane, and does - not block. */ - -int hashable_getRandomBytes(unsigned char *dest, int nbytes) -{ - ssize_t off, nread; - int fd; - - fd = open("/dev/urandom", O_RDONLY); - if (fd == -1) - return -1; - - for (off = 0; nbytes > 0; nbytes -= nread) { - nread = read(fd, dest + off, nbytes); - off += nread; - if (nread == -1) { - off = -1; - break; - } - } - - bail: - close(fd); - - return off; -} - -#endif diff --git a/hashable.cabal b/hashable.cabal --- a/hashable.cabal +++ b/hashable.cabal @@ -1,47 +1,32 @@ Cabal-version: 1.12 Name: hashable -Version: 1.3.0.0 +Version: 1.3.1.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 exists for the benefit of hashing-based data structures. The package provides instances for basic types and a way to combine hash values. -Homepage: http://github.com/tibbe/hashable +Homepage: http://github.com/haskell-unordered-containers/hashable -- SPDX-License-Identifier : BSD-3-Clause License: BSD3 License-file: LICENSE Author: Milan Straka Johan Tibell -Maintainer: johan.tibell@gmail.com -bug-reports: https://github.com/tibbe/hashable/issues +Maintainer: Oleg Grenrus +bug-reports: https://github.com/haskell-unordered-containers/hashable/issues Stability: Provisional Category: Data Build-type: Simple -tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: GHC==8.10.3, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 Extra-source-files: CHANGES.md, README.md Flag integer-gmp - Description: Are we using @integer-gmp@ to provide fast Integer instances? + Description: Are we using @integer-gmp@ to provide fast Integer instances? No effect on GHC-9.0 or later. Default: True -Flag sse2 - Description: Do we want to assume that a target supports SSE 2? - Default: True - Manual: True - -Flag sse41 - Description: Do we want to assume that a target supports SSE 4.1? - Default: False - Manual: True - -Flag examples - Description: Build example modules - Default: False - Manual: True - Library Exposed-modules: Data.Hashable Data.Hashable.Lifted @@ -50,18 +35,22 @@ Data.Hashable.Generic.Instances C-sources: cbits/fnv.c + hs-source-dirs: src - Build-depends: base >= 4.5 && < 4.14 - , bytestring >= 0.9 && < 0.11 + Build-depends: base >= 4.5 && < 4.16 + , bytestring >= 0.9 && < 0.12 , deepseq >= 1.3 && < 1.5 , text >= 0.12 && < 1.3 , ghc-prim - if flag(integer-gmp) - Build-depends: integer-gmp >= 0.4 && < 1.1 + if impl(ghc >= 9) + Build-depends: ghc-bignum >= 1.0 && <1.1 else - -- this is needed for the automatic flag to be well-balanced - Build-depends: integer-simple + if flag(integer-gmp) + Build-depends: integer-gmp >= 0.4 && < 1.1 + else + -- this is needed for the automatic flag to be well-balanced + Build-depends: integer-simple Default-Language: Haskell2010 Other-Extensions: BangPatterns @@ -80,7 +69,7 @@ Ghc-options: -Wall -fwarn-tabs -Test-suite tests +Test-suite hashable-tests Type: exitcode-stdio-1.0 Hs-source-dirs: tests Main-is: Main.hs @@ -105,78 +94,13 @@ Ghc-options: -Wall -fno-warn-orphans Default-Language: Haskell2010 -benchmark benchmarks - -- We cannot depend on the hashable library directly as that creates - -- a dependency cycle. - hs-source-dirs: . benchmarks - - main-is: Benchmarks.hs - other-modules: - Data.Hashable - Data.Hashable.Class - Data.Hashable.RandomSource - Data.Hashable.SipHash - type: exitcode-stdio-1.0 - - build-depends: - base, - bytestring, - criterion >= 1.0, - ghc-prim, - siphash, - text - - if impl(ghc) - Build-depends: ghc-prim, - text >= 0.11.0.5 - 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 - benchmarks/cbits/wang.c - cbits/fnv.c - - if (arch(i386) || arch(x86_64)) && flag(sse2) - cpp-options: -DHAVE_SSE2 - c-sources: - benchmarks/cbits/siphash-sse2.c - - if flag(sse41) - cpp-options: -DHAVE_SSE41 - c-sources: - benchmarks/cbits/siphash-sse41.c - - Ghc-options: -Wall -O2 - if impl(ghc >= 6.8) - Ghc-options: -fwarn-tabs - else - c-sources: cbits/getRandomBytes.c - other-modules: Data.Hashable.RandomSource - if os(windows) - extra-libraries: advapi32 - - Default-Language: Haskell2010 - -Executable hashable-examples - if flag(examples) - build-depends: base, hashable - else - buildable: False +test-suite hashable-examples + type: exitcode-stdio-1.0 + build-depends: base, hashable, ghc-prim hs-source-dirs: examples main-is: Main.hs Default-Language: Haskell2010 source-repository head type: git - location: https://github.com/tibbe/hashable.git + location: https://github.com/haskell-unordered-containers/hashable.git diff --git a/src/Data/Hashable.hs b/src/Data/Hashable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hashable.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Trustworthy #-} + +------------------------------------------------------------------------ +-- | +-- Module : Data.Hashable +-- Copyright : (c) Milan Straka 2010 +-- (c) Johan Tibell 2011 +-- (c) Bryan O'Sullivan 2011, 2012 +-- SPDX-License-Identifier : BSD-3-Clause +-- Maintainer : johan.tibell@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- This module defines a class, 'Hashable', for types that can be +-- converted to a hash value. This class exists for the benefit of +-- hashing-based data structures. The module provides instances for +-- most standard types. Efficient instances for other types can be +-- generated automatically and effortlessly using the generics support +-- in GHC 7.4 and above. +-- +-- The easiest way to get started is to use the 'hash' function. Here +-- is an example session with @ghci@. +-- +-- > ghci> import Data.Hashable +-- > ghci> hash "foo" +-- > 60853164 + +module Data.Hashable + ( + -- * Hashing and security + -- $security + + -- * Computing hash values + Hashable(..) + + -- * Creating new instances + -- | There are two ways to create new instances: by deriving + -- instances automatically using GHC's generic programming + -- support or by writing instances manually. + + -- ** Generic instances + -- $generics + + -- *** Understanding a compiler error + -- $generic_err + + -- ** Writing instances by hand + -- $blocks + + -- *** Hashing contructors with multiple fields + -- $multiple-fields + + -- *** Hashing types with multiple constructors + -- $multiple-ctors + + , hashUsing + , hashPtr + , hashPtrWithSalt + , hashByteArray + , hashByteArrayWithSalt + + -- * Caching hashes + , Hashed + , hashed + , unhashed + , mapHashed + , traverseHashed + ) where + +import Data.Hashable.Class +import Data.Hashable.Generic () + +-- $security +-- #security# +-- +-- Applications that use hash-based data structures to store input +-- from untrusted users can be susceptible to \"hash DoS\", a class of +-- denial-of-service attack that uses deliberately chosen colliding +-- inputs to force an application into unexpectedly behaving with +-- quadratic time complexity. +-- +-- At this time, the string hashing functions used in this library are +-- susceptible to such attacks and users are recommended to either use +-- a 'Data.Map' to store keys derived from untrusted input or to use a +-- hash function (e.g. SipHash) that's resistant to such attacks. A +-- future version of this library might ship with such hash functions. + +-- $generics +-- +-- The recommended way to make instances of +-- 'Hashable' for most types is to use the compiler's support for +-- automatically generating default instances using "GHC.Generics". +-- +-- > {-# LANGUAGE DeriveGeneric #-} +-- > +-- > import GHC.Generics (Generic) +-- > import Data.Hashable +-- > +-- > data Foo a = Foo a String +-- > deriving (Eq, Generic) +-- > +-- > instance Hashable a => Hashable (Foo a) +-- > +-- > data Colour = Red | Green | Blue +-- > deriving Generic +-- > +-- > instance Hashable Colour +-- +-- If you omit a body for the instance declaration, GHC will generate +-- a default instance that correctly and efficiently hashes every +-- constructor and parameter. +-- +-- The default implementations are provided by +-- 'genericHashWithSalt' and 'genericLiftHashWithSalt'; those together with +-- the generic type class 'GHashable' and auxiliary functions are exported +-- from the "Data.Hashable.Generic" module. + +-- $generic_err +-- +-- Suppose you intend to use the generic machinery to automatically +-- generate a 'Hashable' instance. +-- +-- > data Oops = Oops +-- > -- forgot to add "deriving Generic" here! +-- > +-- > instance Hashable Oops +-- +-- And imagine that, as in the example above, you forget to add a +-- \"@deriving 'Generic'@\" clause to your data type. At compile time, +-- you will get an error message from GHC that begins roughly as +-- follows: +-- +-- > No instance for (GHashable (Rep Oops)) +-- +-- This error can be confusing, as 'GHashable' is not exported (it is +-- an internal typeclass used by this library's generics machinery). +-- The correct fix is simply to add the missing \"@deriving +-- 'Generic'@\". + +-- $blocks +-- +-- To maintain high quality hashes, new 'Hashable' instances should be +-- built using existing 'Hashable' instances, combinators, and hash +-- functions. +-- +-- The functions below can be used when creating new instances of +-- 'Hashable'. For example, for many string-like types the +-- 'hashWithSalt' method can be defined in terms of either +-- 'hashPtrWithSalt' or 'hashByteArrayWithSalt'. Here's how you could +-- implement an instance for the 'B.ByteString' data type, from the +-- @bytestring@ package: +-- +-- > import qualified Data.ByteString as B +-- > import qualified Data.ByteString.Internal as B +-- > import qualified Data.ByteString.Unsafe as B +-- > import Data.Hashable +-- > import Foreign.Ptr (castPtr) +-- > +-- > instance Hashable B.ByteString where +-- > hashWithSalt salt bs = B.inlinePerformIO $ +-- > B.unsafeUseAsCStringLen bs $ \(p, len) -> +-- > hashPtrWithSalt p (fromIntegral len) salt + +-- $multiple-fields +-- +-- Hash constructors with multiple fields by chaining 'hashWithSalt': +-- +-- > data Date = Date Int Int Int +-- > +-- > instance Hashable Date where +-- > hashWithSalt s (Date yr mo dy) = +-- > s `hashWithSalt` +-- > yr `hashWithSalt` +-- > mo `hashWithSalt` dy +-- +-- If you need to chain hashes together, use 'hashWithSalt' and follow +-- this recipe: +-- +-- > combineTwo h1 h2 = h1 `hashWithSalt` h2 + +-- $multiple-ctors +-- +-- For a type with several value constructors, there are a few +-- possible approaches to writing a 'Hashable' instance. +-- +-- If the type is an instance of 'Enum', the easiest path is to +-- convert it to an 'Int', and use the existing 'Hashable' instance +-- for 'Int'. +-- +-- > data Color = Red | Green | Blue +-- > deriving Enum +-- > +-- > instance Hashable Color where +-- > hashWithSalt = hashUsing fromEnum +-- +-- If the type's constructors accept parameters, it is important to +-- distinguish the constructors. To distinguish the constructors, add +-- a different integer to the hash computation of each constructor: +-- +-- > data Time = Days Int +-- > | Weeks Int +-- > | Months Int +-- > +-- > instance Hashable Time where +-- > hashWithSalt s (Days n) = s `hashWithSalt` +-- > (0::Int) `hashWithSalt` n +-- > hashWithSalt s (Weeks n) = s `hashWithSalt` +-- > (1::Int) `hashWithSalt` n +-- > hashWithSalt s (Months n) = s `hashWithSalt` +-- > (2::Int) `hashWithSalt` n diff --git a/src/Data/Hashable/Class.hs b/src/Data/Hashable/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hashable/Class.hs @@ -0,0 +1,997 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, + ScopedTypeVariables, UnliftedFFITypes, DeriveDataTypeable, + DefaultSignatures, FlexibleContexts, TypeFamilies, + MultiParamTypeClasses #-} + +#if __GLASGOW_HASKELL__ >= 801 +{-# LANGUAGE PolyKinds #-} -- For TypeRep instances +#endif + +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +------------------------------------------------------------------------ +-- | +-- Module : Data.Hashable.Class +-- Copyright : (c) Milan Straka 2010 +-- (c) Johan Tibell 2011 +-- (c) Bryan O'Sullivan 2011, 2012 +-- SPDX-License-Identifier : BSD-3-Clause +-- Maintainer : johan.tibell@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- This module defines a class, 'Hashable', for types that can be +-- converted to a hash value. This class exists for the benefit of +-- hashing-based data structures. The module provides instances for +-- most standard types. + +module Data.Hashable.Class + ( + -- * Computing hash values + Hashable(..) + , Hashable1(..) + , Hashable2(..) + + -- ** Support for generics + , genericHashWithSalt + , genericLiftHashWithSalt + , GHashable(..) + , HashArgs(..) + , Zero + , One + + -- * Creating new instances + , hashUsing + , hashPtr + , 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 Control.DeepSeq (NFData(rnf)) +import Data.Bits (shiftL, shiftR, xor) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Unsafe as B +import Data.Complex (Complex(..)) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.List (foldl') +import Data.Ratio (Ratio, denominator, numerator) +import qualified Data.Text as T +import qualified Data.Text.Array as TA +import qualified Data.Text.Internal as T +import qualified Data.Text.Lazy as TL +import Data.Version (Version(..)) +import Data.Word (Word8, Word16, Word32, Word64) +import Foreign.C (CString) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (Ptr, FunPtr, IntPtr, WordPtr, castPtr, castFunPtrToPtr, ptrToIntPtr) +import Foreign.Storable (alignment, peek, sizeOf) +import GHC.Base (ByteArray#) +import GHC.Conc (ThreadId(..)) +import GHC.Prim (ThreadId#) +import System.IO.Unsafe (unsafeDupablePerformIO) +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 + +import GHC.Generics + +#if MIN_VERSION_base(4,10,0) +import Type.Reflection (Typeable, TypeRep, SomeTypeRep(..)) +import Type.Reflection.Unsafe (typeRepFingerprint) +import GHC.Fingerprint.Type(Fingerprint(..)) +#elif MIN_VERSION_base(4,8,0) +import Data.Typeable (typeRepFingerprint, Typeable, TypeRep) +import GHC.Fingerprint.Type(Fingerprint(..)) +#else +import Data.Typeable.Internal (Typeable, TypeRep (..)) +import GHC.Fingerprint.Type(Fingerprint(..)) +#endif + +#if MIN_VERSION_base(4,5,0) +import Foreign.C (CLong(..)) +import Foreign.C.Types (CInt(..)) +#else +import Foreign.C (CLong) +import Foreign.C.Types (CInt) +#endif + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Word (Word) +#endif + +#if MIN_VERSION_base(4,7,0) +import Data.Bits (finiteBitSize) +#else +import Data.Bits (bitSize) +#endif + +#if !(MIN_VERSION_bytestring(0,10,0)) +import qualified Data.ByteString.Lazy.Internal as BL -- foldlChunks +#endif + +#if MIN_VERSION_bytestring(0,10,4) +import qualified Data.ByteString.Short.Internal as BSI +#endif + +#ifdef VERSION_ghc_bignum +import GHC.Num.BigNat (BigNat (..)) +import GHC.Num.Integer (Integer (..)) +import GHC.Num.Natural (Natural (..)) +import GHC.Exts (Int (..), sizeofByteArray#) +#endif + +#ifdef VERSION_integer_gmp + +# if MIN_VERSION_integer_gmp(1,0,0) +# define MIN_VERSION_integer_gmp_1_0_0 +# endif + +import GHC.Exts (Int(..)) +import GHC.Integer.GMP.Internals (Integer(..)) +# if defined(MIN_VERSION_integer_gmp_1_0_0) +import GHC.Exts (sizeofByteArray#) +import GHC.Integer.GMP.Internals (BigNat(BN#)) +# endif +#endif + +#if MIN_VERSION_base(4,8,0) +import Data.Void (Void, absurd) +import GHC.Exts (Word(..)) +#ifndef VERSION_ghc_bignum +import GHC.Natural (Natural(..)) +#endif +#endif + +#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(..)) + +#if MIN_VERSION_base(4,9,0) +import Data.Kind (Type) +#else +#define Type * +#endif + +#include "MachDeps.h" + +infixl 0 `hashWithSalt` + +------------------------------------------------------------------------ +-- * Computing hash values + +-- | A default salt used in the implementation of 'hash'. +defaultSalt :: Int +#if WORD_SIZE_IN_BITS == 64 +defaultSalt = -3750763034362895579 -- 14695981039346656037 :: Int64 +#else +defaultSalt = -2128831035 -- 2166136261 :: Int32 +#endif +{-# INLINE defaultSalt #-} + +-- | The class of types that can be converted to a hash value. +-- +-- Minimal implementation: 'hashWithSalt'. +class Hashable a where + -- | Return a hash value for the argument, using the given salt. + -- + -- The general contract of 'hashWithSalt' is: + -- + -- * If two values are equal according to the '==' method, then + -- applying the 'hashWithSalt' method on each of the two values + -- /must/ produce the same integer result if the same salt is + -- used in each case. + -- + -- * It is /not/ required that if two values are unequal + -- according to the '==' method, then applying the + -- 'hashWithSalt' method on each of the two values must produce + -- distinct integer results. However, the programmer should be + -- aware that producing distinct integer results for unequal + -- values may improve the performance of hashing-based data + -- structures. + -- + -- * This method can be used to compute different hash values for + -- the same input by providing a different salt in each + -- application of the method. This implies that any instance + -- that defines 'hashWithSalt' /must/ make use of the salt in + -- its implementation. + hashWithSalt :: Int -> a -> Int + + -- | Like 'hashWithSalt', but no salt is used. The default + -- implementation uses 'hashWithSalt' with some default salt. + -- Instances might want to implement this method to provide a more + -- efficient implementation than the default implementation. + hash :: a -> Int + hash = hashWithSalt defaultSalt + + default hashWithSalt :: (Generic a, GHashable Zero (Rep a)) => Int -> a -> Int + hashWithSalt = genericHashWithSalt + {-# INLINE hashWithSalt #-} + +-- | Generic 'hashWithSalt'. +-- +-- @since 1.3.0.0 +genericHashWithSalt :: (Generic a, GHashable Zero (Rep a)) => Int -> a -> Int +genericHashWithSalt = \salt -> ghashWithSalt HashArgs0 salt . from +{-# INLINE genericHashWithSalt #-} + +data Zero +data One + +data family HashArgs arity a :: Type +data instance HashArgs Zero a = HashArgs0 +newtype instance HashArgs One a = HashArgs1 (Int -> a -> Int) + +-- | The class of types that can be generically hashed. +class GHashable arity f where + ghashWithSalt :: HashArgs arity a -> Int -> f a -> Int + +class Hashable1 t where + -- | Lift a hashing function through the type constructor. + liftHashWithSalt :: (Int -> a -> Int) -> Int -> t a -> Int + + default liftHashWithSalt :: (Generic1 t, GHashable One (Rep1 t)) => (Int -> a -> Int) -> Int -> t a -> Int + liftHashWithSalt = genericLiftHashWithSalt + {-# INLINE liftHashWithSalt #-} + +-- | Generic 'liftHashWithSalt'. +-- +-- @since 1.3.0.0 +genericLiftHashWithSalt :: (Generic1 t, GHashable One (Rep1 t)) => (Int -> a -> Int) -> Int -> t a -> Int +genericLiftHashWithSalt = \h salt -> ghashWithSalt (HashArgs1 h) salt . from1 +{-# INLINE genericLiftHashWithSalt #-} + +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 +-- 'defaultHashWith'. +defaultHashWithSalt :: Hashable a => Int -> a -> Int +defaultHashWithSalt salt x = salt `combine` hash x + +-- | Transform a value into a 'Hashable' value, then hash the +-- transformed value using the given salt. +-- +-- This is a useful shorthand in cases where a type can easily be +-- mapped to another type that is already an instance of 'Hashable'. +-- Example: +-- +-- > data Foo = Foo | Bar +-- > deriving (Enum) +-- > +-- > instance Hashable Foo where +-- > hashWithSalt = hashUsing fromEnum +hashUsing :: (Hashable b) => + (a -> b) -- ^ Transformation function. + -> Int -- ^ Salt. + -> a -- ^ Value to transform. + -> Int +hashUsing f salt x = hashWithSalt salt (f x) +{-# INLINE hashUsing #-} + +instance Hashable Int where + hash = id + hashWithSalt = defaultHashWithSalt + +instance Hashable Int8 where + hash = fromIntegral + hashWithSalt = defaultHashWithSalt + +instance Hashable Int16 where + hash = fromIntegral + hashWithSalt = defaultHashWithSalt + +instance Hashable Int32 where + hash = fromIntegral + hashWithSalt = defaultHashWithSalt + +instance Hashable Int64 where + hash n +#if MIN_VERSION_base(4,7,0) + | finiteBitSize (undefined :: Int) == 64 = fromIntegral n +#else + | bitSize (undefined :: Int) == 64 = fromIntegral n +#endif + | otherwise = fromIntegral (fromIntegral n `xor` + (fromIntegral n `shiftR` 32 :: Word64)) + hashWithSalt = defaultHashWithSalt + +instance Hashable Word where + hash = fromIntegral + hashWithSalt = defaultHashWithSalt + +instance Hashable Word8 where + hash = fromIntegral + hashWithSalt = defaultHashWithSalt + +instance Hashable Word16 where + hash = fromIntegral + hashWithSalt = defaultHashWithSalt + +instance Hashable Word32 where + hash = fromIntegral + hashWithSalt = defaultHashWithSalt + +instance Hashable Word64 where + hash n +#if MIN_VERSION_base(4,7,0) + | finiteBitSize (undefined :: Int) == 64 = fromIntegral n +#else + | bitSize (undefined :: Int) == 64 = fromIntegral n +#endif + | otherwise = fromIntegral (n `xor` (n `shiftR` 32)) + hashWithSalt = defaultHashWithSalt + +instance Hashable () where + hash = fromEnum + hashWithSalt = defaultHashWithSalt + +instance Hashable Bool where + hash = fromEnum + hashWithSalt = defaultHashWithSalt + +instance Hashable Ordering where + hash = fromEnum + hashWithSalt = defaultHashWithSalt + +instance Hashable Char where + hash = fromEnum + hashWithSalt = defaultHashWithSalt + +#if defined(MIN_VERSION_integer_gmp_1_0_0) || defined(VERSION_ghc_bignum) +instance Hashable BigNat where + hashWithSalt salt (BN# ba) = hashByteArrayWithSalt ba 0 numBytes salt + `hashWithSalt` size + where + size = numBytes `quot` SIZEOF_HSWORD + numBytes = I# (sizeofByteArray# ba) +#endif + +#if MIN_VERSION_base(4,8,0) +instance Hashable Natural where +# if defined(VERSION_ghc_bignum) + hash (NS n) = hash (W# n) + hash (NB bn) = hash (BN# bn) + + hashWithSalt salt (NS n) = hashWithSalt salt (W# n) + hashWithSalt salt (NB bn) = hashWithSalt salt (BN# bn) +# else +# if defined(MIN_VERSION_integer_gmp_1_0_0) + hash (NatS# n) = hash (W# n) + hash (NatJ# bn) = hash bn + + hashWithSalt salt (NatS# n) = hashWithSalt salt (W# n) + hashWithSalt salt (NatJ# bn) = hashWithSalt salt bn +# else + hash (Natural n) = hash n + + hashWithSalt salt (Natural n) = hashWithSalt salt n +# endif +# endif +#endif + +instance Hashable Integer where +#if defined(VERSION_ghc_bignum) + hash (IS n) = I# n + hash (IP bn) = hash (BN# bn) + hash (IN bn) = negate (hash (BN# bn)) + + hashWithSalt salt (IS n) = hashWithSalt salt (I# n) + hashWithSalt salt (IP bn) = hashWithSalt salt (BN# bn) + hashWithSalt salt (IN bn) = negate (hashWithSalt salt (BN# bn)) +#else +#if defined(VERSION_integer_gmp) +# if defined(MIN_VERSION_integer_gmp_1_0_0) + hash (S# n) = (I# n) + hash (Jp# bn) = hash bn + hash (Jn# bn) = negate (hash bn) + + hashWithSalt salt (S# n) = hashWithSalt salt (I# n) + hashWithSalt salt (Jp# bn) = hashWithSalt salt bn + hashWithSalt salt (Jn# bn) = negate (hashWithSalt salt bn) +# else + hash (S# int) = I# int + hash n@(J# size# byteArray) + | n >= minInt && n <= maxInt = fromInteger n :: Int + | otherwise = let size = I# size# + numBytes = SIZEOF_HSWORD * abs size + in hashByteArrayWithSalt byteArray 0 numBytes defaultSalt + `hashWithSalt` size + where minInt = fromIntegral (minBound :: Int) + maxInt = fromIntegral (maxBound :: Int) + + hashWithSalt salt (S# n) = hashWithSalt salt (I# n) + hashWithSalt salt n@(J# size# byteArray) + | n >= minInt && n <= maxInt = hashWithSalt salt (fromInteger n :: Int) + | otherwise = let size = I# size# + numBytes = SIZEOF_HSWORD * abs size + in hashByteArrayWithSalt byteArray 0 numBytes salt + `hashWithSalt` size + where minInt = fromIntegral (minBound :: Int) + maxInt = fromIntegral (maxBound :: Int) +# endif +#else + hashWithSalt salt = foldl' hashWithSalt salt . go + where + go n | inBounds n = [fromIntegral n :: Int] + | otherwise = fromIntegral n : go (n `shiftR` WORD_SIZE_IN_BITS) + maxInt = fromIntegral (maxBound :: Int) + inBounds x = x >= fromIntegral (minBound :: Int) && x <= maxInt +#endif +#endif + +instance Hashable a => Hashable (Complex a) where + {-# SPECIALIZE instance Hashable (Complex Double) #-} + {-# SPECIALIZE instance Hashable (Complex Float) #-} + hash (r :+ i) = hash r `hashWithSalt` i + hashWithSalt = hashWithSalt1 +instance Hashable1 Complex where + liftHashWithSalt h s (r :+ i) = s `h` r `h` i + +#if MIN_VERSION_base(4,9,0) +-- Starting with base-4.9, numerator/denominator don't need 'Integral' anymore +instance Hashable a => Hashable (Ratio a) where +#else +instance (Integral a, Hashable a) => Hashable (Ratio a) where +#endif + {-# SPECIALIZE instance Hashable (Ratio Integer) #-} + hash a = hash (numerator a) `hashWithSalt` denominator a + hashWithSalt s a = s `hashWithSalt` numerator a `hashWithSalt` denominator a + +-- | __Note__: prior to @hashable-1.3.0.0@, @hash 0.0 /= hash (-0.0)@ +-- +-- The 'hash' of NaN is not well defined. +-- +-- @since 1.3.0.0 +instance Hashable Float where + hash x + | x == -0.0 || x == 0.0 = 0 -- see note in 'Hashable Double' + | isIEEE x = + assert (sizeOf x >= sizeOf (0::Word32) && + alignment x >= alignment (0::Word32)) $ + hash ((unsafeDupablePerformIO $ with x $ peek . castPtr) :: Word32) + | otherwise = hash (show x) + hashWithSalt = defaultHashWithSalt + +-- | __Note__: prior to @hashable-1.3.0.0@, @hash 0.0 /= hash (-0.0)@ +-- +-- The 'hash' of NaN is not well defined. +-- +-- @since 1.3.0.0 +instance Hashable Double where + hash x + | x == -0.0 || x == 0.0 = 0 -- s.t. @hash -0.0 == hash 0.0@ ; see #173 + | isIEEE x = + assert (sizeOf x >= sizeOf (0::Word64) && + alignment x >= alignment (0::Word64)) $ + hash ((unsafeDupablePerformIO $ with x $ peek . castPtr) :: Word64) + | otherwise = hash (show x) + hashWithSalt = defaultHashWithSalt + +-- | A value with bit pattern (01)* (or 5* in hexa), for any size of Int. +-- It is used as data constructor distinguisher. GHC computes its value during +-- compilation. +distinguisher :: Int +distinguisher = fromIntegral $ (maxBound :: Word) `quot` 3 +{-# INLINE distinguisher #-} + +instance Hashable a => Hashable (Maybe a) where + hash Nothing = 0 + hash (Just a) = 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 = 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 = 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 = 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 = 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 = 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 = 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 + hash (a1, a2, a3, a4, a5, a6, a7) = + hash a1 `hashWithSalt` a2 `hashWithSalt` a3 + `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6 `hashWithSalt` a7 + hashWithSalt s (a1, a2, a3, a4, a5, a6, a7) = + 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 + +-- Auxillary type for Hashable [a] definition +data SPInt = SP !Int !Int + +instance Hashable a => Hashable [a] where + {-# SPECIALIZE instance Hashable [Char] #-} + 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 (h s x) (l + 1) + +instance Hashable B.ByteString where + hashWithSalt salt bs = unsafeDupablePerformIO $ + B.unsafeUseAsCStringLen bs $ \(p, len) -> + hashPtrWithSalt p (fromIntegral len) salt + +instance Hashable BL.ByteString where + hashWithSalt = BL.foldlChunks hashWithSalt + +#if MIN_VERSION_bytestring(0,10,4) +instance Hashable BSI.ShortByteString where + hashWithSalt salt sbs@(BSI.SBS ba) = + hashByteArrayWithSalt ba 0 (BSI.length sbs) salt +#endif + +instance Hashable T.Text where + hashWithSalt salt (T.Text arr off len) = + hashByteArrayWithSalt (TA.aBA arr) (off `shiftL` 1) (len `shiftL` 1) + salt + +instance Hashable TL.Text where + hashWithSalt = TL.foldlChunks hashWithSalt + +-- | Compute the hash of a ThreadId. +hashThreadId :: ThreadId -> Int +hashThreadId (ThreadId t) = hash (fromIntegral (getThreadId t) :: Int) + +foreign import ccall unsafe "rts_getThreadId" getThreadId + :: ThreadId# -> CInt + +instance Hashable ThreadId where + 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 + +---------------------------------------------------------------------------- +-- Fingerprint & TypeRep instances + +-- | @since 1.3.0.0 +instance Hashable Fingerprint where + hash (Fingerprint x _) = fromIntegral x + hashWithSalt = defaultHashWithSalt + {-# INLINE hash #-} + +#if MIN_VERSION_base(4,10,0) + +hashTypeRep :: Type.Reflection.TypeRep a -> Int +hashTypeRep tr = + let Fingerprint x _ = typeRepFingerprint tr in fromIntegral x + +instance Hashable Type.Reflection.SomeTypeRep where + hash (Type.Reflection.SomeTypeRep r) = hashTypeRep r + hashWithSalt = defaultHashWithSalt + {-# INLINE hash #-} + +instance Hashable (Type.Reflection.TypeRep a) where + hash = hashTypeRep + hashWithSalt = defaultHashWithSalt + {-# INLINE hash #-} + +#else + +-- | Compute the hash of a TypeRep, in various GHC versions we can do this quickly. +hashTypeRep :: TypeRep -> Int +{-# INLINE hashTypeRep #-} +#if MIN_VERSION_base(4,8,0) +-- Fingerprint is just the MD5, so taking any Int from it is fine +hashTypeRep tr = let Fingerprint x _ = typeRepFingerprint tr in fromIntegral x +#else +-- Fingerprint is just the MD5, so taking any Int from it is fine +hashTypeRep (TypeRep (Fingerprint x _) _ _) = fromIntegral x +#endif + +instance Hashable TypeRep where + hash = hashTypeRep + hashWithSalt = defaultHashWithSalt + {-# INLINE hash #-} + +#endif + +---------------------------------------------------------------------------- + +#if MIN_VERSION_base(4,8,0) +instance Hashable Void where + hashWithSalt _ = absurd +#endif + +-- | Compute a hash value for the content of this pointer. +hashPtr :: Ptr a -- ^ pointer to the data to hash + -> Int -- ^ length, in bytes + -> IO Int -- ^ hash value +hashPtr p len = hashPtrWithSalt p len defaultSalt + +-- | Compute a hash value for the content of this pointer, using an +-- initial salt. +-- +-- This function can for example be used to hash non-contiguous +-- segments of memory as if they were one contiguous segment, by using +-- the output of one hash as the salt for the next. +hashPtrWithSalt :: Ptr a -- ^ pointer to the data to hash + -> Int -- ^ length, in bytes + -> Int -- ^ salt + -> IO Int -- ^ hash value +hashPtrWithSalt p len salt = + fromIntegral `fmap` c_hashCString (castPtr p) (fromIntegral len) + (fromIntegral salt) + +foreign import ccall unsafe "hashable_fnv_hash" c_hashCString + :: CString -> CLong -> CLong -> IO CLong + +-- | Compute a hash value for the content of this 'ByteArray#', +-- beginning at the specified offset, using specified number of bytes. +hashByteArray :: ByteArray# -- ^ data to hash + -> Int -- ^ offset, in bytes + -> Int -- ^ length, in bytes + -> Int -- ^ hash value +hashByteArray ba0 off len = hashByteArrayWithSalt ba0 off len defaultSalt +{-# INLINE hashByteArray #-} + +-- | Compute a hash value for the content of this 'ByteArray#', using +-- an initial salt. +-- +-- This function can for example be used to hash non-contiguous +-- segments of memory as if they were one contiguous segment, by using +-- the output of one hash as the salt for the next. +hashByteArrayWithSalt + :: ByteArray# -- ^ data to hash + -> Int -- ^ offset, in bytes + -> Int -- ^ length, in bytes + -> Int -- ^ salt + -> Int -- ^ hash value +hashByteArrayWithSalt ba !off !len !h = + fromIntegral $ c_hashByteArray ba (fromIntegral off) (fromIntegral len) + (fromIntegral h) + +foreign import ccall unsafe "hashable_fnv_hash_offset" c_hashByteArray + :: ByteArray# -> CLong -> CLong -> CLong -> CLong + +-- | Combine two given hash values. 'combine' has zero as a left +-- identity. +combine :: Int -> Int -> Int +combine h1 h2 = (h1 * 16777619) `xor` h2 + +instance Hashable Unique where + hash = hashUnique + hashWithSalt = defaultHashWithSalt + +instance Hashable Version where + hashWithSalt salt (Version branch tags) = + 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 + hashWithSalt p (a NE.:| as) = p `hashWithSalt` a `hashWithSalt` as + +-- | @since 1.3.1.0 +instance Hashable1 NE.NonEmpty where + liftHashWithSalt h salt (a NE.:| as) = liftHashWithSalt h (h salt a) as + +instance Hashable a => Hashable (Min a) where + hashWithSalt p (Min a) = hashWithSalt p a + +-- | @since 1.3.1.0 +instance Hashable1 Min where liftHashWithSalt h salt (Min a) = h salt a + +instance Hashable a => Hashable (Max a) where + hashWithSalt p (Max a) = hashWithSalt p a + +-- | @since 1.3.1.0 +instance Hashable1 Max where liftHashWithSalt h salt (Max a) = h salt a + +-- | __Note__: Prior to @hashable-1.3.0.0@ the hash computation included the second argument of 'Arg' which wasn't consistent with its 'Eq' instance. +-- +-- @since 1.3.0.0 +instance Hashable a => Hashable (Arg a b) where + hashWithSalt p (Arg a _) = hashWithSalt p a + +instance Hashable a => Hashable (First a) where + hashWithSalt p (First a) = hashWithSalt p a + +-- | @since 1.3.1.0 +instance Hashable1 First where liftHashWithSalt h salt (First a) = h salt a + +instance Hashable a => Hashable (Last a) where + hashWithSalt p (Last a) = hashWithSalt p a + +-- | @since 1.3.1.0 +instance Hashable1 Last where liftHashWithSalt h salt (Last a) = h salt a + +instance Hashable a => Hashable (WrappedMonoid a) where + hashWithSalt p (WrapMonoid a) = hashWithSalt p a + +-- | @since 1.3.1.0 +instance Hashable1 WrappedMonoid where liftHashWithSalt h salt (WrapMonoid a) = h salt a + +instance Hashable a => Hashable (Option a) where + hashWithSalt p (Option a) = hashWithSalt p a + +-- | @since 1.3.1.0 +instance Hashable1 Option where liftHashWithSalt h salt (Option a) = liftHashWithSalt h salt 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 + +instance NFData a => NFData (Hashed a) where + rnf = rnf . unhashed + +-- | '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 diff --git a/src/Data/Hashable/Generic.hs b/src/Data/Hashable/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hashable/Generic.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Data.Hashable.Generic +-- SPDX-License-Identifier : BSD-3-Clause +-- Stability : provisional +-- Portability : GHC >= 7.4 +-- +-- Hashable support for GHC generics. +-- +-- @since 1.3.0.0 +module Data.Hashable.Generic + ( + -- * Implementation using Generics. + genericHashWithSalt + , genericLiftHashWithSalt + -- * Constraints + , GHashable (..) + , One + , Zero + , HashArgs (..) + ) where + +import Data.Hashable.Generic.Instances () +import Data.Hashable.Class diff --git a/src/Data/Hashable/Generic/Instances.hs b/src/Data/Hashable/Generic/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hashable/Generic/Instances.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures, + ScopedTypeVariables, TypeOperators, + MultiParamTypeClasses, GADTs, FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +------------------------------------------------------------------------ +-- | +-- Module : Data.Hashable.Generic.Instances +-- Copyright : (c) Bryan O'Sullivan 2012 +-- SPDX-License-Identifier : BSD-3-Clause +-- Maintainer : bos@serpentine.com +-- Stability : provisional +-- Portability : GHC >= 7.4 +-- +-- Internal module defining orphan instances for "GHC.Generics" +-- +module Data.Hashable.Generic.Instances () where + +import Data.Hashable.Class +import GHC.Generics + +#if MIN_VERSION_base(4,9,0) +import Data.Kind (Type) +#else +#define Type * +#endif + + +-- Type without constructors +instance GHashable arity V1 where + ghashWithSalt _ salt _ = hashWithSalt salt () + +-- Constructor without arguments +instance GHashable arity U1 where + ghashWithSalt _ salt U1 = hashWithSalt salt () + +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 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 arity (K1 i a) where + ghashWithSalt _ = hashUsing unK1 + +instance GHashable One Par1 where + ghashWithSalt (HashArgs1 h) salt = h salt . unPar1 + +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 SumSize f => GSum arity f where + hashSum :: HashArgs arity a -> Int -> Int -> f a -> Int + -- hashSum args salt index value = ... + +-- [Note: Hashing a sum type] +-- +-- The tree structure is used in GHC.Generics to represent the sum (and +-- product) part of the generic represention of the type, e.g.: +-- +-- (C0 ... :+: C1 ...) :+: (C2 ... :+: (C3 ... :+: C4 ...)) +-- +-- The value constructed with C2 constructor is represented as (R1 (L1 ...)). +-- Yet, if we think that this tree is a flat (heterogenous) list: +-- +-- [C0 ..., C1 ..., C2 ..., C3 ..., C4... ] +-- +-- then the value constructed with C2 is a (dependent) pair (2, ...), and +-- hashing it is simple: +-- +-- salt `hashWithSalt` (2 :: Int) `hashWithSalt` ... +-- +-- This is what we do below. When drilling down the tree, we count how many +-- leafs are to the left (`index` variable). At the leaf case C1, we'll have an +-- actual index into the sum. +-- +-- This works well for balanced data. However for recursive types like: +-- +-- data Nat = Z | S Nat +-- +-- the `hashWithSalt salt (S (S (S Z)))` is +-- +-- salt `hashWithSalt` (1 :: Int) -- first S +-- `hashWithSalt` (1 :: Int) -- second S +-- `hashWithSalt` (1 :: Int) -- third S +-- `hashWithSalt` (0 :: Int) -- Z +-- `hashWithSalt` () -- U1 +-- +-- For that type the manual implementation: +-- +-- instance Hashable Nat where +-- hashWithSalt salt n = hashWithSalt salt (natToInteger n) +-- +-- would be better performing CPU and hash-quality wise (assuming that +-- Integer's Hashable is of high quality). +-- +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 !index s = case s of + L1 x -> hashSum toHash salt index x + R1 x -> hashSum toHash salt (index + sizeL) x + where + sizeL = unTagged (sumSize :: Tagged a) + {-# INLINE hashSum #-} + +instance GHashable arity a => GSum arity (C1 c a) where + hashSum toHash !salt !index (M1 x) = ghashWithSalt toHash (hashWithSalt salt index) x + {-# INLINE hashSum #-} + +class SumSize f where + sumSize :: Tagged f + +newtype Tagged (s :: Type -> Type) = Tagged {unTagged :: Int} + +instance (SumSize a, SumSize b) => SumSize (a :+: b) where + sumSize = Tagged $ unTagged (sumSize :: Tagged a) + + unTagged (sumSize :: Tagged b) + +instance SumSize (C1 c a) where + sumSize = Tagged 1 diff --git a/src/Data/Hashable/Lifted.hs b/src/Data/Hashable/Lifted.hs new file mode 100644 --- /dev/null +++ b/src/Data/Hashable/Lifted.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE Trustworthy #-} + +------------------------------------------------------------------------ +-- | +-- Module : Data.Hashable.Lifted +-- Copyright : (c) Milan Straka 2010 +-- (c) Johan Tibell 2011 +-- (c) Bryan O'Sullivan 2011, 2012 +-- SPDX-License-Identifier : BSD-3-Clause +-- 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 :: (a -> Int) -> 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. + diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -19,8 +19,8 @@ import Control.Monad (ap, liftM) import System.IO.Unsafe (unsafePerformIO) import Foreign.Marshal.Array (withArray) -import GHC.Base (ByteArray#, Int(..), newByteArray#, unsafeCoerce#, - writeWord8Array#) +import GHC.Base (ByteArray#, Int(..), newByteArray#, writeWord8Array#) +import GHC.Exts (unsafeCoerce#) import GHC.ST (ST(..), runST) import GHC.Word (Word8(..)) import Test.QuickCheck hiding ((.&.))