Fix Foldable instance for IntMap (fixes #579) (#593)

* Fix Foldable instance for IntMap.

As reported in #579 the Foldable
instance for IntMap is unlawful and internally inconsistent. This was caused as
a result of the internal representation used by IntMap.

More specifically, `fold`, `foldMap`, and `traverse` (via `traverseWithKey`)
always placed positively keyed entries before negative keyed ones. To fix this
we need to check to see if the mask is positive or negative.

Tested by adding new property tests, verifying they failed with the
implementation at HEAD, and then passed after the changes.

Author: m-renaud

Data/IntMap/Internal.hs

@@ -441,7 +441,9 @@ instance Foldable.Foldable IntMap where
   fold = go
     where go Nil = mempty
           go (Tip _ v) = v
-          go (Bin _ _ l r) = go l `mappend` go r
+          go (Bin _ m l r)
+            | m < 0     = go r `mappend` go l
+            | otherwise = go l `mappend` go r
   {-# INLINABLE fold #-}
   foldr = foldr
   {-# INLINE foldr #-}
@@ -450,7 +452,9 @@ instance Foldable.Foldable IntMap where
   foldMap f t = go t
     where go Nil = mempty
           go (Tip _ v) = f v
-          go (Bin _ _ l r) = go l `mappend` go r
+          go (Bin _ m l r)
+            | m < 0     = go r `mappend` go l
+            | otherwise = go l `mappend` go r
   {-# INLINE foldMap #-}
   foldl' = foldl'
   {-# INLINE foldl' #-}
@@ -2416,7 +2420,9 @@ traverseWithKey f = go
   where
     go Nil = pure Nil
     go (Tip k v) = Tip k <$> f k v
-    go (Bin p m l r) = liftA2 (Bin p m) (go l) (go r)
+    go (Bin p m l r)
+      | m < 0     = liftA2 (Bin p m) (go r) (go l)
+      | otherwise = liftA2 (Bin p m) (go l) (go r)
 {-# INLINE traverseWithKey #-}
 
 -- | /O(n)/. The function @'mapAccum'@ threads an accumulating
@@ -2875,7 +2881,9 @@ foldMapWithKey f = go
   where
     go Nil           = mempty
     go (Tip kx x)    = f kx x
-    go (Bin _ _ l r) = go l `mappend` go r
+    go (Bin _ m l r)
+      | m < 0     = go r `mappend` go l
+      | otherwise = go l `mappend` go r
 {-# INLINE foldMapWithKey #-}
 
 {--------------------------------------------------------------------

changelog.md

@@ -1,5 +1,11 @@
 # Changelog for [`containers` package](http://github.com/haskell/containers)
 
+## 0.6.0.2
+
+* Fix Foldable instance for IntMap, which previously placed positively
+  keyed entries before negatively keyed ones for `fold`, `foldMap`, and
+  `traverse`.
+
 ## 0.6.0.1
 
 * Released with GHC 8.6

tests/intmap-properties.hs

@@ -12,7 +12,9 @@ import Data.Monoid
 import Data.Maybe hiding (mapMaybe)
 import qualified Data.Maybe as Maybe (mapMaybe)
 import Data.Ord
+import Data.Foldable (foldMap)
 import Data.Function
+import Data.Traversable (Traversable(traverse), foldMapDefault)
 import Prelude hiding (lookup, null, map, filter, foldr, foldl)
 import qualified Prelude (map)
 
@@ -25,6 +27,7 @@ import Test.Framework.Providers.QuickCheck2
 import Test.HUnit hiding (Test, Testable)
 import Test.QuickCheck
 import Test.QuickCheck.Function (Fun(..), apply)
+import Test.QuickCheck.Poly (A, B)
 
 default (Int)
 
@@ -176,6 +179,13 @@ main = defaultMain
              , testProperty "foldr'"               prop_foldr'
              , testProperty "foldl"                prop_foldl
              , testProperty "foldl'"               prop_foldl'
+             , testProperty "foldr==foldMap"       prop_foldrEqFoldMap
+             , testProperty
+                 "foldrWithKey==foldMapWithKey"
+                 prop_foldrWithKeyEqFoldMapWithKey
+             , testProperty
+                 "prop_FoldableTraversableCompat"
+                 prop_FoldableTraversableCompat
              , testProperty "keysSet"              prop_keysSet
              , testProperty "fromSet"              prop_fromSet
              , testProperty "restrictKeys"         prop_restrictKeys
@@ -1156,6 +1166,18 @@ prop_foldl' n ys = length ys > 0 ==>
       foldlWithKey' (\b k _ -> k + b) n m == List.foldr (+) n (List.map fst xs) &&
       foldlWithKey' (\xs k x -> (k,x):xs) [] m == reverse (List.sort xs)
 
+prop_foldrEqFoldMap :: IntMap Int -> Property
+prop_foldrEqFoldMap m =
+  foldr (:) [] m === Data.Foldable.foldMap (:[]) m
+
+prop_foldrWithKeyEqFoldMapWithKey :: IntMap Int -> Property
+prop_foldrWithKeyEqFoldMapWithKey m =
+  foldrWithKey (\k v -> ((k,v):)) [] m === foldMapWithKey (\k v -> ([(k,v)])) m
+
+prop_FoldableTraversableCompat :: Fun A [B] -> IntMap A -> Property
+prop_FoldableTraversableCompat fun m = foldMap f m === foldMapDefault f m
+  where f = apply fun
+
 prop_keysSet :: [(Int, Int)] -> Bool
 prop_keysSet xs =
   keysSet (fromList xs) == IntSet.fromList (List.map fst xs)