Fix false negatives in IntMap.isProperSubmapOfBy

haskell · May 30, 2024 · 7cb250b · 7cb250b
1 parent c651094
commit 7cb250b
Show file tree

Hide file tree

Showing 3 changed files with 25 additions and 2 deletions.
diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs
@@ -1014,6 +1014,9 @@ test_isProperSubmapOfBy = do
     isProperSubmapOfBy (==) (fromList [(-1,1),(2,2)]) (fromList [(-1,1)]) @?= False
     isProperSubmapOfBy (<)  (fromList [(-1,1)])       (fromList [(-1,1),(2,2)]) @?= False
 
+    -- See Github #1007
+    isProperSubmapOfBy (==) (fromList [(-3,1),(-1,1)]) (fromList [(-3,1),(-1,1),(0,1)]) @?= True
+
 test_isProperSubmapOf :: Assertion
 test_isProperSubmapOf = do
     isProperSubmapOf (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True
@@ -1024,6 +1027,9 @@ test_isProperSubmapOf = do
     isProperSubmapOf (fromList [(-1,1),(2,2)]) (fromList [(-1,1),(2,2)]) @?= False
     isProperSubmapOf (fromList [(-1,1),(2,2)]) (fromList [(-1,1)]) @?= False
 
+    -- See Github #1007
+    isProperSubmapOf (fromList [(-3,1),(-1,1)]) (fromList [(-3,1),(-1,1),(0,1)]) @?= True
+
 ----------------------------------------------------------------
 -- Min/Max
 

diff --git a/containers-tests/tests/intset-properties.hs b/containers-tests/tests/intset-properties.hs
@@ -20,6 +20,7 @@ main = defaultMain $ testGroup "intset-properties"
                    , testCase "lookupLE" test_lookupLE
                    , testCase "lookupGE" test_lookupGE
                    , testCase "split" test_split
+                   , testCase "isProperSubsetOf" test_isProperSubsetOf
                    , testProperty "prop_Valid" prop_Valid
                    , testProperty "prop_EmptyValid" prop_EmptyValid
                    , testProperty "prop_SingletonValid" prop_SingletonValid
@@ -109,6 +110,19 @@ test_split :: Assertion
 test_split = do
    split 3 (fromList [1..5]) @?= (fromList [1,2], fromList [4,5])
 
+test_isProperSubsetOf :: Assertion
+test_isProperSubsetOf = do
+    isProperSubsetOf (fromList [1]) (fromList [1,2]) @?= True
+    isProperSubsetOf (fromList [1,2]) (fromList [1,2]) @?= False
+    isProperSubsetOf (fromList [1,2]) (fromList [1]) @?= False
+
+    isProperSubsetOf (fromList [-1]) (fromList [-1,2]) @?= True
+    isProperSubsetOf (fromList [-1,2]) (fromList [-1,2]) @?= False
+    isProperSubsetOf (fromList [-1,2]) (fromList [-1]) @?= False
+
+    -- See Github #1007
+    isProperSubsetOf (fromList [-65,-1]) (fromList [-65,-1,0]) @?= True
+
 {--------------------------------------------------------------------
   Arbitrary, reasonably balanced trees
 --------------------------------------------------------------------}

diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs
@@ -2367,11 +2367,14 @@ submapCmp :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Ordering
 submapCmp predicate t1@(Bin p1 l1 r1) (Bin p2 l2 r2) = case mapMapBranch p1 p2 of
   ABL -> GT
   ABR -> GT
-  BAL -> submapCmp predicate t1 l2
-  BAR -> submapCmp predicate t1 r2
+  BAL -> submapCmpLt l2
+  BAR -> submapCmpLt r2
   EQL -> submapCmpEq
   NOM -> GT  -- disjoint
   where
+    submapCmpLt t = case submapCmp predicate t1 t of
+                      GT -> GT
+                      _  -> LT
     submapCmpEq = case (submapCmp predicate l1 l2, submapCmp predicate r1 r2) of
                     (GT,_ ) -> GT
                     (_ ,GT) -> GT