[commit: packages/containers] ghc-head: Improve Traversable instance of Map. (4d24ff5)

[git at git.haskell.org]

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

On branch  : ghc-head
Link       : http://git.haskell.org/?p=packages/containers.git;a=commit;h=4d24ff5d08f0bb27ca73a9888286d6426149515b

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

commit 4d24ff5d08f0bb27ca73a9888286d6426149515b
Author: Milan Straka <fox at ucw.cz>
Date:   Sun Jun 9 13:38:09 2013 +0200

    Improve Traversable instance of Map.
    
    Similarly to Foldable instance (commit #29d3fbcc), add a special case in
    traverseWithKey when traversing a leaf. In this case, the Tips under the
    leaf are not traversed. The speedup is 25%.
    
    See the log of the mentioned commit #29d3fbcc for discussion of
    alternative implementations.


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

4d24ff5d08f0bb27ca73a9888286d6426149515b
 Data/IntMap/Base.hs |    1 +
 Data/Map/Base.hs    |    5 +++--
 2 files changed, 4 insertions(+), 2 deletions(-)

diff --git a/Data/IntMap/Base.hs b/Data/IntMap/Base.hs
index 8e21d7c..0e80f26 100644
--- a/Data/IntMap/Base.hs
+++ b/Data/IntMap/Base.hs
@@ -312,6 +312,7 @@ instance Foldable.Foldable IntMap where
 
 instance Traversable IntMap where
     traverse f = traverseWithKey (\_ -> f)
+    {-# INLINE traverse #-}
 
 instance NFData a => NFData (IntMap a) where
     rnf Nil = ()
diff --git a/Data/Map/Base.hs b/Data/Map/Base.hs
index 19918b1..30cac67 100644
--- a/Data/Map/Base.hs
+++ b/Data/Map/Base.hs
@@ -1658,8 +1658,8 @@ traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b)
 traverseWithKey f = go
   where
     go Tip = pure Tip
-    go (Bin s k v l r)
-      = flip (Bin s k) <$> go l <*> f k v <*> go r
+    go (Bin 1 k v _ _) = (\v' -> Bin 1 k v' Tip Tip) <$> f k v
+    go (Bin s k v l r) = flip (Bin s k) <$> go l <*> f k v <*> go r
 {-# INLINE traverseWithKey #-}
 
 -- | /O(n)/. The function 'mapAccum' threads an accumulating
@@ -2601,6 +2601,7 @@ instance Functor (Map k) where
 
 instance Traversable (Map k) where
   traverse f = traverseWithKey (\_ -> f)
+  {-# INLINE traverse #-}
 
 instance Foldable.Foldable (Map k) where
   fold t = go t