IntMap.mergeA: Fix effects sequencing with negative keys
authorSimon Jakobi <simon.jakobi@gmail.com>
Tue, 17 Dec 2019 18:47:55 +0000 (19:47 +0100)
committerDavid Feuer <David.Feuer@gmail.com>
Wed, 25 Dec 2019 12:35:14 +0000 (07:35 -0500)
Closes #692.

This includes a test for the effects sequencing in Data.Map.mergeA.

containers-tests/tests/intmap-properties.hs
containers-tests/tests/map-properties.hs
containers/src/Data/IntMap/Internal.hs

index 3fd9bfe..4a55bc0 100644 (file)
@@ -153,6 +153,7 @@ main = defaultMain
              , testProperty "intersectionWithKey model" prop_intersectionWithKeyModel
              , testProperty "mergeWithKey model"   prop_mergeWithKeyModel
              , testProperty "merge valid"          prop_merge_valid
+             , testProperty "mergeA effects"       prop_mergeA_effects
              , testProperty "fromAscList"          prop_ordered
              , testProperty "fromList then toList" prop_list
              , testProperty "toDescList"           prop_descList
@@ -1311,6 +1312,17 @@ prop_merge_valid whenMissingA whenMissingB whenMatched xs ys
         xs
         ys
 
+-- This uses the instance
+--     Monoid a => Applicative ((,) a)
+-- to test that effects are sequenced in ascending key order.
+prop_mergeA_effects :: UMap -> UMap -> Property
+prop_mergeA_effects xs ys
+  = effects === sort effects
+  where
+    (effects, _m) = mergeA whenMissing whenMissing whenMatched xs ys
+    whenMissing = traverseMissing (\k _ -> ([k], ()))
+    whenMatched = zipWithAMatched (\k _ _ -> ([k], ()))
+
 ----------------------------------------------------------------
 
 prop_ordered :: Property
index c1bff01..9ade0b5 100644 (file)
@@ -176,6 +176,7 @@ main = defaultMain
          , testProperty "differenceMerge"   prop_differenceMerge
          , testProperty "unionWithKeyMerge"   prop_unionWithKeyMerge
          , testProperty "mergeWithKey model"   prop_mergeWithKeyModel
+         , testProperty "mergeA effects"       prop_mergeA_effects
          , testProperty "fromAscList"          prop_ordered
          , testProperty "fromDescList"         prop_rev_ordered
          , testProperty "fromDistinctDescList" prop_fromDistinctDescList
@@ -1109,6 +1110,17 @@ prop_mergeWithKeyModel xs ys
           -- warnings are issued if testMergeWithKey gets inlined.
           {-# NOINLINE testMergeWithKey #-}
 
+-- This uses the instance
+--     Monoid a => Applicative ((,) a)
+-- to test that effects are sequenced in ascending key order.
+prop_mergeA_effects :: UMap -> UMap -> Property
+prop_mergeA_effects xs ys
+  = effects === sort effects
+  where
+    (effects, _m) = mergeA whenMissing whenMissing whenMatched xs ys
+    whenMissing = traverseMissing (\k _ -> ([k], ()))
+    whenMatched = zipWithAMatched (\k _ _ -> ([k], ()))
+
 ----------------------------------------------------------------
 
 prop_ordered :: Property
index 6503b09..b9238cc 100644 (file)
@@ -2047,8 +2047,8 @@ mergeA
       where
         merge2 t2@(Bin p2 m2 l2 r2)
           | nomatch k1 p2 m2 = linkA k1 (subsingletonBy g1k k1 x1) p2 (g2t t2)
-          | zero k1 m2       = liftA2 (bin p2 m2) (merge2 l2) (g2t r2)
-          | otherwise        = liftA2 (bin p2 m2) (g2t l2) (merge2 r2)
+          | zero k1 m2       = binA p2 m2 (merge2 l2) (g2t r2)
+          | otherwise        = binA p2 m2 (g2t l2) (merge2 r2)
         merge2 (Tip k2 x2)   = mergeTips k1 x1 k2 x2
         merge2 Nil           = subsingletonBy g1k k1 x1
 
@@ -2056,23 +2056,23 @@ mergeA
       where
         merge1 t1@(Bin p1 m1 l1 r1)
           | nomatch k2 p1 m1 = linkA p1 (g1t t1) k2 (subsingletonBy g2k k2 x2)
-          | zero k2 m1       = liftA2 (bin p1 m1) (merge1 l1) (g1t r1)
-          | otherwise        = liftA2 (bin p1 m1) (g1t l1) (merge1 r1)
+          | zero k2 m1       = binA p1 m1 (merge1 l1) (g1t r1)
+          | otherwise        = binA p1 m1 (g1t l1) (merge1 r1)
         merge1 (Tip k1 x1)   = mergeTips k1 x1 k2 x2
         merge1 Nil           = subsingletonBy g2k k2 x2
 
     go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
       | shorter m1 m2  = merge1
       | shorter m2 m1  = merge2
-      | p1 == p2       = liftA2 (bin p1 m1)   (go  l1 l2) (go r1 r2)
-      | otherwise      = liftA2 (link_ p1 p2) (g1t t1)    (g2t   t2)
+      | p1 == p2       = binA p1 m1 (go l1 l2) (go r1 r2)
+      | otherwise      = linkA p1 (g1t t1) p2 (g2t t2)
       where
-        merge1 | nomatch p2 p1 m1  = liftA2 (link_ p1 p2) (g1t t1)    (g2t t2)
-               | zero p2 m1        = liftA2 (bin p1 m1)   (go  l1 t2) (g1t r1)
-               | otherwise         = liftA2 (bin p1 m1)   (g1t l1)    (go  r1 t2)
-        merge2 | nomatch p1 p2 m2  = liftA2 (link_ p1 p2) (g1t t1)    (g2t    t2)
-               | zero p1 m2        = liftA2 (bin p2 m2)   (go  t1 l2) (g2t    r2)
-               | otherwise         = liftA2 (bin p2 m2)   (g2t    l2) (go  t1 r2)
+        merge1 | nomatch p2 p1 m1  = linkA p1 (g1t t1) p2 (g2t t2)
+               | zero p2 m1        = binA p1 m1 (go  l1 t2) (g1t r1)
+               | otherwise         = binA p1 m1 (g1t l1)    (go  r1 t2)
+        merge2 | nomatch p1 p2 m2  = linkA p1 (g1t t1) p2 (g2t t2)
+               | zero p1 m2        = binA p2 m2 (go  t1 l2) (g2t    r2)
+               | otherwise         = binA p2 m2 (g2t    l2) (go  t1 r2)
 
     subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x
     {-# INLINE subsingletonBy #-}
@@ -2092,11 +2092,6 @@ mergeA
     subdoubleton k1 k2 (Just y1) (Just y2) = link k1 (Tip k1 y1) k2 (Tip k2 y2)
     {-# INLINE subdoubleton #-}
 
-    link_ _  _  Nil t2  = t2
-    link_ _  _  t1  Nil = t1
-    link_ p1 p2 t1  t2  = link p1 t1 p2 t2
-    {-# INLINE link_ #-}
-
     -- | A variant of 'link_' which makes sure to execute side-effects
     -- in the right order.
     linkA
@@ -2105,12 +2100,26 @@ mergeA
         -> Prefix -> f (IntMap a)
         -> f (IntMap a)
     linkA p1 t1 p2 t2
-      | zero p1 m = liftA2 (bin p m) t1 t2
-      | otherwise = liftA2 (bin p m) t2 t1
+      | zero p1 m = binA p m t1 t2
+      | otherwise = binA p m t2 t1
       where
         m = branchMask p1 p2
         p = mask p1 m
     {-# INLINE linkA #-}
+
+    -- A variant of 'bin' that ensures that effects for negative keys are executed
+    -- first.
+    binA
+        :: Applicative f
+        => Prefix
+        -> Mask
+        -> f (IntMap a)
+        -> f (IntMap a)
+        -> f (IntMap a)
+    binA p m a b
+      | m < 0     = liftA2 (flip (bin p m)) b a
+      | otherwise = liftA2       (bin p m)  a b
+    {-# INLINE binA #-}
 {-# INLINE mergeA #-}