[commit: packages/containers] cleaned_bugfix394, master, merge-doc-target, merge-fixes-5.9, revert-408-bugfix_394: Data.IntMap.Internal: corrected order of effects in mergeA (dec40ee)

[git at git.haskell.org]

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

On branches: cleaned_bugfix394,master,merge-doc-target,merge-fixes-5.9,revert-408-bugfix_394
Link       : http://git.haskell.org/packages/containers.git/commitdiff/dec40eeadd401168226029ef74b6eb1738c36785

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

commit dec40eeadd401168226029ef74b6eb1738c36785
Author: wren romano <wren at community.haskell.org>
Date:   Sun Nov 6 23:36:17 2016 -0800

    Data.IntMap.Internal: corrected order of effects in mergeA
    
    That is, corrected the order for the Tip vs Bin cases. Still haven't
    tested everything all together.


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

dec40eeadd401168226029ef74b6eb1738c36785
 Data/IntMap/Internal.hs | 29 +++++++++++++++++++++++------
 1 file changed, 23 insertions(+), 6 deletions(-)

diff --git a/Data/IntMap/Internal.hs b/Data/IntMap/Internal.hs
index 6947dfe..9da7140 100644
--- a/Data/IntMap/Internal.hs
+++ b/Data/IntMap/Internal.hs
@@ -1593,9 +1593,9 @@ filterAMissing f = WhenMissing
 -- | /O(n)/. Filter keys and values using an 'Applicative' predicate.
 filterWithKeyA
   :: Applicative f => (Key -> a -> f Bool) -> IntMap a -> f (IntMap a)
-filterWithKeyA _ Nil             = pure Nil
-filterWithKeyA f t@(Tip k x)     = (\b -> if b then t else Nil) <$> f k x
-filterWithKeyA f t@(Bin p m l r) =
+filterWithKeyA _ Nil           = pure Nil
+filterWithKeyA f t@(Tip k x)   = (\b -> if b then t else Nil) <$> f k x
+filterWithKeyA f (Bin p m l r) =
     bin p m <$> filterWithKeyA f l <*> filterWithKeyA f r
 
 -- | This wasn't in Data.Bool until 4.7.0, so we define it here
@@ -1804,7 +1804,15 @@ mergeA
     go (Tip k1 x1) t2' = merge2 t2'
       where
         merge2 t2@(Bin p2 m2 l2 r2)
-          | nomatch k1 p2 m2 = link_ k1 p2 <$> subsingletonBy g1k k1 x1 <*> g2t t2
+          | nomatch k1 p2 m2 =
+              -- The obvious implementation, but wrong order of effects.
+              -- > link_ k1 p2 <$> subsingletonBy g1k k1 x1 <*> g2t t2
+              -- The right order of effects, but needs optimizing:
+              let (lts2, gts2) = split k1 t2 in
+              (\lt' t' gt' -> lt' `union` t' `union` gt')
+                <$> g2t lts2
+                <*> subsingletonBy g1k k1 x1
+                <*> g2t gts2
           | zero k1 m2       = bin p2 m2 <$> merge2 l2 <*> g2t r2
           | otherwise        = bin p2 m2 <$> g2t l2 <*> merge2 r2
         merge2 (Tip k2 x2)   = mergeTips k1 x1 k2 x2
@@ -1813,7 +1821,15 @@ mergeA
     go t1' (Tip k2 x2) = merge1 t1'
       where
         merge1 t1@(Bin p1 m1 l1 r1)
-          | nomatch k2 p1 m1 = link_ p1 k2 <$> g1t t1 <*> subsingletonBy g2k k2 x2
+          | nomatch k2 p1 m1 =
+              -- The obvious implementation, but wrong order of effects.
+              -- > link_ p1 k2 <$> g1t t1 <*> subsingletonBy g2k k2 x2
+              -- The right order of effects, but needs optimizing:
+              let (lts1, gts1) = split k2 t1 in
+              (\lt' t' gt' -> lt' `union` t' `union` gt')
+                <$> g1t lts1
+                <*> subsingletonBy g2k k2 x2
+                <*> g1t gts1
           | zero k2 m1       = bin p1 m1 <$> merge1 l1 <*> g1t r1
           | otherwise        = bin p1 m1 <$> g1t l1 <*> merge1 r1
         merge1 (Tip k1 x1)   = mergeTips k1 x1 k2 x2
@@ -1837,10 +1853,11 @@ mergeA
 
     mergeTips k1 x1 k2 x2
       | k1 == k2  = maybe Nil (Tip k1) <$> f k1 x1 x2
-      | otherwise = subdoubleton k1 k2 <$> g1k k1 x1 <*> g2k k2 x2
+      | k1 <  k2  = subdoubleton k1 k2 <$> g1k k1 x1 <*> g2k k2 x2
         {-
         = link_ k1 k2 <$> subsingletonBy g1k k1 x1 <*> subsingletonBy g2k k2 x2
         -}
+      | otherwise = subdoubleton k2 k1 <$> g2k k2 x2 <*> g1k k1 x1
     {-# INLINE mergeTips #-}
 
     subdoubleton _ _   Nothing Nothing     = Nil