Fix Foldable instance for IntMap (fixes #579) (#593)
authorMatt Renaud <matt@m-renaud.com>
Tue, 22 Jan 2019 03:41:53 +0000 (19:41 -0800)
committerGitHub <noreply@github.com>
Tue, 22 Jan 2019 03:41:53 +0000 (19:41 -0800)
* Fix Foldable instance for IntMap.

As reported in https://github.com/haskell/containers/issues/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.

Data/IntMap/Internal.hs
changelog.md
tests/intmap-properties.hs

index 4d78c19..d7f07d9 100644 (file)
@@ -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 #-}
 
 {--------------------------------------------------------------------
index 751b75a..fccb85a 100644 (file)
@@ -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
index 18c55e6..3114df7 100644 (file)
@@ -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)