Add draft

Author: jappeace

Data/HashMap/Internal.hs

@@ -4,6 +4,8 @@
 {-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 #if __GLASGOW_HASKELL__ >= 802
 {-# LANGUAGE TypeInType #-}
@@ -26,7 +28,8 @@
 
 module Data.HashMap.Internal
     (
-      HashMap(..)
+      HashMapT(..)
+    , HashMap
     , Leaf(..)
 
       -- * Construction
@@ -158,6 +161,7 @@ import qualified Data.List as L
 import GHC.Exts ((==#), build, reallyUnsafePtrEquality#, inline)
 import Prelude hiding (filter, foldl, foldr, lookup, map, null, pred)
 import Text.Read hiding (step)
+import GHC.TypeLits(Nat, natVal)
 
 import qualified Data.HashMap.Internal.Array as A
 import qualified Data.Hashable as H
@@ -196,8 +200,8 @@ import Data.Coerce (coerce)
 ------------------------------------------------------------------------
 
 -- | Convenience function.  Compute a hash value for the given value.
-hash :: H.Hashable a => a -> Hash
-hash = fromIntegral . H.hash
+hash :: H.Hashable a => Integer -> a -> Hash
+hash salt = fromIntegral . H.hashWithSalt (fromIntegral salt)
 
 data Leaf k v = L !k v
   deriving (Eq)
@@ -218,17 +222,27 @@ instance NF.NFData2 Leaf where
 -- Invariant: The length of the 1st argument to 'Full' is
 -- 2^bitsPerSubkey
 
+
+#if WORD_SIZE_IN_BITS == 64
+type DefaultSalt = -2578643520546668380  -- 0xdc36d1615b7400a4
+#else
+type DefaultSalt = 0x087fc72c
+#endif
+
 -- | A map from keys to values.  A map cannot contain duplicate keys;
 -- each key can map to at most one value.
-data HashMap k v
+data HashMapT (salt :: Nat) k v
     = Empty
-    | BitmapIndexed !Bitmap !(A.Array (HashMap k v))
+    | BitmapIndexed !Bitmap !(A.Array (HashMapT salt k v))
     | Leaf !Hash !(Leaf k v)
-    | Full !(A.Array (HashMap k v))
+    | Full !(A.Array (HashMapT salt k v))
     | Collision !Hash !(A.Array (Leaf k v))
       deriving (Typeable)
 
-type role HashMap nominal representational
+-- backwards compatibility
+type HashMap = HashMapT DefaultSalt
+
+type role HashMapT nominal nominal representational
 
 instance (NFData k, NFData v) => NFData (HashMap k v) where
     rnf Empty                 = ()
@@ -397,17 +411,18 @@ instance Eq k => Eq1 (HashMap k) where
 --
 -- In general, the lack of substitutivity can be observed with any function
 -- that depends on the key ordering, such as folds and traversals.
-instance (Eq k, Eq v) => Eq (HashMap k v) where
+instance (Eq k, Eq v) => Eq (HashMapT salt k v) where
     (==) = equal1 (==)
 
 -- We rely on there being no Empty constructors in the tree!
 -- This ensures that two equal HashMaps will have the same
 -- shape, modulo the order of entries in Collisions.
-equal1 :: Eq k
+equal1 :: forall k v v' salt . Eq k
        => (v -> v' -> Bool)
-       -> HashMap k v -> HashMap k v' -> Bool
+       -> HashMapT salt k v -> HashMapT salt k v' -> Bool
 equal1 eq = go
   where
+    go :: HashMapT salt k v -> HashMapT salt k v' -> Bool
     go Empty Empty = True
     go (BitmapIndexed bm1 ary1) (BitmapIndexed bm2 ary2)
       = bm1 == bm2 && A.sameArray1 go ary1 ary2
@@ -420,7 +435,7 @@ equal1 eq = go
     leafEq (L k1 v1) (L k2 v2) = k1 == k2 && eq v1 v2
 
 equal2 :: (k -> k' -> Bool) -> (v -> v' -> Bool)
-      -> HashMap k v -> HashMap k' v' -> Bool
+      -> HashMapT salt k v -> HashMapT salt k' v' -> Bool
 equal2 eqk eqv t1 t2 = go (toList' t1 []) (toList' t2 [])
   where
     -- If the two trees are the same, then their lists of 'Leaf's and
@@ -562,7 +577,7 @@ instance (Hashable k, Hashable v) => Hashable (HashMap k v) where
         arrayHashesSorted s = L.sort . L.map (hashLeafWithSalt s) . A.toList
 
   -- Helper to get 'Leaf's and 'Collision's as a list.
-toList' :: HashMap k v -> [HashMap k v] -> [HashMap k v]
+toList' :: HashMapT salt k v -> [HashMapT salt k v] -> [HashMapT salt k v]
 toList' (BitmapIndexed _ ary) a = A.foldr toList' a ary
 toList' (Full ary)            a = A.foldr toList' a ary
 toList' l@(Leaf _ _)          a = l : a
@@ -579,12 +594,17 @@ isLeafOrCollision _               = False
 -- * Construction
 
 -- | /O(1)/ Construct an empty map.
-empty :: HashMap k v
+empty :: forall k v salt . HashMapT salt k v
 empty = Empty
 
 -- | /O(1)/ Construct a map with a single element.
 singleton :: (Hashable k) => k -> v -> HashMap k v
-singleton k v = Leaf (hash k) (L k v)
+singleton = singleton'
+
+singleton' :: forall k v salt . (Hashable k) => k -> v -> HashMapT salt k v
+singleton' k v = Leaf (hash salt k) (L k v)
+  where
+    salt = natVal (Proxy :: Proxy salt)
 
 ------------------------------------------------------------------------
 -- * Basic interface
@@ -614,7 +634,7 @@ member k m = case lookup k m of
 
 -- | /O(log n)/ Return the value to which the specified key is mapped,
 -- or 'Nothing' if this map contains no mapping for the key.
-lookup :: (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
+lookup :: (Eq k, Hashable k) => k -> HashMapT salt k v -> Maybe v
 #if __GLASGOW_HASKELL__ >= 802
 -- GHC does not yet perform a worker-wrapper transformation on
 -- unboxed sums automatically. That seems likely to happen at some
@@ -624,8 +644,10 @@ lookup k m = case lookup# k m of
   (# | a #) -> Just a
 {-# INLINE lookup #-}
 
-lookup# :: (Eq k, Hashable k) => k -> HashMap k v -> (# (# #) | v #)
-lookup# k m = lookupCont (\_ -> (# (# #) | #)) (\v _i -> (# | v #)) (hash k) k 0 m
+lookup# :: (Eq k, Hashable k) => k -> HashMapT salt k v -> (# (# #) | v #)
+lookup# k m = lookupCont (\_ -> (# (# #) | #)) (\v _i -> (# | v #)) (hash salt k) k 0 m
+  where
+    salt = natVal (Proxy :: Proxy salt)
 {-# INLINABLE lookup# #-}
 
 #else
@@ -708,20 +730,20 @@ lookupRecordCollision h k m = lookupCont (\_ -> Absent) Present h k 0 m
 -- keys at level @n@ of a hashmap, the offset should be @n * bitsPerSubkey@.
 lookupCont ::
 #if __GLASGOW_HASKELL__ >= 802
-  forall rep (r :: TYPE rep) k v.
+  forall rep (r :: TYPE rep) k v salt.
 #else
-  forall r k v.
+  forall r k v salt.
 #endif
      Eq k
   => ((# #) -> r)    -- Absent continuation
   -> (v -> Int -> r) -- Present continuation
   -> Hash -- The hash of the key
   -> k
   -> Int -- The offset of the subkey in the hash.
-  -> HashMap k v -> r
+  -> HashMapT salt k v -> r
 lookupCont absent present !h0 !k0 !s0 !m0 = go h0 k0 s0 m0
   where
-    go :: Eq k => Hash -> k -> Int -> HashMap k v -> r
+    go :: Eq k => Hash -> k -> Int -> HashMapT salt k v -> r
     go !_ !_ !_ Empty = absent (# #)
     go h k _ (Leaf hx (L kx x))
         | h == hx && k == kx = present x (-1)
@@ -806,11 +828,13 @@ bitmapIndexedOrFull b ary
 -- | /O(log n)/ Associate the specified value with the specified
 -- key in this map.  If this map previously contained a mapping for
 -- the key, the old value is replaced.
-insert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v
-insert k v m = insert' (hash k) k v m
+insert :: forall k v salt . (Eq k, Hashable k) => k -> v -> HashMapT salt k v -> HashMapT salt k v
+insert k v m = insert' (hash salt k) k v m
+  where
+    salt = natVal (Proxy :: Proxy salt)
 {-# INLINABLE insert #-}
 
-insert' :: Eq k => Hash -> k -> v -> HashMap k v -> HashMap k v
+insert' :: forall k v salt . Eq k => Hash -> k -> v -> HashMapT salt k v -> HashMapT salt k v
 insert' h0 k0 v0 m0 = go h0 k0 v0 0 m0
   where
     go !h !k x !_ Empty = Leaf h (L k x)
@@ -934,7 +958,7 @@ setAtPosition i k x ary = A.update ary i (L k x)
 
 
 -- | In-place update version of insert
-unsafeInsert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v
+unsafeInsert :: (Eq k) => k -> v -> HashMap k v -> HashMap k v
 unsafeInsert k0 v0 m0 = runST (go h0 k0 v0 0 m0)
   where
     h0 = hash k0