Make Ord instance Eq compatible

Author: phadej

Data/HashMap/Base.hs

@@ -268,10 +268,12 @@ equal eqk eqv t1 t2 = go (toList' t1 []) (toList' t2 [])
     -- order of elements in 'Collision').
 
     go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2)
-      | k1 == k2 && leafEq 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 &&
+      | k1 == k2 &&
+        A.length ary1 == A.length ary2 &&
         isPermutationBy leafEq (A.toList ary1) (A.toList ary2)
       = go tl1 tl2
     go [] [] = True
@@ -287,6 +289,11 @@ instance Ord k => Ord1 (HashMap k) where
     liftCompare = cmp compare
 #endif
 
+-- | The order is total.
+--
+-- /Note:/ Because the hash is not guaranteed to be stable across library
+-- versions, OSes, or architectures, neither is an actual order of elements in
+-- 'HashMap' or an result of `compare`.is stable.
 instance (Ord k, Ord v) => Ord (HashMap k v) where
     compare = cmp compare compare
 
@@ -295,10 +302,14 @@ cmp :: (k -> k' -> Ordering) -> (v -> v' -> Ordering)
 cmp cmpk cmpv t1 t2 = go (toList' t1 []) (toList' t2 [])
   where
     go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2)
-      = compare k1 k2 `mappend` leafCompare l1 l2 `mappend` go tl1 tl2
+      = compare k1 k2 `mappend`
+        leafCompare l1 l2 `mappend`
+        go tl1 tl2
     go (Collision k1 ary1 : tl1) (Collision k2 ary2 : tl2)
-      = compare k1 k2 `mappend` compare (A.length ary1) (A.length ary2) `mappend`
-        unorderedCompare leafCompare (A.toList ary1) (A.toList ary2)
+      = compare k1 k2 `mappend`
+        compare (A.length ary1) (A.length ary2) `mappend`
+        unorderedCompare leafCompare (A.toList ary1) (A.toList ary2) `mappend`
+        go tl1 tl2
     go (Leaf _ _ : _) (Collision _ _ : _) = LT
     go (Collision _ _ : _) (Leaf _ _ : _) = GT
     go [] [] = EQ

tests/HashMapProperties.hs

@@ -59,6 +59,26 @@ pOrd2 xs ys zs = case (compare x y, compare y z) of
     y = HM.fromList ys
     z = HM.fromList zs
 
+pOrd3 :: [(Key, Int)] -> [(Key, Int)] -> Bool
+pOrd3 xs ys = case (compare x y, compare y x) of
+    (EQ, EQ) -> True
+    (LT, GT) -> True
+    (GT, LT) -> True
+    _        -> False
+  where
+    x = HM.fromList xs
+    y = HM.fromList ys
+
+pOrdEq :: [(Key, Int)] -> [(Key, Int)] -> Bool
+pOrdEq xs ys = case (compare x y, x == y) of
+    (EQ, True)  -> True
+    (LT, False) -> True
+    (GT, False) -> True
+    _           -> False
+  where
+    x = HM.fromList xs
+    y = HM.fromList ys
+
 pReadShow :: [(Key, Int)] -> Bool
 pReadShow xs = M.fromList xs == read (show (M.fromList xs))
 
@@ -275,6 +295,8 @@ tests =
       , testProperty "/=" pNeq
       , testProperty "compare reflexive" pOrd1
       , testProperty "compare transitive" pOrd2
+      , testProperty "compare antisymmetric" pOrd3
+      , testProperty "Ord => Eq" pOrdEq
       , testProperty "Read/Show" pReadShow
       , testProperty "Functor" pFunctor
       , testProperty "Foldable" pFoldable

tests/HashSetProperties.hs

@@ -53,6 +53,26 @@ pOrd2 xs ys zs = case (compare x y, compare y z) of
     y = S.fromList ys
     z = S.fromList zs
 
+pOrd3 :: [Key] -> [Key] -> Bool
+pOrd3 xs ys = case (compare x y, compare y x) of
+    (EQ, EQ) -> True
+    (LT, GT) -> True
+    (GT, LT) -> True
+    _        -> False
+  where
+    x = S.fromList xs
+    y = S.fromList ys
+
+pOrdEq :: [Key] -> [Key] -> Bool
+pOrdEq xs ys = case (compare x y, x == y) of
+    (EQ, True)  -> True
+    (LT, False) -> True
+    (GT, False) -> True
+    _           -> False
+  where
+    x = S.fromList xs
+    y = S.fromList ys
+
 pReadShow :: [Key] -> Bool
 pReadShow xs = Set.fromList xs == read (show (Set.fromList xs))
 
@@ -155,6 +175,10 @@ tests =
       [ testProperty "==" pEq
       , testProperty "Permutation ==" pPermutationEq
       , testProperty "/=" pNeq
+      , testProperty "compare reflexive" pOrd1
+      , testProperty "compare transitive" pOrd2
+      , testProperty "compare antisymmetric" pOrd3
+      , testProperty "Ord => Eq" pOrdEq
       , testProperty "Read/Show" pReadShow
       , testProperty "Foldable" pFoldable
       , testProperty "Hashable" pHashable