[commit: packages/containers] merge-fixes-5.9: Fix buggy restrictKeys and withoutKeys (#393) (477cd98)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/containers

On branch  : merge-fixes-5.9
Link       : http://git.haskell.org/packages/containers.git/commitdiff/477cd98375e77bb2581c2bff4501b8e2e1b00850

>---------------------------------------------------------------

commit 477cd98375e77bb2581c2bff4501b8e2e1b00850
Author: David Feuer <David.Feuer at gmail.com>
Date:   Mon Feb 6 16:07:33 2017 -0500

    Fix buggy restrictKeys and withoutKeys (#393)
    
    `restrictKeys` and `withoutKeys` for `Data.IntMap` were completely
    wrong. The QuickCheck properties that should have caught this were
    never actually run.
    
    * Fix the implementations
    
    * Make the tests actually run.
    
    Fixes #392


>---------------------------------------------------------------

477cd98375e77bb2581c2bff4501b8e2e1b00850
 Data/IntMap/Internal.hs    | 53 +++++++++-------------------------------------
 tests/intmap-properties.hs |  2 ++
 2 files changed, 12 insertions(+), 43 deletions(-)

diff --git a/Data/IntMap/Internal.hs b/Data/IntMap/Internal.hs
index 690bc73..37cf8c4 100644
--- a/Data/IntMap/Internal.hs
+++ b/Data/IntMap/Internal.hs
@@ -1059,30 +1059,14 @@ withoutKeys = go
                | zero p1 m2        = bin p2 m2 (go t1 l2) Nil
                | otherwise         = bin p2 m2 Nil (go t1 r2)
 
-    go t1'@(Bin _ _ _ _) t2'@(IntSet.Tip k2' _) = merge0 t2' k2' t1'
-      where
-        merge0 t2 k2 t1@(Bin p1 m1 l1 r1)
-          | nomatch k2 p1 m1 = t1
-          | zero k2 m1 = binCheckLeft p1 m1 (merge0 t2 k2 l1) r1
-          | otherwise  = binCheckRight p1 m1 l1 (merge0 t2 k2 r1)
-        merge0 _ k2 t1@(Tip k1 _)
-          | k1 == k2 = Nil
-          | otherwise = t1
-        merge0 _ _  Nil = Nil
+    go t1'@(Bin _ _ _ _) t2'@(IntSet.Tip _ _) =
+      filterWithKey (\k _ -> k `IntSet.notMember` t2') t1'
 
     go t1@(Bin _ _ _ _) IntSet.Nil = t1
 
-    go t1'@(Tip k1' _) t2' = merge0 t1' k1' t2'
-      where
-        merge0 t1 k1 (IntSet.Bin p2 m2 l2 r2)
-          | nomatch k1 p2 m2 = t1
-          | zero k1 m2 = bin p2 m2 (merge0 t1 k1 l2) Nil
-          | otherwise  = bin p2 m2 Nil (merge0 t1 k1 r2)
-        merge0 t1 k1 (IntSet.Tip k2 _)
-          | k1 == k2 = Nil
-          | otherwise = t1
-        merge0 t1 _  IntSet.Nil = t1
-
+    go t1'@(Tip k1' _) t2'
+      | k1' `IntSet.member` t2' = Nil
+      | otherwise = t1'
     go Nil _ = Nil
 
 
@@ -1120,30 +1104,13 @@ restrictKeys = go
                | zero p1 m2        = bin p2 m2 (go t1 l2) Nil
                | otherwise         = bin p2 m2 Nil (go t1 r2)
 
-    go t1'@(Bin _ _ _ _) t2'@(IntSet.Tip k2' _) = merge0 t2' k2' t1'
-      where
-        merge0 t2 k2 (Bin p1 m1 l1 r1)
-          | nomatch k2 p1 m1 = Nil
-          | zero k2 m1 = bin p1 m1 (merge0 t2 k2 l1) Nil
-          | otherwise  = bin p1 m1 Nil (merge0 t2 k2 r1)
-        merge0 _ k2 t1@(Tip k1 _)
-          | k1 == k2 = t1
-          | otherwise = Nil
-        merge0 _ _  Nil = Nil
-
+    go t1'@(Bin _ _ _ _) t2'@(IntSet.Tip _ _) =
+      filterWithKey (\k _ -> k `IntSet.member` t2') t1'
     go (Bin _ _ _ _) IntSet.Nil = Nil
 
-    go t1'@(Tip k1' _) t2' = merge0 t1' k1' t2'
-      where
-        merge0 t1 k1 (IntSet.Bin p2 m2 l2 r2)
-          | nomatch k1 p2 m2 = Nil
-          | zero k1 m2 = bin p2 m2 (merge0 t1 k1 l2) Nil
-          | otherwise  = bin p2 m2 Nil (merge0 t1 k1 r2)
-        merge0 t1 k1 (IntSet.Tip k2 _)
-          | k1 == k2 = t1
-          | otherwise = Nil
-        merge0 _ _  IntSet.Nil = Nil
-
+    go t1'@(Tip k1' _) t2'
+      | k1' `IntSet.member` t2' = t1'
+      | otherwise = Nil
     go Nil _ = Nil
 
 -- | /O(n+m)/. The intersection with a combining function.
diff --git a/tests/intmap-properties.hs b/tests/intmap-properties.hs
index 21ee9f6..a6fbe2f 100644
--- a/tests/intmap-properties.hs
+++ b/tests/intmap-properties.hs
@@ -167,6 +167,8 @@ main = defaultMain
              , testProperty "foldl'"               prop_foldl'
              , testProperty "keysSet"              prop_keysSet
              , testProperty "fromSet"              prop_fromSet
+             , testProperty "restrictKeys"         prop_restrictKeys
+             , testProperty "withoutKeys"          prop_withoutKeys
              ]
 
 apply2 :: Fun (a, b) c -> a -> b -> c