Merge pull request #140 from phadej/functor-classes

Add instance for Data.Functor.Classes

Author: tibbe

.travis.yml

@@ -13,18 +13,18 @@ before_cache:
 
 matrix:
   include:
-    - env: CABALVER=1.16 GHCVER=7.4.2
+    - env: CABALVER=1.24 GHCVER=7.4.2
       compiler: ": #GHC 7.4.2"
-      addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2], sources: [hvr-ghc]}}
-    - env: CABALVER=1.16 GHCVER=7.6.3
+      addons: {apt: {packages: [cabal-install-1.24,ghc-7.4.2], sources: [hvr-ghc]}}
+    - env: CABALVER=1.24 GHCVER=7.6.3
       compiler: ": #GHC 7.6.3"
-      addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3], sources: [hvr-ghc]}}
-    - env: CABALVER=1.18 GHCVER=7.8.4
+      addons: {apt: {packages: [cabal-install-1.24,ghc-7.6.3], sources: [hvr-ghc]}}
+    - env: CABALVER=1.24 GHCVER=7.8.4
       compiler: ": #GHC 7.8.4"
-      addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
-    - env: CABALVER=1.22 GHCVER=7.10.3
+      addons: {apt: {packages: [cabal-install-1.24,ghc-7.8.4], sources: [hvr-ghc]}}
+    - env: CABALVER=1.24 GHCVER=7.10.3
       compiler: ": #GHC 7.10.3"
-      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}
+      addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3], sources: [hvr-ghc]}}
     - env: CABALVER=1.24 GHCVER=8.0.1
       compiler: ": #GHC 8.0.1"
       addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
@@ -43,7 +43,7 @@ install:
    fi
  - travis_retry cabal update -v
  - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
- - cabal install --only-dependencies --enable-tests --dry -v > installplan.txt
+ - cabal install --only-dependencies --enable-tests --disable-benchmarks --dry -v > installplan.txt
  - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
 
 # check whether current requested install-plan matches cached package-db snapshot
@@ -57,7 +57,7 @@ install:
      echo "cabal build-cache MISS";
      rm -rf $HOME/.cabsnap;
      mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
-     cabal install --only-dependencies --enable-tests;
+     cabal install --only-dependencies --enable-tests --disable-benchmarks;
    fi
 
 # snapshot package-db on cache miss
@@ -73,7 +73,7 @@ install:
 # any command which exits with a non-zero exit code causes the build to fail.
 script:
  - if [ -f configure.ac ]; then autoreconf -i; fi
- - cabal configure --enable-tests -v2  # -v2 provides useful information for debugging
+ - cabal configure --enable-tests --disable-benchmarks -v2  # -v2 provides useful information for debugging
  - cabal build   # this builds all libraries and executables (including tests)
  - cabal test
  - cabal sdist   # tests that a source-distribution can be generated

CHANGES.md

@@ -1,3 +1,11 @@
+## 0.2.8.0
+
+ * Add `Eq1/2`, `Show1/2`, `Read1` instances with `base-4.9`
+
+ * `Eq (HashSet a)` doesn't require `Hashable a` anymore, only `Eq a`.
+
+ * Add `Hashable1/2` with `hashable-1.2.6.0`
+
 ## 0.2.7.2
 
  * Don't use -fregs-graphs

Data/HashMap/Base.hs

@@ -89,6 +89,7 @@ module Data.HashMap.Base
     , updateOrConcatWith
     , updateOrConcatWithKey
     , filterMapAux
+    , equalKeys
     ) where
 
 #if __GLASGOW_HASKELL__ < 710
@@ -125,7 +126,15 @@ import GHC.Exts (isTrue#)
 import qualified GHC.Exts as Exts
 #endif
 
+#if MIN_VERSION_base(4,9,0)
+import Data.Functor.Classes
+#endif
+
+#if MIN_VERSION_hashable(1,2,5)
+import qualified Data.Hashable.Lifted as H
+#endif
 
+-- | A set of values.  A set cannot contain duplicate values.
 ------------------------------------------------------------------------
 
 -- | Convenience function.  Compute a hash value for the given value.
@@ -203,6 +212,25 @@ type Hash   = Word
 type Bitmap = Word
 type Shift  = Int
 
+#if MIN_VERSION_base(4,9,0)
+instance Show2 HashMap where
+    liftShowsPrec2 spk slk spv slv d m =
+        showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)
+      where
+        sp = liftShowsPrec2 spk slk spv slv
+        sl = liftShowList2 spk slk spv slv
+
+instance Show k => Show1 (HashMap k) where
+    liftShowsPrec = liftShowsPrec2 showsPrec showList
+
+instance (Eq k, Hashable k, Read k) => Read1 (HashMap k) where
+    liftReadsPrec rp rl = readsData $
+        readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList
+      where
+        rp' = liftReadsPrec rp rl
+        rl' = liftReadList rp rl
+#endif
+
 instance (Eq k, Hashable k, Read k, Read e) => Read (HashMap k e) where
     readPrec = parens $ prec 10 $ do
       Ident "fromList" <- lexP
@@ -218,26 +246,102 @@ instance (Show k, Show v) => Show (HashMap k v) where
 instance Traversable (HashMap k) where
     traverse f = traverseWithKey (const f)
 
+#if MIN_VERSION_base(4,9,0)
+instance Eq2 HashMap where
+    liftEq2 = equal
+
+instance Eq k => Eq1 (HashMap k) where
+    liftEq = equal (==)
+#endif
+
 instance (Eq k, Eq v) => Eq (HashMap k v) where
-    (==) = equal
+    (==) = equal (==) (==)
 
-equal :: (Eq k, Eq v) => HashMap k v -> HashMap k v -> Bool
-equal t1 t2 = go (toList' t1 []) (toList' t2 [])
+equal :: (k -> k' -> Bool) -> (v -> v' -> Bool)
+      -> HashMap k v -> HashMap k' v' -> Bool
+equal eqk eqv t1 t2 = go (toList' t1 []) (toList' t2 [])
   where
     -- If the two trees are the same, then their lists of 'Leaf's and
     -- 'Collision's read from left to right should be the same (modulo the
     -- order of elements in 'Collision').
 
     go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2)
-      | k1 == k2 && l1 == l2
+      | k1 == k2 && leafEq l1 l2
+      = go tl1 tl2
+    go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2)
+      | k1 == k2 && A.length ary1 == A.length ary2 &&
+        isPermutationBy leafEq (A.toList ary1) (A.toList ary2)
+      = go tl1 tl2
+    go [] [] = True
+    go _  _  = False
+
+    leafEq (L k v) (L k' v') = eqk k k' && eqv v v'
+
+-- Note: previous implemenation isPermutation = null (as // bs)
+-- was O(n^2) too.
+--
+-- This assumes lists are of equal length
+isPermutationBy :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+isPermutationBy f = go
+  where
+    f' = flip f
+
+    go [] [] = True
+    go (x : xs) (y : ys)
+        | f x y     = go xs ys
+        | otherwise = go (deleteBy f' y xs) (deleteBy f x ys)
+    go [] (_ : _) = False
+    go (_ : _) [] = False
+
+-- Data.List.deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]
+deleteBy                :: (a -> b -> Bool) -> a -> [b] -> [b]
+deleteBy _  _ []        = []
+deleteBy eq x (y:ys)    = if x `eq` y then ys else y : deleteBy eq x ys
+
+-- Same as 'equal' but doesn't compare the values.
+equalKeys :: (k -> k' -> Bool) -> HashMap k v -> HashMap k' v' -> Bool
+equalKeys eq t1 t2 = go (toList' t1 []) (toList' t2 [])
+  where
+    go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2)
+      | k1 == k2 && leafEq l1 l2
       = go tl1 tl2
     go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2)
       | k1 == k2 && A.length ary1 == A.length ary2 &&
-        L.null (A.toList ary1 L.\\ A.toList ary2)
+        isPermutationBy leafEq (A.toList ary1) (A.toList ary2)
       = go tl1 tl2
     go [] [] = True
     go _  _  = False
 
+    leafEq (L k _) (L k' _) = eq k k'
+
+#if MIN_VERSION_hashable(1,2,5)
+instance H.Hashable2 HashMap where
+    liftHashWithSalt2 hk hv salt hm = go salt (toList' hm [])
+      where
+        -- go :: Int -> [HashMap k v] -> Int
+        go s [] = s
+        go s (Leaf _ l : tl)
+          = s `hashLeafWithSalt` l `go` tl
+        -- For collisions we hashmix hash value
+        -- and then array of values' hashes sorted
+        go s (Collision h a : tl)
+          = (s `H.hashWithSalt` h) `hashCollisionWithSalt` a `go` tl
+        go s (_ : tl) = s `go` tl
+
+        -- hashLeafWithSalt :: Int -> Leaf k v -> Int
+        hashLeafWithSalt s (L k v) = (s `hk` k) `hv` v
+
+        -- hashCollisionWithSalt :: Int -> A.Array (Leaf k v) -> Int
+        hashCollisionWithSalt s
+          = L.foldl' H.hashWithSalt s . arrayHashesSorted s
+
+        -- arrayHashesSorted :: Int -> A.Array (Leaf k v) -> [Int]
+        arrayHashesSorted s = L.sort . L.map (hashLeafWithSalt s) . A.toList
+
+instance (Hashable k) => H.Hashable1 (HashMap k) where
+    liftHashWithSalt = H.liftHashWithSalt2 H.hashWithSalt
+#endif
+
 instance (Hashable k, Hashable v) => Hashable (HashMap k v) where
     hashWithSalt salt hm = go salt (toList' hm [])
       where
@@ -256,13 +360,10 @@ instance (Hashable k, Hashable v) => Hashable (HashMap k v) where
 
         hashCollisionWithSalt :: Int -> A.Array (Leaf k v) -> Int
         hashCollisionWithSalt s
-          = L.foldl' H.hashWithSalt s . arrayHashesSorted
-
-        arrayHashesSorted :: A.Array (Leaf k v) -> [Int]
-        arrayHashesSorted = L.sort . L.map leafValueHash . A.toList
+          = L.foldl' H.hashWithSalt s . arrayHashesSorted s
 
-        leafValueHash :: Leaf k v -> Int
-        leafValueHash (L _ v) = H.hash v
+        arrayHashesSorted :: Int -> A.Array (Leaf k v) -> [Int]
+        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]

Data/HashSet.hs

@@ -74,7 +74,7 @@ module Data.HashSet
 
 import Control.DeepSeq (NFData(..))
 import Data.Data hiding (Typeable)
-import Data.HashMap.Base (HashMap, foldrWithKey)
+import Data.HashMap.Base (HashMap, foldrWithKey, equalKeys)
 import Data.Hashable (Hashable(hashWithSalt))
 #if __GLASGOW_HASKELL__ >= 711
 import Data.Semigroup (Semigroup(..), Monoid(..))
@@ -93,6 +93,14 @@ import Text.Read
 import qualified GHC.Exts as Exts
 #endif
 
+#if MIN_VERSION_base(4,9,0)
+import Data.Functor.Classes
+#endif
+
+#if MIN_VERSION_hashable(1,2,5)
+import qualified Data.Hashable.Lifted as H
+#endif
+
 -- | A set of values.  A set cannot contain duplicate values.
 newtype HashSet a = HashSet {
       asMap :: HashMap a ()
@@ -106,12 +114,15 @@ instance (NFData a) => NFData (HashSet a) where
     rnf = rnf . asMap
     {-# INLINE rnf #-}
 
-instance (Hashable a, Eq a) => Eq (HashSet a) where
-    -- This performs two passes over the tree.
-    a == b = foldr f True b && size a == size b
-        where f i = (&& i `member` a)
+instance (Eq a) => Eq (HashSet a) where
+    HashSet a == HashSet b = equalKeys (==) a b
     {-# INLINE (==) #-}
 
+#if MIN_VERSION_base(4,9,0)
+instance Eq1 HashSet where
+    liftEq eq (HashSet a) (HashSet b) = equalKeys eq a b
+#endif
+
 instance Foldable.Foldable HashSet where
     foldr = Data.HashSet.foldr
     {-# INLINE foldr #-}
@@ -140,6 +151,12 @@ instance (Eq a, Hashable a, Read a) => Read (HashSet a) where
 
     readListPrec = readListPrecDefault
 
+#if MIN_VERSION_base(4,9,0)
+instance Show1 HashSet where
+    liftShowsPrec sp sl d m =
+        showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)
+#endif
+
 instance (Show a) => Show (HashSet a) where
     showsPrec d m = showParen (d > 10) $
       showString "fromList " . shows (toList m)
@@ -153,6 +170,11 @@ instance (Data a, Eq a, Hashable a) => Data (HashSet a) where
     dataTypeOf _   = hashSetDataType
     dataCast1 f    = gcast1 f
 
+#if MIN_VERSION_hashable(1,2,6)
+instance H.Hashable1 HashSet where
+    liftHashWithSalt h s = H.liftHashWithSalt2 h hashWithSalt s . asMap
+#endif
+
 instance (Hashable a) => Hashable (HashSet a) where
     hashWithSalt salt = hashWithSalt salt . asMap
 

tests/HashMapProperties.hs

@@ -54,8 +54,9 @@ pHashable :: [(Key, Int)] -> [Int] -> Int -> Property
 pHashable xs is salt =
     x == y ==> hashWithSalt salt x === hashWithSalt salt y
   where
-    ys = shuffle is xs
-    x = HM.fromList xs
+    xs' = L.nubBy (\(k,_) (k',_) -> k == k') xs
+    ys = shuffle is xs'
+    x = HM.fromList xs'
     y = HM.fromList ys
     -- Shuffle the list using indexes in the second
     shuffle :: [Int] -> [a] -> [a]

tests/HashSetProperties.hs

@@ -53,8 +53,9 @@ pHashable :: [Key] -> [Int] -> Int -> Property
 pHashable xs is salt =
     x == y ==> hashWithSalt salt x === hashWithSalt salt y
   where
-    ys = shuffle is xs
-    x = S.fromList xs
+    xs' = L.nub xs
+    ys = shuffle is xs'
+    x = S.fromList xs'
     y = S.fromList ys
     shuffle idxs = L.map snd
                  . L.sortBy (comparing fst)

unordered-containers.cabal

@@ -1,5 +1,5 @@
 name:           unordered-containers
-version:        0.2.7.2
+version:        0.2.8.0
 synopsis:       Efficient hashing-based container types
 description:
   Efficient hashing-based container types.  The containers have been