Stop using hedge algorithms
[packages/containers.git] / Data / IntMap / Base.hs
index fc46f83..f45e7d1 100644 (file)
@@ -1,10 +1,18 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
 #if __GLASGOW_HASKELL__
 {-# LANGUAGE MagicHash, DeriveDataTypeable, StandaloneDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 #endif
 #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703
 {-# LANGUAGE Trustworthy #-}
 #endif
+#if __GLASGOW_HASKELL__ >= 708
+{-# LANGUAGE TypeFamilies #-}
+#endif
+
+#include "containers.h"
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.IntMap.Base
 -- on representations.
 -----------------------------------------------------------------------------
 
+-- [Note: INLINE bit fiddling]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- It is essential that the bit fiddling functions like mask, zero, branchMask
 -- etc are inlined. If they do not, the memory allocation skyrockets. The GHC
 -- usually gets it right, but it is disastrous if it does not. Therefore we
 -- explicitly mark these functions INLINE.
 
-module Data.IntMap.Base (
-            -- * Map type
-              IntMap(..), Key          -- instance Eq,Show
-
-            -- * Operators
-            , (!), (\\)
-
-            -- * Query
-            , null
-            , size
-            , member
-            , notMember
-            , lookup
-            , findWithDefault
-
-            -- * Construction
-            , empty
-            , singleton
-
-            -- ** Insertion
-            , insert
-            , insertWith
-            , insertWithKey
-            , insertLookupWithKey
-
-            -- ** Delete\/Update
-            , delete
-            , adjust
-            , adjustWithKey
-            , update
-            , updateWithKey
-            , updateLookupWithKey
-            , alter
-
-            -- * Combine
-
-            -- ** Union
-            , union
-            , unionWith
-            , unionWithKey
-            , unions
-            , unionsWith
-
-            -- ** Difference
-            , difference
-            , differenceWith
-            , differenceWithKey
-
-            -- ** Intersection
-            , intersection
-            , intersectionWith
-            , intersectionWithKey
-
-            -- * Traversal
-            -- ** Map
-            , map
-            , mapWithKey
-            , mapAccum
-            , mapAccumWithKey
-            , mapAccumRWithKey
-            , mapKeys
-            , mapKeysWith
-            , mapKeysMonotonic
-
-            -- * Folds
-            , foldr
-            , foldl
-            , foldrWithKey
-            , foldlWithKey
-            -- ** Strict folds
-            , foldr'
-            , foldl'
-            , foldrWithKey'
-            , foldlWithKey'
-
-            -- * Conversion
-            , elems
-            , keys
-            , keysSet
-            , assocs
-
-            -- ** Lists
-            , toList
-            , fromList
-            , fromListWith
-            , fromListWithKey
-
-            -- ** Ordered lists
-            , toAscList
-            , toDescList
-            , fromAscList
-            , fromAscListWith
-            , fromAscListWithKey
-            , fromDistinctAscList
-
-            -- * Filter
-            , filter
-            , filterWithKey
-            , partition
-            , partitionWithKey
-
-            , mapMaybe
-            , mapMaybeWithKey
-            , mapEither
-            , mapEitherWithKey
-
-            , split
-            , splitLookup
-
-            -- * Submap
-            , isSubmapOf, isSubmapOfBy
-            , isProperSubmapOf, isProperSubmapOfBy
-
-            -- * Min\/Max
-            , findMin
-            , findMax
-            , deleteMin
-            , deleteMax
-            , deleteFindMin
-            , deleteFindMax
-            , updateMin
-            , updateMax
-            , updateMinWithKey
-            , updateMaxWithKey
-            , minView
-            , maxView
-            , minViewWithKey
-            , maxViewWithKey
-
-            -- * Debugging
-            , showTree
-            , showTreeWith
-
-            -- * Internal types
-            , Mask, Prefix, Nat
-
-            -- * Utility
-            , natFromInt
-            , intFromNat
-            , shiftRL
-            , join
-            , bin
-            , zero
-            , nomatch
-            , match
-            , mask
-            , maskW
-            , shorter
-            , branchMask
-            , highestBitMask
-            , foldlStrict
-            ) where
 
-import Data.Bits
+-- [Note: Local 'go' functions and capturing]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Care must be taken when using 'go' function which captures an argument.
+-- Sometimes (for example when the argument is passed to a data constructor,
+-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code
+-- must be checked for increased allocation when creating and modifying such
+-- functions.
+
+
+-- [Note: Order of constructors]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The order of constructors of IntMap matters when considering performance.
+-- Currently in GHC 7.0, when type has 3 constructors, they are matched from
+-- the first to the last -- the best performance is achieved when the
+-- constructors are ordered by frequency.
+-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil
+-- improves the benchmark by circa 10%.
 
-import Prelude hiding (lookup,map,filter,foldr,foldl,null)
-import qualified Data.IntSet as IntSet
+module Data.IntMap.Base (
+    -- * Map type
+      IntMap(..), Key          -- instance Eq,Show
+
+    -- * Operators
+    , (!), (\\)
+
+    -- * Query
+    , null
+    , size
+    , member
+    , notMember
+    , lookup
+    , findWithDefault
+    , lookupLT
+    , lookupGT
+    , lookupLE
+    , lookupGE
+
+    -- * Construction
+    , empty
+    , singleton
+
+    -- ** Insertion
+    , insert
+    , insertWith
+    , insertWithKey
+    , insertLookupWithKey
+
+    -- ** Delete\/Update
+    , delete
+    , adjust
+    , adjustWithKey
+    , update
+    , updateWithKey
+    , updateLookupWithKey
+    , alter
+    , alterF
+
+    -- * Combine
+
+    -- ** Union
+    , union
+    , unionWith
+    , unionWithKey
+    , unions
+    , unionsWith
+
+    -- ** Difference
+    , difference
+    , differenceWith
+    , differenceWithKey
+
+    -- ** Intersection
+    , intersection
+    , intersectionWith
+    , intersectionWithKey
+
+    -- ** Universal combining function
+    , mergeWithKey
+    , mergeWithKey'
+
+    -- * Traversal
+    -- ** Map
+    , map
+    , mapWithKey
+    , traverseWithKey
+    , mapAccum
+    , mapAccumWithKey
+    , mapAccumRWithKey
+    , mapKeys
+    , mapKeysWith
+    , mapKeysMonotonic
+
+    -- * Folds
+    , foldr
+    , foldl
+    , foldrWithKey
+    , foldlWithKey
+    , foldMapWithKey
+
+    -- ** Strict folds
+    , foldr'
+    , foldl'
+    , foldrWithKey'
+    , foldlWithKey'
+
+    -- * Conversion
+    , elems
+    , keys
+    , assocs
+    , keysSet
+    , fromSet
+
+    -- ** Lists
+    , toList
+    , fromList
+    , fromListWith
+    , fromListWithKey
+
+    -- ** Ordered lists
+    , toAscList
+    , toDescList
+    , fromAscList
+    , fromAscListWith
+    , fromAscListWithKey
+    , fromDistinctAscList
+
+    -- * Filter
+    , filter
+    , filterWithKey
+    , restrictKeys
+    , withoutKeys
+    , partition
+    , partitionWithKey
+
+    , mapMaybe
+    , mapMaybeWithKey
+    , mapEither
+    , mapEitherWithKey
+
+    , split
+    , splitLookup
+    , splitRoot
+
+    -- * Submap
+    , isSubmapOf, isSubmapOfBy
+    , isProperSubmapOf, isProperSubmapOfBy
+
+    -- * Min\/Max
+    , findMin
+    , findMax
+    , deleteMin
+    , deleteMax
+    , deleteFindMin
+    , deleteFindMax
+    , updateMin
+    , updateMax
+    , updateMinWithKey
+    , updateMaxWithKey
+    , minView
+    , maxView
+    , minViewWithKey
+    , maxViewWithKey
+
+    -- * Debugging
+    , showTree
+    , showTreeWith
+
+    -- * Internal types
+    , Mask, Prefix, Nat
+
+    -- * Utility
+    , natFromInt
+    , intFromNat
+    , link
+    , bin
+    , binCheckLeft
+    , binCheckRight
+    , zero
+    , nomatch
+    , match
+    , mask
+    , maskW
+    , shorter
+    , branchMask
+    , highestBitMask
+    ) where
+
+#if !(MIN_VERSION_base(4,8,0))
+import Control.Applicative (Applicative(pure, (<*>)), (<$>))
 import Data.Monoid (Monoid(..))
-import Data.Maybe (fromMaybe)
-import Data.Typeable
-import qualified Data.Foldable as Foldable
 import Data.Traversable (Traversable(traverse))
-import Control.Applicative (Applicative(pure,(<*>)),(<$>))
-import Control.Monad ( liftM )
+import Data.Word (Word)
+#endif
+#if MIN_VERSION_base(4,9,0)
+import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)
+#endif
+
 import Control.DeepSeq (NFData(rnf))
+import Control.Monad (liftM)
+import Data.Bits
+import qualified Data.Foldable as Foldable
+import Data.Maybe (fromMaybe)
+import Data.Typeable
+import Prelude hiding (lookup, map, filter, foldr, foldl, null)
+
+import Data.IntSet.Base (Key)
+import qualified Data.IntSet.Base as IntSet
+import Data.Utils.BitUtil
+import Data.Utils.StrictFold
+import Data.Utils.StrictPair
 
 #if __GLASGOW_HASKELL__
+import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix),
+                  DataType, mkDataType)
+import GHC.Exts (build)
+#if !MIN_VERSION_base(4,8,0)
+import Data.Functor ((<$))
+#endif
+#if __GLASGOW_HASKELL__ >= 708
+import qualified GHC.Exts as GHCExts
+#endif
 import Text.Read
-import Data.Data (Data(..), mkNoRepType)
 #endif
-
-#if __GLASGOW_HASKELL__
-import GHC.Exts ( Word(..), Int(..), shiftRL#, build )
-#else
-import Data.Word
+#if __GLASGOW_HASKELL__ >= 709
+import Data.Coerce
 #endif
 
--- Use macros to define strictness of functions.
--- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.
--- We do not use BangPatterns, because they are not in any standard and we
--- want the compilers to be compiled by as many compilers as possible.
-#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined
 
 -- A "Nat" is a natural machine word (an unsigned Int)
 type Nat = Word
@@ -218,37 +274,23 @@ intFromNat :: Nat -> Key
 intFromNat = fromIntegral
 {-# INLINE intFromNat #-}
 
-shiftRL :: Nat -> Key -> Nat
-#if __GLASGOW_HASKELL__
-{--------------------------------------------------------------------
-  GHC: use unboxing to get @shiftRL@ inlined.
---------------------------------------------------------------------}
-shiftRL (W# x) (I# i)
-  = W# (shiftRL# x i)
-#else
-shiftRL x i   = shiftR x i
-{-# INLINE shiftRL #-}
-#endif
-
 {--------------------------------------------------------------------
   Types
 --------------------------------------------------------------------}
 
--- The order of constructors of IntMap matters when considering performance.
--- Currently in GHC 7.0, when type has 3 constructors, they are matched from
--- the first to the last -- the best performance is achieved when the
--- constructors are ordered by frequency.
--- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil
--- improves the containers_benchmark by 9.5% on x86 and by 8% on x86_64.
 
 -- | A map of integers to values @a@.
-data IntMap a = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(IntMap a) !(IntMap a)
+
+-- See Note: Order of constructors
+data IntMap a = Bin {-# UNPACK #-} !Prefix
+                    {-# UNPACK #-} !Mask
+                    !(IntMap a)
+                    !(IntMap a)
               | Tip {-# UNPACK #-} !Key a
               | Nil
 
 type Prefix = Int
 type Mask   = Int
-type Key    = Int
 
 {--------------------------------------------------------------------
   Operators
@@ -261,7 +303,7 @@ type Key    = Int
 -- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'
 
 (!) :: IntMap a -> Key -> a
-m ! k    = find k m
+(!) m k = find k m
 
 -- | Same as 'difference'.
 (\\) :: IntMap a -> IntMap b -> IntMap a
@@ -275,23 +317,78 @@ infixl 9 \\{-This comment teaches CPP correct behaviour -}
 
 instance Monoid (IntMap a) where
     mempty  = empty
-    mappend = union
     mconcat = unions
+#if !(MIN_VERSION_base(4,9,0))
+    mappend = union
+#else
+    mappend = (<>)
+
+instance Semigroup (IntMap a) where
+    (<>)    = union
+    stimes  = stimesIdempotentMonoid
+#endif
 
 instance Foldable.Foldable IntMap where
-  fold Nil = mempty
-  fold (Tip _ v) = v
-  fold (Bin _ _ l r) = Foldable.fold l `mappend` Foldable.fold r
+  fold = go
+    where go Nil = mempty
+          go (Tip _ v) = v
+          go (Bin _ _ l r) = go l `mappend` go r
+  {-# INLINABLE fold #-}
   foldr = foldr
+  {-# INLINE foldr #-}
   foldl = foldl
-  foldMap _ Nil = mempty
-  foldMap f (Tip _k v) = f v
-  foldMap f (Bin _ _ l r) = Foldable.foldMap f l `mappend` Foldable.foldMap f r
+  {-# INLINE foldl #-}
+  foldMap f t = go t
+    where go Nil = mempty
+          go (Tip _ v) = f v
+          go (Bin _ _ l r) = go l `mappend` go r
+  {-# INLINE foldMap #-}
+
+#if MIN_VERSION_base(4,6,0)
+  foldl' = foldl'
+  {-# INLINE foldl' #-}
+  foldr' = foldr'
+  {-# INLINE foldr' #-}
+#endif
+#if MIN_VERSION_base(4,8,0)
+  length = size
+  {-# INLINE length #-}
+  null   = null
+  {-# INLINE null #-}
+  toList = elems -- NB: Foldable.toList /= IntMap.toList
+  {-# INLINE toList #-}
+  elem = go
+    where go !_ Nil = False
+          go x (Tip _ y) = x == y
+          go x (Bin _ _ l r) = go x l || go x r
+  {-# INLINABLE elem #-}
+  maximum = start
+    where start Nil = error "IntMap.Foldable.maximum: called with empty map"
+          start (Tip _ y) = y
+          start (Bin _ _ l r) = go (start l) r
+
+          go !m Nil = m
+          go m (Tip _ y) = max m y
+          go m (Bin _ _ l r) = go (go m l) r
+  {-# INLINABLE maximum #-}
+  minimum = start
+    where start Nil = error "IntMap.Foldable.minimum: called with empty map"
+          start (Tip _ y) = y
+          start (Bin _ _ l r) = go (start l) r
+
+          go !m Nil = m
+          go m (Tip _ y) = min m y
+          go m (Bin _ _ l r) = go (go m l) r
+  {-# INLINABLE minimum #-}
+  sum = foldl' (+) 0
+  {-# INLINABLE sum #-}
+  product = foldl' (*) 1
+  {-# INLINABLE product #-}
+#endif
 
 instance Traversable IntMap where
-    traverse _ Nil = pure Nil
-    traverse f (Tip k v) = Tip k <$> f v
-    traverse f (Bin p m l r) = Bin p m <$> traverse f l <*> traverse f r
+    traverse f = traverseWithKey (\_ -> f)
+    {-# INLINE traverse #-}
 
 instance NFData a => NFData (IntMap a) where
     rnf Nil = ()
@@ -305,14 +402,22 @@ instance NFData a => NFData (IntMap a) where
 --------------------------------------------------------------------}
 
 -- This instance preserves data abstraction at the cost of inefficiency.
--- We omit reflection services for the sake of data abstraction.
+-- We provide limited reflection services for the sake of data abstraction.
 
 instance Data a => Data (IntMap a) where
   gfoldl f z im = z fromList `f` (toList im)
-  toConstr _    = error "toConstr"
-  gunfold _ _   = error "gunfold"
-  dataTypeOf _  = mkNoRepType "Data.IntMap.IntMap"
-  dataCast1 f   = gcast1 f
+  toConstr _     = fromListConstr
+  gunfold k z c  = case constrIndex c of
+    1 -> k (z fromList)
+    _ -> error "gunfold"
+  dataTypeOf _   = intMapDataType
+  dataCast1 f    = gcast1 f
+
+fromListConstr :: Constr
+fromListConstr = mkConstr intMapDataType "fromList" [] Prefix
+
+intMapDataType :: DataType
+intMapDataType = mkDataType "Data.IntMap.Base.IntMap" [fromListConstr]
 
 #endif
 
@@ -327,6 +432,7 @@ instance Data a => Data (IntMap a) where
 null :: IntMap a -> Bool
 null Nil = True
 null _   = False
+{-# INLINE null #-}
 
 -- | /O(n)/. Number of elements in the map.
 --
@@ -334,22 +440,24 @@ null _   = False
 -- > size (singleton 1 'a')                       == 1
 -- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3
 size :: IntMap a -> Int
-size t
-  = case t of
-      Bin _ _ l r -> size l + size r
-      Tip _ _ -> 1
-      Nil     -> 0
+size (Bin _ _ l r) = size l + size r
+size (Tip _ _) = 1
+size Nil = 0
 
 -- | /O(min(n,W))/. Is the key a member of the map?
 --
 -- > member 5 (fromList [(5,'a'), (3,'b')]) == True
 -- > member 1 (fromList [(5,'a'), (3,'b')]) == False
 
+-- See Note: Local 'go' functions and capturing]
 member :: Key -> IntMap a -> Bool
-member k m
-  = case lookup k m of
-      Nothing -> False
-      Just _  -> True
+member !k = go
+  where
+    go (Bin p m l r) | nomatch k p m = False
+                     | zero k m  = go l
+                     | otherwise = go r
+    go (Tip kx _) = k == kx
+    go Nil = False
 
 -- | /O(min(n,W))/. Is the key not a member of the map?
 --
@@ -359,28 +467,32 @@ member k m
 notMember :: Key -> IntMap a -> Bool
 notMember k m = not $ member k m
 
--- The 'go' function in the lookup causes 10% speedup, but also an increased
--- memory allocation. It does not cause speedup with other methods like insert
--- and delete, so it is present only in lookup.
-
 -- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'.
+
+-- See Note: Local 'go' functions and capturing]
 lookup :: Key -> IntMap a -> Maybe a
-lookup k = k `seq` go
+lookup !k = go
   where
-    go (Bin _ m l r)
-      | zero k m  = go l
-      | otherwise = go r
-    go (Tip kx x)
-      | k == kx   = Just x
-      | otherwise = Nothing
-    go Nil      = Nothing
+    go (Bin p m l r) | nomatch k p m = Nothing
+                     | zero k m  = go l
+                     | otherwise = go r
+    go (Tip kx x) | k == kx   = Just x
+                  | otherwise = Nothing
+    go Nil = Nothing
 
 
+-- See Note: Local 'go' functions and capturing]
 find :: Key -> IntMap a -> a
-find k m
-  = case lookup k m of
-      Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")
-      Just x  -> x
+find !k = go
+  where
+    go (Bin p m l r) | nomatch k p m = not_found
+                     | zero k m  = go l
+                     | otherwise = go r
+    go (Tip kx x) | k == kx   = x
+                  | otherwise = not_found
+    go Nil = not_found
+
+    not_found = error ("IntMap.!: key " ++ show k ++ " is not an element of the map")
 
 -- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@
 -- returns the value at key @k@ or returns @def@ when the key is not an
@@ -389,11 +501,109 @@ find k m
 -- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'
 -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'
 
+-- See Note: Local 'go' functions and capturing]
 findWithDefault :: a -> Key -> IntMap a -> a
-findWithDefault def k m
-  = case lookup k m of
-      Nothing -> def
-      Just x  -> x
+findWithDefault def !k = go
+  where
+    go (Bin p m l r) | nomatch k p m = def
+                     | zero k m  = go l
+                     | otherwise = go r
+    go (Tip kx x) | k == kx   = x
+                  | otherwise = def
+    go Nil = def
+
+-- | /O(log n)/. Find largest key smaller than the given one and return the
+-- corresponding (key, value) pair.
+--
+-- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing
+-- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
+
+-- See Note: Local 'go' functions and capturing.
+lookupLT :: Key -> IntMap a -> Maybe (Key, a)
+lookupLT !k t = case t of
+    Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r
+    _ -> go Nil t
+  where
+    go def (Bin p m l r) | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r
+                         | zero k m  = go def l
+                         | otherwise = go l r
+    go def (Tip ky y) | k <= ky   = unsafeFindMax def
+                      | otherwise = Just (ky, y)
+    go def Nil = unsafeFindMax def
+
+-- | /O(log n)/. Find smallest key greater than the given one and return the
+-- corresponding (key, value) pair.
+--
+-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
+-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing
+
+-- See Note: Local 'go' functions and capturing.
+lookupGT :: Key -> IntMap a -> Maybe (Key, a)
+lookupGT !k t = case t of
+    Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r
+    _ -> go Nil t
+  where
+    go def (Bin p m l r) | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def
+                         | zero k m  = go r l
+                         | otherwise = go def r
+    go def (Tip ky y) | k >= ky   = unsafeFindMin def
+                      | otherwise = Just (ky, y)
+    go def Nil = unsafeFindMin def
+
+-- | /O(log n)/. Find largest key smaller or equal to the given one and return
+-- the corresponding (key, value) pair.
+--
+-- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing
+-- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
+-- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
+
+-- See Note: Local 'go' functions and capturing.
+lookupLE :: Key -> IntMap a -> Maybe (Key, a)
+lookupLE !k t = case t of
+    Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r
+    _ -> go Nil t
+  where
+    go def (Bin p m l r) | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r
+                         | zero k m  = go def l
+                         | otherwise = go l r
+    go def (Tip ky y) | k < ky    = unsafeFindMax def
+                      | otherwise = Just (ky, y)
+    go def Nil = unsafeFindMax def
+
+-- | /O(log n)/. Find smallest key greater or equal to the given one and return
+-- the corresponding (key, value) pair.
+--
+-- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
+-- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
+-- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing
+
+-- See Note: Local 'go' functions and capturing.
+lookupGE :: Key -> IntMap a -> Maybe (Key, a)
+lookupGE !k t = case t of
+    Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r
+    _ -> go Nil t
+  where
+    go def (Bin p m l r) | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def
+                         | zero k m  = go r l
+                         | otherwise = go def r
+    go def (Tip ky y) | k > ky    = unsafeFindMin def
+                      | otherwise = Just (ky, y)
+    go def Nil = unsafeFindMin def
+
+
+-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is
+-- given, it has m > 0.
+unsafeFindMin :: IntMap a -> Maybe (Key, a)
+unsafeFindMin Nil = Nothing
+unsafeFindMin (Tip ky y) = Just (ky, y)
+unsafeFindMin (Bin _ _ l _) = unsafeFindMin l
+
+-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is
+-- given, it has m > 0.
+unsafeFindMax :: IntMap a -> Maybe (Key, a)
+unsafeFindMax Nil = Nothing
+unsafeFindMax (Tip ky y) = Just (ky, y)
+unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r
 
 {--------------------------------------------------------------------
   Construction
@@ -406,6 +616,7 @@ findWithDefault def k m
 empty :: IntMap a
 empty
   = Nil
+{-# INLINE empty #-}
 
 -- | /O(1)/. A map of one element.
 --
@@ -415,6 +626,7 @@ empty
 singleton :: Key -> a -> IntMap a
 singleton k x
   = Tip k x
+{-# INLINE singleton #-}
 
 {--------------------------------------------------------------------
   Insert
@@ -429,16 +641,14 @@ singleton k x
 -- > insert 5 'x' empty                         == singleton 5 'x'
 
 insert :: Key -> a -> IntMap a -> IntMap a
-insert k x t = k `seq`
-  case t of
-    Bin p m l r
-      | nomatch k p m -> join k (Tip k x) p t
-      | zero k m      -> Bin p m (insert k x l) r
-      | otherwise     -> Bin p m l (insert k x r)
-    Tip ky _
-      | k==ky         -> Tip k x
-      | otherwise     -> join k (Tip k x) ky t
-    Nil -> Tip k x
+insert !k x t@(Bin p m l r)
+  | nomatch k p m = link k (Tip k x) p t
+  | zero k m      = Bin p m (insert k x l) r
+  | otherwise     = Bin p m l (insert k x r)
+insert k x t@(Tip ky _)
+  | k==ky         = Tip k x
+  | otherwise     = link k (Tip k x) ky t
+insert k x Nil = Tip k x
 
 -- right-biased insertion, used by 'union'
 -- | /O(min(n,W))/. Insert with a combining function.
@@ -467,16 +677,14 @@ insertWith f k x t
 -- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"
 
 insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
-insertWithKey f k x t = k `seq`
-  case t of
-    Bin p m l r
-      | nomatch k p m -> join k (Tip k x) p t
-      | zero k m      -> Bin p m (insertWithKey f k x l) r
-      | otherwise     -> Bin p m l (insertWithKey f k x r)
-    Tip ky y
-      | k==ky         -> Tip k (f k x y)
-      | otherwise     -> join k (Tip k x) ky t
-    Nil -> Tip k x
+insertWithKey f !k x t@(Bin p m l r)
+  | nomatch k p m = link k (Tip k x) p t
+  | zero k m      = Bin p m (insertWithKey f k x l) r
+  | otherwise     = Bin p m l (insertWithKey f k x r)
+insertWithKey f k x t@(Tip ky y)
+  | k == ky       = Tip k (f k x y)
+  | otherwise     = link k (Tip k x) ky t
+insertWithKey _ k x Nil = Tip k x
 
 -- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)
 -- is a pair where the first element is equal to (@'lookup' k map@)
@@ -494,21 +702,18 @@ insertWithKey f k x t = k `seq`
 -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])
 
 insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)
-insertLookupWithKey f k x t = k `seq`
-  case t of
-    Bin p m l r
-      | nomatch k p m -> (Nothing,join k (Tip k x) p t)
-      | zero k m      -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)
-      | otherwise     -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')
-    Tip ky y
-      | k==ky         -> (Just y,Tip k (f k x y))
-      | otherwise     -> (Nothing,join k (Tip k x) ky t)
-    Nil -> (Nothing,Tip k x)
+insertLookupWithKey f !k x t@(Bin p m l r)
+  | nomatch k p m = (Nothing,link k (Tip k x) p t)
+  | zero k m      = let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)
+  | otherwise     = let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')
+insertLookupWithKey f k x t@(Tip ky y)
+  | k == ky       = (Just y,Tip k (f k x y))
+  | otherwise     = (Nothing,link k (Tip k x) ky t)
+insertLookupWithKey _ k x Nil = (Nothing,Tip k x)
 
 
 {--------------------------------------------------------------------
   Deletion
-  [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
 --------------------------------------------------------------------}
 -- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not
 -- a member of the map, the original map is returned.
@@ -518,16 +723,14 @@ insertLookupWithKey f k x t = k `seq`
 -- > delete 5 empty                         == empty
 
 delete :: Key -> IntMap a -> IntMap a
-delete k t = k `seq`
-  case t of
-    Bin p m l r
-      | nomatch k p m -> t
-      | zero k m      -> bin p m (delete k l) r
-      | otherwise     -> bin p m l (delete k r)
-    Tip ky _
-      | k==ky         -> Nil
-      | otherwise     -> t
-    Nil -> Nil
+delete !k t@(Bin p m l r)
+  | nomatch k p m = t
+  | zero k m      = binCheckLeft p m (delete k l) r
+  | otherwise     = binCheckRight p m l (delete k r)
+delete k t@(Tip ky _)
+  | k == ky       = Nil
+  | otherwise     = t
+delete _k Nil = Nil
 
 -- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not
 -- a member of the map, the original map is returned.
@@ -549,8 +752,15 @@ adjust f k m
 -- > adjustWithKey f 7 empty                         == empty
 
 adjustWithKey ::  (Key -> a -> a) -> Key -> IntMap a -> IntMap a
-adjustWithKey f
-  = updateWithKey (\k' x -> Just (f k' x))
+adjustWithKey f !k t@(Bin p m l r)
+  | nomatch k p m = t
+  | zero k m      = Bin p m (adjustWithKey f k l) r
+  | otherwise     = Bin p m l (adjustWithKey f k r)
+adjustWithKey f k t@(Tip ky y)
+  | k == ky       = Tip ky (f k y)
+  | otherwise     = t
+adjustWithKey _ _ Nil = Nil
+
 
 -- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@
 -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
@@ -575,18 +785,16 @@ update f
 -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
 
 updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a
-updateWithKey f k t = k `seq`
-  case t of
-    Bin p m l r
-      | nomatch k p m -> t
-      | zero k m      -> bin p m (updateWithKey f k l) r
-      | otherwise     -> bin p m l (updateWithKey f k r)
-    Tip ky y
-      | k==ky         -> case (f k y) of
+updateWithKey f !k t@(Bin p m l r)
+  | nomatch k p m = t
+  | zero k m      = binCheckLeft p m (updateWithKey f k l) r
+  | otherwise     = binCheckRight p m l (updateWithKey f k r)
+updateWithKey f k t@(Tip ky y)
+  | k == ky       = case (f k y) of
                            Just y' -> Tip ky y'
                            Nothing -> Nil
-      | otherwise     -> t
-    Nil -> Nil
+  | otherwise     = t
+updateWithKey _ _ Nil = Nil
 
 -- | /O(min(n,W))/. Lookup and update.
 -- The function returns original value, if it is updated.
@@ -599,18 +807,16 @@ updateWithKey f k t = k `seq`
 -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
 
 updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)
-updateLookupWithKey f k t = k `seq`
-  case t of
-    Bin p m l r
-      | nomatch k p m -> (Nothing,t)
-      | zero k m      -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)
-      | otherwise     -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')
-    Tip ky y
-      | k==ky         -> case (f k y) of
-                           Just y' -> (Just y,Tip ky y')
-                           Nothing -> (Just y,Nil)
-      | otherwise     -> (Nothing,t)
-    Nil -> (Nothing,Nil)
+updateLookupWithKey f !k t@(Bin p m l r)
+  | nomatch k p m = (Nothing,t)
+  | zero k m      = let !(found,l') = updateLookupWithKey f k l in (found,binCheckLeft p m l' r)
+  | otherwise     = let !(found,r') = updateLookupWithKey f k r in (found,binCheckRight p m l r')
+updateLookupWithKey f k t@(Tip ky y)
+  | k==ky         = case (f k y) of
+                      Just y' -> (Just y,Tip ky y')
+                      Nothing -> (Just y,Nil)
+  | otherwise     = (Nothing,t)
+updateLookupWithKey _ _ Nil = (Nothing,Nil)
 
 
 
@@ -618,25 +824,59 @@ updateLookupWithKey f k t = k `seq`
 -- 'alter' can be used to insert, delete, or update a value in an 'IntMap'.
 -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.
 alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a
-alter f k t = k `seq`
-  case t of
-    Bin p m l r
-      | nomatch k p m -> case f Nothing of
-                           Nothing -> t
-                           Just x -> join k (Tip k x) p t
-      | zero k m      -> bin p m (alter f k l) r
-      | otherwise     -> bin p m l (alter f k r)
-    Tip ky y
-      | k==ky         -> case f (Just y) of
-                           Just x -> Tip ky x
-                           Nothing -> Nil
-      | otherwise     -> case f Nothing of
-                           Just x -> join k (Tip k x) ky t
-                           Nothing -> Tip ky y
-    Nil               -> case f Nothing of
-                           Just x -> Tip k x
-                           Nothing -> Nil
-
+alter f !k t@(Bin p m l r)
+  | nomatch k p m = case f Nothing of
+                      Nothing -> t
+                      Just x -> link k (Tip k x) p t
+  | zero k m      = binCheckLeft p m (alter f k l) r
+  | otherwise     = binCheckRight p m l (alter f k r)
+alter f k t@(Tip ky y)
+  | k==ky         = case f (Just y) of
+                      Just x -> Tip ky x
+                      Nothing -> Nil
+  | otherwise     = case f Nothing of
+                      Just x -> link k (Tip k x) ky t
+                      Nothing -> Tip ky y
+alter f k Nil     = case f Nothing of
+                      Just x -> Tip k x
+                      Nothing -> Nil
+
+-- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at
+-- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,
+-- or update a value in an 'IntMap'.  In short : @'lookup' k <$> 'alterF' f k m = f
+-- ('lookup' k m)@.
+--
+-- Example:
+--
+-- @
+-- interactiveAlter :: Int -> IntMap String -> IO (IntMap String)
+-- interactiveAlter k m = alterF f k m where
+--   f Nothing -> do
+--      putStrLn $ show k ++
+--          " was not found in the map. Would you like to add it?"
+--      getUserResponse1 :: IO (Maybe String)
+--   f (Just old) -> do
+--      putStrLn "The key is currently bound to " ++ show old ++
+--          ". Would you like to change or delete it?"
+--      getUserresponse2 :: IO (Maybe String)
+-- @
+--
+-- 'alterF' is the most general operation for working with an individual
+-- key that may or may not be in a given map.
+--
+-- Note: 'alterF' is a flipped version of the 'at' combinator from
+-- 'Control.Lens.At'.
+--
+-- @since 0.5.8
+
+alterF :: Functor f
+       => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a)
+-- This implementation was stolen from 'Control.Lens.At'.
+alterF f k m = (<$> f mv) $ \fres ->
+  case fres of
+    Nothing -> maybe m (const (delete k m)) mv
+    Just v' -> insert k v' m
+  where mv = lookup k m
 
 {--------------------------------------------------------------------
   Union
@@ -668,24 +908,8 @@ unionsWith f ts
 -- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]
 
 union :: IntMap a -> IntMap a -> IntMap a
-union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
-  | shorter m1 m2  = union1
-  | shorter m2 m1  = union2
-  | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)
-  | otherwise      = join p1 t1 p2 t2
-  where
-    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2
-            | zero p2 m1        = Bin p1 m1 (union l1 t2) r1
-            | otherwise         = Bin p1 m1 l1 (union r1 t2)
-
-    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2
-            | zero p1 m2        = Bin p2 m2 (union t1 l2) r2
-            | otherwise         = Bin p2 m2 l2 (union t1 r2)
-
-union (Tip k x) t = insert k x t
-union t (Tip k x) = insertWith (\_ y -> y) k x t  -- right bias
-union Nil t       = t
-union t Nil       = t
+union m1 m2
+  = mergeWithKey' Bin const id id m1 m2
 
 -- | /O(n+m)/. The union with a combining function.
 --
@@ -701,24 +925,8 @@ unionWith f m1 m2
 -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
 
 unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
-unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
-  | shorter m1 m2  = union1
-  | shorter m2 m1  = union2
-  | p1 == p2       = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)
-  | otherwise      = join p1 t1 p2 t2
-  where
-    union1  | nomatch p2 p1 m1  = join p1 t1 p2 t2
-            | zero p2 m1        = Bin p1 m1 (unionWithKey f l1 t2) r1
-            | otherwise         = Bin p1 m1 l1 (unionWithKey f r1 t2)
-
-    union2  | nomatch p1 p2 m2  = join p1 t1 p2 t2
-            | zero p1 m2        = Bin p2 m2 (unionWithKey f t1 l2) r2
-            | otherwise         = Bin p2 m2 l2 (unionWithKey f t1 r2)
-
-unionWithKey f (Tip k x) t = insertWithKey f k x t
-unionWithKey f t (Tip k x) = insertWithKey (\k' x' y' -> f k' y' x') k x t  -- right bias
-unionWithKey _ Nil t  = t
-unionWithKey _ t Nil  = t
+unionWithKey f m1 m2
+  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) id id m1 m2
 
 {--------------------------------------------------------------------
   Difference
@@ -728,27 +936,8 @@ unionWithKey _ t Nil  = t
 -- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"
 
 difference :: IntMap a -> IntMap b -> IntMap a
-difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
-  | shorter m1 m2  = difference1
-  | shorter m2 m1  = difference2
-  | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)
-  | otherwise      = t1
-  where
-    difference1 | nomatch p2 p1 m1  = t1
-                | zero p2 m1        = bin p1 m1 (difference l1 t2) r1
-                | otherwise         = bin p1 m1 l1 (difference r1 t2)
-
-    difference2 | nomatch p1 p2 m2  = t1
-                | zero p1 m2        = difference t1 l2
-                | otherwise         = difference t1 r2
-
-difference t1@(Tip k _) t2
-  | member k t2  = Nil
-  | otherwise    = t1
-
-difference Nil _       = Nil
-difference t (Tip k _) = delete k t
-difference t Nil       = t
+difference m1 m2
+  = mergeWithKey (\_ _ _ -> Nothing) id (const Nil) m1 m2
 
 -- | /O(n+m)/. Difference with a combining function.
 --
@@ -770,30 +959,51 @@ differenceWith f m1 m2
 -- >     == singleton 3 "3:b|B"
 
 differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
-differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
-  | shorter m1 m2  = difference1
-  | shorter m2 m1  = difference2
-  | p1 == p2       = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)
-  | otherwise      = t1
-  where
-    difference1 | nomatch p2 p1 m1  = t1
-                | zero p2 m1        = bin p1 m1 (differenceWithKey f l1 t2) r1
-                | otherwise         = bin p1 m1 l1 (differenceWithKey f r1 t2)
-
-    difference2 | nomatch p1 p2 m2  = t1
-                | zero p1 m2        = differenceWithKey f t1 l2
-                | otherwise         = differenceWithKey f t1 r2
+differenceWithKey f m1 m2
+  = mergeWithKey f id (const Nil) m1 m2
 
-differenceWithKey f t1@(Tip k x) t2
-  = case lookup k t2 of
-      Just y  -> case f k x y of
-                   Just y' -> Tip k y'
-                   Nothing -> Nil
-      Nothing -> t1
-
-differenceWithKey _ Nil _       = Nil
-differenceWithKey f t (Tip k y) = updateWithKey (\k' x -> f k' x y) k t
-differenceWithKey _ t Nil       = t
+-- | Remove all the keys in a given set from a map.
+--
+-- @
+-- m `withoutKeys` s = 'filterWithKey' (\k _ -> k `'IntSet.notMember'` s) m
+-- @
+--
+-- @since 0.5.8
+withoutKeys :: IntMap a -> IntSet.IntSet -> IntMap a
+withoutKeys = go
+  where
+    go t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2)
+      | shorter m1 m2  = merge1
+      | shorter m2 m1  = merge2
+      | p1 == p2       = bin p1 m1 (go l1 l2) (go r1 r2)
+      | otherwise      = t1
+      where
+        merge1 | nomatch p2 p1 m1  = t1
+               | zero p2 m1        = binCheckLeft p1 m1 (go l1 t2) r1
+               | otherwise         = binCheckRight p1 m1 l1 (go r1 t2)
+        merge2 | nomatch p1 p2 m2  = t1
+               | 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' _) = merge t2' k2' t1'
+      where merge t2 k2 t1@(Bin p1 m1 l1 r1) | nomatch k2 p1 m1 = t1
+                                             | zero k2 m1 = binCheckLeft p1 m1 (merge t2 k2 l1) r1
+                                             | otherwise  = binCheckRight p1 m1 l1 (merge t2 k2 r1)
+            merge _ k2 t1@(Tip k1 _) | k1 == k2 = Nil
+                                     | otherwise = t1
+            merge _ _  Nil = Nil
+
+    go t1@(Bin _ _ _ _) IntSet.Nil = t1
+
+    go t1'@(Tip k1' _) t2' = merge t1' k1' t2'
+      where merge t1 k1 (IntSet.Bin p2 m2 l2 r2) | nomatch k1 p2 m2 = t1
+                                                 | zero k1 m2 = bin p2 m2 (merge t1 k1 l2) Nil
+                                                 | otherwise  = bin p2 m2 Nil (merge t1 k1 r2)
+            merge t1 k1 (IntSet.Tip k2 _) | k1 == k2 = Nil
+                                          | otherwise = t1
+            merge t1 _  IntSet.Nil = t1
+
+    go Nil _ = Nil
 
 
 {--------------------------------------------------------------------
@@ -804,29 +1014,52 @@ differenceWithKey _ t Nil       = t
 -- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"
 
 intersection :: IntMap a -> IntMap b -> IntMap a
-intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
-  | shorter m1 m2  = intersection1
-  | shorter m2 m1  = intersection2
-  | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)
-  | otherwise      = Nil
+intersection m1 m2
+  = mergeWithKey' bin const (const Nil) (const Nil) m1 m2
+
+-- | /O(n+m)/. The restriction of a map to the keys in a set.
+--
+-- @
+-- m `restrictKeys` s = 'filterWithKey' (\k _ -> k `'IntSet.member'` s) m
+-- @
+--
+-- @since 0.5.8
+restrictKeys :: IntMap a -> IntSet.IntSet -> IntMap a
+restrictKeys = go
   where
-    intersection1 | nomatch p2 p1 m1  = Nil
-                  | zero p2 m1        = intersection l1 t2
-                  | otherwise         = intersection r1 t2
-
-    intersection2 | nomatch p1 p2 m2  = Nil
-                  | zero p1 m2        = intersection t1 l2
-                  | otherwise         = intersection t1 r2
-
-intersection t1@(Tip k _) t2
-  | member k t2  = t1
-  | otherwise    = Nil
-intersection t (Tip k _)
-  = case lookup k t of
-      Just y  -> Tip k y
-      Nothing -> Nil
-intersection Nil _ = Nil
-intersection _ Nil = Nil
+    go t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2)
+      | shorter m1 m2  = merge1
+      | shorter m2 m1  = merge2
+      | p1 == p2       = bin p1 m1 (go l1 l2) (go r1 r2)
+      | otherwise      = Nil
+      where
+        merge1 | nomatch p2 p1 m1  = Nil
+               | zero p2 m1        = bin p1 m1 (go l1 t2) Nil
+               | otherwise         = bin p1 m1 Nil (go r1 t2)
+        merge2 | nomatch p1 p2 m2  = Nil
+               | 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' _) = merge t2' k2' t1'
+      where merge t2 k2 (Bin p1 m1 l1 r1) | nomatch k2 p1 m1 = Nil
+                                          | zero k2 m1 = bin p1 m1 (merge t2 k2 l1) Nil
+                                          | otherwise  = bin p1 m1 Nil (merge t2 k2 r1)
+            merge _ k2 t1@(Tip k1 _) | k1 == k2 = t1
+                                     | otherwise = Nil
+            merge _ _  Nil = Nil
+
+    go (Bin _ _ _ _) IntSet.Nil = Nil
+
+    go t1'@(Tip k1' _) t2' = merge t1' k1' t2'
+      where merge t1 k1 (IntSet.Bin p2 m2 l2 r2)
+              | nomatch k1 p2 m2 = Nil
+              | zero k1 m2 = bin p2 m2 (merge t1 k1 l2) Nil
+              | otherwise  = bin p2 m2 Nil (merge t1 k1 r2)
+            merge t1 k1 (IntSet.Tip k2 _) | k1 == k2 = t1
+                                          | otherwise = Nil
+            merge _ _  IntSet.Nil = Nil
+
+    go Nil _ = Nil
 
 -- | /O(n+m)/. The intersection with a combining function.
 --
@@ -842,31 +1075,109 @@ intersectionWith f m1 m2
 -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"
 
 intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c
-intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
-  | shorter m1 m2  = intersection1
-  | shorter m2 m1  = intersection2
-  | p1 == p2       = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)
-  | otherwise      = Nil
-  where
-    intersection1 | nomatch p2 p1 m1  = Nil
-                  | zero p2 m1        = intersectionWithKey f l1 t2
-                  | otherwise         = intersectionWithKey f r1 t2
-
-    intersection2 | nomatch p1 p2 m2  = Nil
-                  | zero p1 m2        = intersectionWithKey f t1 l2
-                  | otherwise         = intersectionWithKey f t1 r2
-
-intersectionWithKey f (Tip k x) t2
-  = case lookup k t2 of
-      Just y  -> Tip k (f k x y)
-      Nothing -> Nil
-intersectionWithKey f t1 (Tip k y)
-  = case lookup k t1 of
-      Just x  -> Tip k (f k x y)
-      Nothing -> Nil
-intersectionWithKey _ Nil _ = Nil
-intersectionWithKey _ _ Nil = Nil
+intersectionWithKey f m1 m2
+  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) (const Nil) (const Nil) m1 m2
+
+{--------------------------------------------------------------------
+  MergeWithKey
+--------------------------------------------------------------------}
+
+-- | /O(n+m)/. A high-performance universal combining function. Using
+-- 'mergeWithKey', all combining functions can be defined without any loss of
+-- efficiency (with exception of 'union', 'difference' and 'intersection',
+-- where sharing of some nodes is lost with 'mergeWithKey').
+--
+-- Please make sure you know what is going on when using 'mergeWithKey',
+-- otherwise you can be surprised by unexpected code growth or even
+-- corruption of the data structure.
+--
+-- When 'mergeWithKey' is given three arguments, it is inlined to the call
+-- site. You should therefore use 'mergeWithKey' only to define your custom
+-- combining functions. For example, you could define 'unionWithKey',
+-- 'differenceWithKey' and 'intersectionWithKey' as
+--
+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2
+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2
+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2
+--
+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two
+-- 'IntMap's is created, such that
+--
+-- * if a key is present in both maps, it is passed with both corresponding
+--   values to the @combine@ function. Depending on the result, the key is either
+--   present in the result with specified value, or is left out;
+--
+-- * a nonempty subtree present only in the first map is passed to @only1@ and
+--   the output is added to the result;
+--
+-- * a nonempty subtree present only in the second map is passed to @only2@ and
+--   the output is added to the result.
+--
+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.
+-- The values can be modified arbitrarily. Most common variants of @only1@ and
+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or
+-- @'filterWithKey' f@ could be used for any @f@.
+
+mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)
+             -> IntMap a -> IntMap b -> IntMap c
+mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2
+  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.
+        combine = \(Tip k1 x1) (Tip _k2 x2) -> case f k1 x1 x2 of Nothing -> Nil
+                                                                  Just x -> Tip k1 x
+        {-# INLINE combine #-}
+{-# INLINE mergeWithKey #-}
 
+-- Slightly more general version of mergeWithKey. It differs in the following:
+--
+-- * the combining function operates on maps instead of keys and values. The
+--   reason is to enable sharing in union, difference and intersection.
+--
+-- * mergeWithKey' is given an equivalent of bin. The reason is that in union*,
+--   Bin constructor can be used, because we know both subtrees are nonempty.
+
+mergeWithKey' :: (Prefix -> Mask -> IntMap c -> IntMap c -> IntMap c)
+              -> (IntMap a -> IntMap b -> IntMap c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)
+              -> IntMap a -> IntMap b -> IntMap c
+mergeWithKey' bin' f g1 g2 = go
+  where
+    go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
+      | shorter m1 m2  = merge1
+      | shorter m2 m1  = merge2
+      | p1 == p2       = bin' p1 m1 (go l1 l2) (go r1 r2)
+      | otherwise      = maybe_link p1 (g1 t1) p2 (g2 t2)
+      where
+        merge1 | nomatch p2 p1 m1  = maybe_link p1 (g1 t1) p2 (g2 t2)
+               | zero p2 m1        = bin' p1 m1 (go l1 t2) (g1 r1)
+               | otherwise         = bin' p1 m1 (g1 l1) (go r1 t2)
+        merge2 | nomatch p1 p2 m2  = maybe_link p1 (g1 t1) p2 (g2 t2)
+               | zero p1 m2        = bin' p2 m2 (go t1 l2) (g2 r2)
+               | otherwise         = bin' p2 m2 (g2 l2) (go t1 r2)
+
+    go t1'@(Bin _ _ _ _) t2'@(Tip k2' _) = merge t2' k2' t1'
+      where merge t2 k2 t1@(Bin p1 m1 l1 r1) | nomatch k2 p1 m1 = maybe_link p1 (g1 t1) k2 (g2 t2)
+                                             | zero k2 m1 = bin' p1 m1 (merge t2 k2 l1) (g1 r1)
+                                             | otherwise  = bin' p1 m1 (g1 l1) (merge t2 k2 r1)
+            merge t2 k2 t1@(Tip k1 _) | k1 == k2 = f t1 t2
+                                      | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)
+            merge t2 _  Nil = g2 t2
+
+    go t1@(Bin _ _ _ _) Nil = g1 t1
+
+    go t1'@(Tip k1' _) t2' = merge t1' k1' t2'
+      where merge t1 k1 t2@(Bin p2 m2 l2 r2) | nomatch k1 p2 m2 = maybe_link k1 (g1 t1) p2 (g2 t2)
+                                             | zero k1 m2 = bin' p2 m2 (merge t1 k1 l2) (g2 r2)
+                                             | otherwise  = bin' p2 m2 (g2 l2) (merge t1 k1 r2)
+            merge t1 k1 t2@(Tip k2 _) | k1 == k2 = f t1 t2
+                                      | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)
+            merge t1 _  Nil = g1 t1
+
+    go Nil t2 = g2 t2
+
+    maybe_link _ Nil _ t2 = t2
+    maybe_link _ t1 _ Nil = t1
+    maybe_link p1 t1 p2 t2 = link p1 t1 p2 t2
+    {-# INLINE maybe_link #-}
+{-# INLINE mergeWithKey' #-}
 
 {--------------------------------------------------------------------
   Min\/Max
@@ -879,10 +1190,10 @@ intersectionWithKey _ _ Nil = Nil
 
 updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a
 updateMinWithKey f t =
-  case t of Bin p m l r | m < 0 -> bin p m l (go f r)
+  case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)
             _ -> go f t
   where
-    go f' (Bin p m l r) = bin p m (go f' l) r
+    go f' (Bin p m l r) = binCheckLeft p m (go f' l) r
     go f' (Tip k y) = case f' k y of
                         Just y' -> Tip k y'
                         Nothing -> Nil
@@ -895,10 +1206,10 @@ updateMinWithKey f t =
 
 updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a
 updateMaxWithKey f t =
-  case t of Bin p m l r | m < 0 -> bin p m (go f l) r
+  case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r
             _ -> go f t
   where
-    go f' (Bin p m l r) = bin p m l (go f' r)
+    go f' (Bin p m l r) = binCheckRight p m l (go f' r)
     go f' (Tip k y) = case f' k y of
                         Just y' -> Tip k y'
                         Nothing -> Nil
@@ -913,10 +1224,10 @@ updateMaxWithKey f t =
 maxViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)
 maxViewWithKey t =
   case t of Nil -> Nothing
-            Bin p m l r | m < 0 -> case go l of (result, l') -> Just (result, bin p m l' r)
+            Bin p m l r | m < 0 -> case go l of (result, l') -> Just (result, binCheckLeft p m l' r)
             _ -> Just (go t)
   where
-    go (Bin p m l r) = case go r of (result, r') -> (result, bin p m l r')
+    go (Bin p m l r) = case go r of (result, r') -> (result, binCheckRight p m l r')
     go (Tip k y) = ((k, y), Nil)
     go Nil = error "maxViewWithKey Nil"
 
@@ -929,10 +1240,10 @@ maxViewWithKey t =
 minViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)
 minViewWithKey t =
   case t of Nil -> Nothing
-            Bin p m l r | m < 0 -> case go r of (result, r') -> Just (result, bin p m l r')
+            Bin p m l r | m < 0 -> case go r of (result, r') -> Just (result, binCheckRight p m l r')
             _ -> Just (go t)
   where
-    go (Bin p m l r) = case go l of (result, l') -> (result, bin p m l' r)
+    go (Bin p m l r) = case go l of (result, l') -> (result, binCheckLeft p m l' r)
     go (Tip k y) = ((k, y), Nil)
     go Nil = error "minViewWithKey Nil"
 
@@ -996,13 +1307,17 @@ findMax (Bin _ m l r)
           go (Bin _ _ _ r') = go r'
           go Nil            = error "findMax Nil"
 
--- | /O(min(n,W))/. Delete the minimal key. An error is thrown if the IntMap is already empty.
--- Note, this is not the same behavior Map.
+-- | /O(min(n,W))/. Delete the minimal key. Returns an empty map if the map is empty.
+--
+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#8211;
+-- versions prior to 0.5 threw an error if the 'IntMap' was already empty.
 deleteMin :: IntMap a -> IntMap a
 deleteMin = maybe Nil snd . minView
 
--- | /O(min(n,W))/. Delete the maximal key. An error is thrown if the IntMap is already empty.
--- Note, this is not the same behavior Map.
+-- | /O(min(n,W))/. Delete the maximal key. Returns an empty map if the map is empty.
+--
+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#8211;
+-- versions prior to 0.5 threw an error if the 'IntMap' was already empty.
 deleteMax :: IntMap a -> IntMap a
 deleteMax = maybe Nil snd . maxView
 
@@ -1107,7 +1422,24 @@ isSubmapOfBy _         Nil _           = True
 -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
 
 map :: (a -> b) -> IntMap a -> IntMap b
-map f = mapWithKey (\_ x -> f x)
+map f = go
+  where
+    go (Bin p m l r) = Bin p m (go l) (go r)
+    go (Tip k x)     = Tip k (f x)
+    go Nil           = Nil
+
+#ifdef __GLASGOW_HASKELL__
+{-# NOINLINE [1] map #-}
+{-# RULES
+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs
+ #-}
+#endif
+#if __GLASGOW_HASKELL__ >= 709
+-- Safe coercions were introduced in 7.8, but did not play well with RULES yet.
+{-# RULES
+"map/coerce" map coerce = coerce
+ #-}
+#endif
 
 -- | /O(n)/. Map a function over all values in the map.
 --
@@ -1121,6 +1453,33 @@ mapWithKey f t
       Tip k x     -> Tip k (f k x)
       Nil         -> Nil
 
+#ifdef __GLASGOW_HASKELL__
+{-# NOINLINE [1] mapWithKey #-}
+{-# RULES
+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =
+  mapWithKey (\k a -> f k (g k a)) xs
+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =
+  mapWithKey (\k a -> f k (g a)) xs
+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =
+  mapWithKey (\k a -> f (g k a)) xs
+ #-}
+#endif
+
+-- | /O(n)/.
+-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@
+-- That is, behaves exactly like a regular 'traverse' except that the traversing
+-- function also has access to the key associated with a value.
+--
+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])
+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing
+traverseWithKey :: Applicative t => (Key -> a -> t b) -> IntMap a -> t (IntMap b)
+traverseWithKey f = go
+  where
+    go Nil = pure Nil
+    go (Tip k v) = Tip k <$> f k v
+    go (Bin p m l r) = Bin p m <$> go l <*> go r
+{-# INLINE traverseWithKey #-}
+
 -- | /O(n)/. The function @'mapAccum'@ threads an accumulating
 -- argument through the map in ascending order of keys.
 --
@@ -1256,16 +1615,18 @@ partition p m
 -- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
 
 partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)
-partitionWithKey predicate t
-  = case t of
-      Bin p m l r
-        -> let (l1,l2) = partitionWithKey predicate l
-               (r1,r2) = partitionWithKey predicate r
-           in (bin p m l1 r1, bin p m l2 r2)
-      Tip k x
-        | predicate k x -> (t,Nil)
-        | otherwise     -> (Nil,t)
-      Nil -> (Nil,Nil)
+partitionWithKey predicate0 t0 = toPair $ go predicate0 t0
+  where
+    go predicate t
+      = case t of
+          Bin p m l r
+            -> let (l1 :*: l2) = go predicate l
+                   (r1 :*: r2) = go predicate r
+               in bin p m l1 r1 :*: bin p m l2 r2
+          Tip k x
+            | predicate k x -> (t :*: Nil)
+            | otherwise     -> (Nil :*: t)
+          Nil -> (Nil :*: Nil)
 
 -- | /O(n)/. Map values and collect the 'Just' results.
 --
@@ -1311,15 +1672,17 @@ mapEither f m
 -- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
 
 mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)
-mapEitherWithKey f (Bin p m l r)
-  = (bin p m l1 r1, bin p m l2 r2)
+mapEitherWithKey f0 t0 = toPair $ go f0 t0
   where
-    (l1,l2) = mapEitherWithKey f l
-    (r1,r2) = mapEitherWithKey f r
-mapEitherWithKey f (Tip k x) = case f k x of
-  Left y  -> (Tip k y, Nil)
-  Right z -> (Nil, Tip k z)
-mapEitherWithKey _ Nil = (Nil, Nil)
+    go f (Bin p m l r)
+      = bin p m l1 r1 :*: bin p m l2 r2
+      where
+        (l1 :*: l2) = go f l
+        (r1 :*: r2) = go f r
+    go f (Tip k x) = case f k x of
+      Left y  -> (Tip k y :*: Nil)
+      Right z -> (Nil :*: Tip k z)
+    go _ Nil = (Nil :*: Nil)
 
 -- | /O(min(n,W))/. The expression (@'split' k map@) is a pair @(map1,map2)@
 -- where all keys in @map1@ are lower than @k@ and all keys in
@@ -1333,18 +1696,23 @@ mapEitherWithKey _ Nil = (Nil, Nil)
 
 split :: Key -> IntMap a -> (IntMap a, IntMap a)
 split k t =
-  case t of Bin _ m l r | m < 0 -> if k >= 0 -- handle negative numbers.
-                                      then case go k l of (lt, gt) -> (union r lt, gt)
-                                      else case go k r of (lt, gt) -> (lt, union gt l)
-            _ -> go k t
+  case t of
+      Bin _ m l r
+          | m < 0 -> if k >= 0 -- handle negative numbers.
+                     then case go k l of (lt :*: gt) -> let !lt' = union r lt 
+                                                        in (lt', gt)
+                     else case go k r of (lt :*: gt) -> let !gt' = union gt l
+                                                        in (lt, gt')
+      _ -> case go k t of
+          (lt :*: gt) -> (lt, gt)
   where
-    go k' t'@(Bin p m l r) | nomatch k' p m = if k' > p then (t', Nil) else (Nil, t')
-                           | zero k' m = case go k' l of (lt, gt) -> (lt, union gt r)
-                           | otherwise = case go k' r of (lt, gt) -> (union l lt, gt)
-    go k' t'@(Tip ky _) | k' > ky   = (t', Nil)
-                        | k' < ky   = (Nil, t')
-                        | otherwise = (Nil, Nil)
-    go _ Nil = (Nil, Nil)
+    go k' t'@(Bin p m l r) | nomatch k' p m = if k' > p then t' :*: Nil else Nil :*: t'
+                           | zero k' m = case go k' l of (lt :*: gt) -> lt :*: union gt r
+                           | otherwise = case go k' r of (lt :*: gt) -> union l lt :*: gt
+    go k' t'@(Tip ky _) | k' > ky   = (t' :*: Nil)
+                        | k' < ky   = (Nil :*: t')
+                        | otherwise = (Nil :*: Nil)
+    go _ Nil = (Nil :*: Nil)
 
 -- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot
 -- key was found in the original map.
@@ -1357,14 +1725,23 @@ split k t =
 
 splitLookup :: Key -> IntMap a -> (IntMap a, Maybe a, IntMap a)
 splitLookup k t =
-  case t of Bin _ m l r | m < 0 -> if k >= 0 -- handle negative numbers.
-                                      then case go k l of (lt, fnd, gt) -> (union r lt, fnd, gt)
-                                      else case go k r of (lt, fnd, gt) -> (lt, fnd, union gt l)
-            _ -> go k t
+  case t of
+      Bin _ m l r
+          | m < 0 -> if k >= 0 -- handle negative numbers.
+                     then case go k l of
+                         (lt, fnd, gt) -> let !lt' = union r lt
+                                          in (lt', fnd, gt)
+                     else case go k r of
+                         (lt, fnd, gt) -> let !gt' = union gt l
+                                          in (lt, fnd, gt')
+      _ -> go k t
   where
-    go k' t'@(Bin p m l r) | nomatch k' p m = if k' > p then (t', Nothing, Nil) else (Nil, Nothing, t')
-                           | zero k' m = case go k' l of (lt, fnd, gt) -> (lt, fnd, union gt r)
-                           | otherwise = case go k' r of (lt, fnd, gt) -> (union l lt, fnd, gt)
+    go k' t'@(Bin p m l r)
+        | nomatch k' p m = if k' > p then (t', Nothing, Nil) else (Nil, Nothing, t')
+        | zero k' m      = case go k' l of
+            (lt, fnd, gt) -> let !gt' = union gt r in (lt, fnd, gt')
+        | otherwise      = case go k' r of
+            (lt, fnd, gt) -> let !lt' = union l lt in (lt', fnd, gt)
     go k' t'@(Tip ky y) | k' > ky   = (t', Nothing, Nil)
                         | k' < ky   = (Nil, Nothing, t')
                         | otherwise = (Nil, Just y, Nil)
@@ -1383,9 +1760,10 @@ splitLookup k t =
 -- > let f a len = len + (length a)
 -- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4
 foldr :: (a -> b -> b) -> b -> IntMap a -> b
-foldr f z t =
+foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
   case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before
-            _                   -> go z t
+                        | otherwise -> go (go z r) l
+            _ -> go z t
   where
     go z' Nil           = z'
     go z' (Tip _ x)     = f x z'
@@ -1396,12 +1774,12 @@ foldr f z t =
 -- evaluated before using the result in the next application. This
 -- function is strict in the starting value.
 foldr' :: (a -> b -> b) -> b -> IntMap a -> b
-foldr' f z t =
+foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
   case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before
-            _                   -> go z t
+                        | otherwise -> go (go z r) l
+            _ -> go z t
   where
-    STRICT_1_OF_2(go)
-    go z' Nil           = z'
+    go !z' Nil          = z'
     go z' (Tip _ x)     = f x z'
     go z' (Bin _ _ l r) = go (go z' r) l
 {-# INLINE foldr' #-}
@@ -1416,9 +1794,10 @@ foldr' f z t =
 -- > let f len a = len + (length a)
 -- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4
 foldl :: (a -> b -> a) -> a -> IntMap b -> a
-foldl f z t =
+foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
   case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before
-            _                   -> go z t
+                        | otherwise -> go (go z l) r
+            _ -> go z t
   where
     go z' Nil           = z'
     go z' (Tip _ x)     = f z' x
@@ -1429,12 +1808,12 @@ foldl f z t =
 -- evaluated before using the result in the next application. This
 -- function is strict in the starting value.
 foldl' :: (a -> b -> a) -> a -> IntMap b -> a
-foldl' f z t =
+foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
   case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before
-            _                   -> go z t
+                        | otherwise -> go (go z l) r
+            _ -> go z t
   where
-    STRICT_1_OF_2(go)
-    go z' Nil           = z'
+    go !z' Nil          = z'
     go z' (Tip _ x)     = f z' x
     go z' (Bin _ _ l r) = go (go z' l) r
 {-# INLINE foldl' #-}
@@ -1449,10 +1828,11 @@ foldl' f z t =
 --
 -- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
 -- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"
-foldrWithKey :: (Int -> a -> b -> b) -> b -> IntMap a -> b
-foldrWithKey f z t =
+foldrWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
+foldrWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
   case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before
-            _                   -> go z t
+                        | otherwise -> go (go z r) l
+            _ -> go z t
   where
     go z' Nil           = z'
     go z' (Tip kx x)    = f kx x z'
@@ -1462,13 +1842,13 @@ foldrWithKey f z t =
 -- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is
 -- evaluated before using the result in the next application. This
 -- function is strict in the starting value.
-foldrWithKey' :: (Int -> a -> b -> b) -> b -> IntMap a -> b
-foldrWithKey' f z t =
+foldrWithKey' :: (Key -> a -> b -> b) -> b -> IntMap a -> b
+foldrWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
   case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before
-            _                   -> go z t
+                        | otherwise -> go (go z r) l
+            _ -> go z t
   where
-    STRICT_1_OF_2(go)
-    go z' Nil           = z'
+    go !z' Nil          = z'
     go z' (Tip kx x)    = f kx x z'
     go z' (Bin _ _ l r) = go (go z' r) l
 {-# INLINE foldrWithKey' #-}
@@ -1483,10 +1863,11 @@ foldrWithKey' f z t =
 --
 -- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
 -- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"
-foldlWithKey :: (a -> Int -> b -> a) -> a -> IntMap b -> a
-foldlWithKey f z t =
+foldlWithKey :: (a -> Key -> b -> a) -> a -> IntMap b -> a
+foldlWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
   case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before
-            _                   -> go z t
+                        | otherwise -> go (go z l) r
+            _ -> go z t
   where
     go z' Nil           = z'
     go z' (Tip kx x)    = f z' kx x
@@ -1496,17 +1877,30 @@ foldlWithKey f z t =
 -- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is
 -- evaluated before using the result in the next application. This
 -- function is strict in the starting value.
-foldlWithKey' :: (a -> Int -> b -> a) -> a -> IntMap b -> a
-foldlWithKey' f z t =
+foldlWithKey' :: (a -> Key -> b -> a) -> a -> IntMap b -> a
+foldlWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
   case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before
-            _                   -> go z t
+                        | otherwise -> go (go z l) r
+            _ -> go z t
   where
-    STRICT_1_OF_2(go)
-    go z' Nil           = z'
+    go !z' Nil          = z'
     go z' (Tip kx x)    = f z' kx x
     go z' (Bin _ _ l r) = go (go z' l) r
 {-# INLINE foldlWithKey' #-}
 
+-- | /O(n)/. Fold the keys and values in the map using the given monoid, such that
+--
+-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@
+--
+-- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.
+foldMapWithKey :: Monoid m => (Key -> a -> m) -> IntMap a -> m
+foldMapWithKey f = go
+  where
+    go Nil           = mempty
+    go (Tip kx x)    = f kx x
+    go (Bin _ _ l r) = go l `mappend` go r
+{-# INLINE foldMapWithKey #-}
+
 {--------------------------------------------------------------------
   List variations
 --------------------------------------------------------------------}
@@ -1529,15 +1923,6 @@ elems = foldr (:) []
 keys  :: IntMap a -> [Key]
 keys = foldrWithKey (\k _ ks -> k : ks) []
 
--- | /O(n*min(n,W))/. The set of all keys of the map.
---
--- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5]
--- > keysSet empty == Data.IntSet.empty
-
-keysSet :: IntMap a -> IntSet.IntSet
-keysSet m = IntSet.fromDistinctAscList (keys m)
-
-
 -- | /O(n)/. An alias for 'toAscList'. Returns all key\/value pairs in the
 -- map in ascending key order. Subject to list fusion.
 --
@@ -1547,10 +1932,58 @@ keysSet m = IntSet.fromDistinctAscList (keys m)
 assocs :: IntMap a -> [(Key,a)]
 assocs = toAscList
 
+-- | /O(n*min(n,W))/. The set of all keys of the map.
+--
+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5]
+-- > keysSet empty == Data.IntSet.empty
+
+keysSet :: IntMap a -> IntSet.IntSet
+keysSet Nil = IntSet.Nil
+keysSet (Tip kx _) = IntSet.singleton kx
+keysSet (Bin p m l r)
+  | m .&. IntSet.suffixBitMask == 0 = IntSet.Bin p m (keysSet l) (keysSet r)
+  | otherwise = IntSet.Tip (p .&. IntSet.prefixBitMask) (computeBm (computeBm 0 l) r)
+  where computeBm !acc (Bin _ _ l' r') = computeBm (computeBm acc l') r'
+        computeBm acc (Tip kx _) = acc .|. IntSet.bitmapOf kx
+        computeBm _   Nil = error "Data.IntSet.keysSet: Nil"
+
+-- | /O(n)/. Build a map from a set of keys and a function which for each key
+-- computes its value.
+--
+-- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]
+-- > fromSet undefined Data.IntSet.empty == empty
+
+fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a
+fromSet _ IntSet.Nil = Nil
+fromSet f (IntSet.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)
+fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1)
+  where -- This is slightly complicated, as we to convert the dense
+        -- representation of IntSet into tree representation of IntMap.
+        --
+        -- We are given a nonzero bit mask 'bmask' of 'bits' bits with prefix 'prefix'.
+        -- We split bmask into halves corresponding to left and right subtree.
+        -- If they are both nonempty, we create a Bin node, otherwise exactly
+        -- one of them is nonempty and we construct the IntMap from that half.
+        buildTree g !prefix !bmask bits = case bits of
+          0 -> Tip prefix (g prefix)
+          _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of
+                 bits2 | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 ->
+                           buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2
+                       | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 ->
+                           buildTree g prefix bmask bits2
+                       | otherwise ->
+                           Bin prefix bits2 (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2)
 
 {--------------------------------------------------------------------
   Lists
 --------------------------------------------------------------------}
+#if __GLASGOW_HASKELL__ >= 708
+instance GHCExts.IsList (IntMap a) where
+  type Item (IntMap a) = (Key,a)
+  fromList = fromList
+  toList   = toList
+#endif
+
 -- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list
 -- fusion.
 --
@@ -1576,14 +2009,39 @@ toAscList = foldrWithKey (\k x xs -> (k,x):xs) []
 toDescList :: IntMap a -> [(Key,a)]
 toDescList = foldlWithKey (\xs k x -> (k,x):xs) []
 
+-- List fusion for the list generating functions.
 #if __GLASGOW_HASKELL__
--- List fusion for the list generating functions
-{-# RULES "IntMap/elems" forall im . elems im = build (\c n -> foldr c n im) #-}
-{-# RULES "IntMap/keys" forall im . keys im = build (\c n -> foldrWithKey (\k _ ks -> c k ks) n im) #-}
-{-# RULES "IntMap/assocs" forall im . assocs im = build (\c n -> foldrWithKey (\k x xs -> c (k,x) xs) n im) #-}
-{-# RULES "IntMap/toList" forall im . toList im = build (\c n -> foldrWithKey (\k x xs -> c (k,x) xs) n im) #-}
-{-# RULES "IntMap/toAscList" forall im . toAscList im = build (\c n -> foldrWithKey (\k x xs -> c (k,x) xs) n im) #-}
-{-# RULES "IntMap/toDescList" forall im . toDescList im = build (\c n -> foldlWithKey (\xs k x -> c (k,x) xs) n im) #-}
+-- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.
+-- They are important to convert unfused methods back, see mapFB in prelude.
+foldrFB :: (Key -> a -> b -> b) -> b -> IntMap a -> b
+foldrFB = foldrWithKey
+{-# INLINE[0] foldrFB #-}
+foldlFB :: (a -> Key -> b -> a) -> a -> IntMap b -> a
+foldlFB = foldlWithKey
+{-# INLINE[0] foldlFB #-}
+
+-- Inline assocs and toList, so that we need to fuse only toAscList.
+{-# INLINE assocs #-}
+{-# INLINE toList #-}
+
+-- The fusion is enabled up to phase 2 included. If it does not succeed,
+-- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to
+-- elems,keys,to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were
+-- used in a list fusion, otherwise it would go away in phase 1), and let compiler
+-- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to
+-- inline it before phase 0, otherwise the fusion rules would not fire at all.
+{-# NOINLINE[0] elems #-}
+{-# NOINLINE[0] keys #-}
+{-# NOINLINE[0] toAscList #-}
+{-# NOINLINE[0] toDescList #-}
+{-# RULES "IntMap.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}
+{-# RULES "IntMap.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}
+{-# RULES "IntMap.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}
+{-# RULES "IntMap.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}
+{-# RULES "IntMap.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}
+{-# RULES "IntMap.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}
+{-# RULES "IntMap.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}
+{-# RULES "IntMap.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}
 #endif
 
 
@@ -1663,14 +2121,20 @@ fromAscListWithKey f (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0)
 --
 -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
 
-fromDistinctAscList :: [(Key,a)] -> IntMap a
+#if __GLASGOW_HASKELL__
+fromDistinctAscList :: forall a. [(Key,a)] -> IntMap a
+#else
+fromDistinctAscList ::            [(Key,a)] -> IntMap a
+#endif
 fromDistinctAscList []         = Nil
 fromDistinctAscList (z0 : zs0) = work z0 zs0 Nada
   where
     work (kx,vx) []            stk = finish kx (Tip kx vx) stk
     work (kx,vx) (z@(kz,_):zs) stk = reduce z zs (branchMask kx kz) kx (Tip kx vx) stk
 
+#if __GLASGOW_HASKELL__
     reduce :: (Key,a) -> [(Key,a)] -> Mask -> Prefix -> IntMap a -> Stack a -> IntMap a
+#endif
     reduce z zs _ px tx Nada = work z zs (Push px tx Nada)
     reduce z zs m px tx stk@(Push py ty stk') =
         let mxy = branchMask px py
@@ -1680,7 +2144,7 @@ fromDistinctAscList (z0 : zs0) = work z0 zs0 Nada
                  else work z zs (Push px tx stk)
 
     finish _  t  Nada = t
-    finish px tx (Push py ty stk) = finish p (join py ty px tx) stk
+    finish px tx (Push py ty stk) = finish p (link py ty px tx) stk
         where m = branchMask px py
               p = mask px m
 
@@ -1724,6 +2188,12 @@ instance Ord a => Ord (IntMap a) where
 instance Functor IntMap where
     fmap = map
 
+#ifdef __GLASGOW_HASKELL__
+    a <$ Bin p m l r = Bin p m (a <$ l) (a <$ r)
+    a <$ Tip k _     = Tip k a
+    _ <$ Nil         = Nil
+#endif
+
 {--------------------------------------------------------------------
   Show
 --------------------------------------------------------------------}
@@ -1754,23 +2224,22 @@ instance (Read e) => Read (IntMap e) where
   Typeable
 --------------------------------------------------------------------}
 
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(IntMap,intMapTc,"IntMap")
+INSTANCE_TYPEABLE1(IntMap)
 
 {--------------------------------------------------------------------
   Helpers
 --------------------------------------------------------------------}
 {--------------------------------------------------------------------
-  Join
+  Link
 --------------------------------------------------------------------}
-join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
-join p1 t1 p2 t2
+link :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
+link p1 t1 p2 t2
   | zero p1 m = Bin p m t1 t2
   | otherwise = Bin p m t2 t1
   where
     m = branchMask p1 p2
     p = mask p1 m
-{-# INLINE join #-}
+{-# INLINE link #-}
 
 {--------------------------------------------------------------------
   @bin@ assures that we never have empty trees within a tree.
@@ -1781,6 +2250,17 @@ bin _ _ Nil r = r
 bin p m l r   = Bin p m l r
 {-# INLINE bin #-}
 
+-- binCheckLeft only checks that the left subtree is non-empty
+binCheckLeft :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
+binCheckLeft _ _ Nil r = r
+binCheckLeft p m l r   = Bin p m l r
+{-# INLINE binCheckLeft #-}
+
+-- binCheckRight only checks that the right subtree is non-empty
+binCheckRight :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
+binCheckRight _ _ l Nil = l
+binCheckRight p m l r   = Bin p m l r
+{-# INLINE binCheckRight #-}
 
 {--------------------------------------------------------------------
   Endian independent bit twiddling
@@ -1823,70 +2303,37 @@ branchMask p1 p2
   = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
 {-# INLINE branchMask #-}
 
-{----------------------------------------------------------------------
-  Finding the highest bit (mask) in a word [x] can be done efficiently in
-  three ways:
-  * convert to a floating point value and the mantissa tells us the
-    [log2(x)] that corresponds with the highest bit position. The mantissa
-    is retrieved either via the standard C function [frexp] or by some bit
-    twiddling on IEEE compatible numbers (float). Note that one needs to
-    use at least [double] precision for an accurate mantissa of 32 bit
-    numbers.
-  * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
-  * use processor specific assembler instruction (asm).
-
-  The most portable way would be [bit], but is it efficient enough?
-  I have measured the cycle counts of the different methods on an AMD
-  Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
-
-  highestBitMask: method  cycles
-                  --------------
-                   frexp   200
-                   float    33
-                   bit      11
-                   asm      12
-
-  highestBit:     method  cycles
-                  --------------
-                   frexp   195
-                   float    33
-                   bit      11
-                   asm      11
-
-  Wow, the bit twiddling is on today's RISC like machines even faster
-  than a single CISC instruction (BSR)!
-----------------------------------------------------------------------}
-
-{----------------------------------------------------------------------
-  [highestBitMask] returns a word where only the highest bit is set.
-  It is found by first setting all bits in lower positions than the
-  highest bit and than taking an exclusive or with the original value.
-  Allthough the function may look expensive, GHC compiles this into
-  excellent C code that subsequently compiled into highly efficient
-  machine code. The algorithm is derived from Jorg Arndt's FXT library.
-----------------------------------------------------------------------}
-highestBitMask :: Nat -> Nat
-highestBitMask x0
-  = case (x0 .|. shiftRL x0 1) of
-     x1 -> case (x1 .|. shiftRL x1 2) of
-      x2 -> case (x2 .|. shiftRL x2 4) of
-       x3 -> case (x3 .|. shiftRL x3 8) of
-        x4 -> case (x4 .|. shiftRL x4 16) of
-         x5 -> case (x5 .|. shiftRL x5 32) of   -- for 64 bit platforms
-          x6 -> (x6 `xor` (shiftRL x6 1))
-{-# INLINE highestBitMask #-}
-
-
 {--------------------------------------------------------------------
   Utilities
 --------------------------------------------------------------------}
 
-foldlStrict :: (a -> b -> a) -> a -> [b] -> a
-foldlStrict f = go
-  where
-    go z []     = z
-    go z (x:xs) = let z' = f z x in z' `seq` go z' xs
-{-# INLINE foldlStrict #-}
+-- | /O(1)/.  Decompose a map into pieces based on the structure of the underlying
+-- tree.  This function is useful for consuming a map in parallel.
+--
+-- No guarantee is made as to the sizes of the pieces; an internal, but
+-- deterministic process determines this.  However, it is guaranteed that the
+-- pieces returned will be in ascending order (all elements in the first submap
+-- less than all elements in the second, and so on).
+--
+-- Examples:
+--
+-- > splitRoot (fromList (zip [1..6::Int] ['a'..])) ==
+-- >   [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]]
+--
+-- > splitRoot empty == []
+--
+--  Note that the current implementation does not return more than two submaps,
+--  but you should not depend on this behaviour because it can change in the
+--  future without notice.
+splitRoot :: IntMap a -> [IntMap a]
+splitRoot orig =
+  case orig of
+    Nil -> []
+    x@(Tip _ _) -> [x]
+    Bin _ m l r | m < 0 -> [r, l]
+                | otherwise -> [l, r]
+{-# INLINE splitRoot #-}
+
 
 {--------------------------------------------------------------------
   Debugging