Add instance for Data.Functor.Classes

Author: phadej

CHANGES.md

@@ -1,3 +1,9 @@
+## 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`.
+
 ## 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,6 +126,9 @@ import GHC.Exts (isTrue#)
 import qualified GHC.Exts as Exts
 #endif
 
+#if MIN_VERSION_base(4,9,0)
+import Data.Functor.Classes
+#endif
 
 ------------------------------------------------------------------------
 
@@ -203,6 +207,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 +241,74 @@ 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 &&
-        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 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 &&
+        isPermutationBy leafEq (A.toList ary1) (A.toList ary2)
+      = go tl1 tl2
+    go [] [] = True
+    go _  _  = False
+
+    leafEq (L k _) (L k' _) = eq k k'
+
 instance (Hashable k, Hashable v) => Hashable (HashMap k v) where
     hashWithSalt salt hm = go salt (toList' hm [])
       where

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,10 @@ import Text.Read
 import qualified GHC.Exts as Exts
 #endif
 
+#if MIN_VERSION_base(4,9,0)
+import Data.Functor.Classes
+#endif
+
 -- | A set of values.  A set cannot contain duplicate values.
 newtype HashSet a = HashSet {
       asMap :: HashMap a ()
@@ -106,12 +110,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 +147,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)

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