Stop using hedge algorithms
[packages/containers.git] / Data / IntMap / Base.hs
index 3832e1c..f45e7d1 100644 (file)
@@ -1,14 +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
-{-# LANGUAGE ScopedTypeVariables #-}
 #if __GLASGOW_HASKELL__ >= 708
 {-# LANGUAGE TypeFamilies #-}
 #endif
+
+#include "containers.h"
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.IntMap.Base
@@ -86,6 +90,7 @@ module Data.IntMap.Base (
     , updateWithKey
     , updateLookupWithKey
     , alter
+    , alterF
 
     -- * Combine
 
@@ -159,6 +164,8 @@ module Data.IntMap.Base (
     -- * Filter
     , filter
     , filterWithKey
+    , restrictKeys
+    , withoutKeys
     , partition
     , partitionWithKey
 
@@ -203,6 +210,8 @@ module Data.IntMap.Base (
     , intFromNat
     , link
     , bin
+    , binCheckLeft
+    , binCheckRight
     , zero
     , nomatch
     , match
@@ -213,16 +222,22 @@ module Data.IntMap.Base (
     , highestBitMask
     ) where
 
+#if !(MIN_VERSION_base(4,8,0))
 import Control.Applicative (Applicative(pure, (<*>)), (<$>))
+import Data.Monoid (Monoid(..))
+import Data.Traversable (Traversable(traverse))
+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.Monoid (Monoid(..))
-import Data.Traversable (Traversable(traverse))
 import Data.Typeable
-import Data.Word (Word)
 import Prelude hiding (lookup, map, filter, foldr, foldl, null)
 
 import Data.IntSet.Base (Key)
@@ -235,23 +250,16 @@ import Data.Utils.StrictPair
 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
 #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
-
--- We use cabal-generated MIN_VERSION_base to adapt to changes of base.
--- Nevertheless, as a convenience, we also allow compiling without cabal by
--- defining trivial MIN_VERSION_base if needed.
-#ifndef MIN_VERSION_base
-#define MIN_VERSION_base(major1,major2,minor) 0
+#if __GLASGOW_HASKELL__ >= 709
+import Data.Coerce
 #endif
 
 
@@ -295,7 +303,7 @@ type Mask   = 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
@@ -309,8 +317,16 @@ 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 = go
@@ -342,8 +358,7 @@ instance Foldable.Foldable IntMap where
   toList = elems -- NB: Foldable.toList /= IntMap.toList
   {-# INLINE toList #-}
   elem = go
-    where STRICT_1_OF_2(go)
-          go _ Nil = False
+    where go !_ Nil = False
           go x (Tip _ y) = x == y
           go x (Bin _ _ l r) = go x l || go x r
   {-# INLINABLE elem #-}
@@ -352,8 +367,7 @@ instance Foldable.Foldable IntMap where
           start (Tip _ y) = y
           start (Bin _ _ l r) = go (start l) r
 
-          STRICT_1_OF_2(go)
-          go m Nil = m
+          go !m Nil = m
           go m (Tip _ y) = max m y
           go m (Bin _ _ l r) = go (go m l) r
   {-# INLINABLE maximum #-}
@@ -362,8 +376,7 @@ instance Foldable.Foldable IntMap where
           start (Tip _ y) = y
           start (Bin _ _ l r) = go (start l) r
 
-          STRICT_1_OF_2(go)
-          go m Nil = m
+          go !m Nil = m
           go m (Tip _ y) = min m y
           go m (Bin _ _ l r) = go (go m l) r
   {-# INLINABLE minimum #-}
@@ -427,11 +440,9 @@ 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?
 --
@@ -440,7 +451,7 @@ size t
 
 -- See Note: Local 'go' functions and capturing]
 member :: Key -> IntMap a -> Bool
-member k = k `seq` go
+member !k = go
   where
     go (Bin p m l r) | nomatch k p m = False
                      | zero k m  = go l
@@ -460,7 +471,7 @@ notMember k m = not $ member k m
 
 -- See Note: Local 'go' functions and capturing]
 lookup :: Key -> IntMap a -> Maybe a
-lookup k = k `seq` go
+lookup !k = go
   where
     go (Bin p m l r) | nomatch k p m = Nothing
                      | zero k m  = go l
@@ -472,7 +483,7 @@ lookup k = k `seq` go
 
 -- See Note: Local 'go' functions and capturing]
 find :: Key -> IntMap a -> a
-find k = k `seq` go
+find !k = go
   where
     go (Bin p m l r) | nomatch k p m = not_found
                      | zero k m  = go l
@@ -492,7 +503,7 @@ find k = k `seq` go
 
 -- See Note: Local 'go' functions and capturing]
 findWithDefault :: a -> Key -> IntMap a -> a
-findWithDefault def k = k `seq` go
+findWithDefault def !k = go
   where
     go (Bin p m l r) | nomatch k p m = def
                      | zero k m  = go l
@@ -509,7 +520,7 @@ findWithDefault def k = k `seq` go
 
 -- See Note: Local 'go' functions and capturing.
 lookupLT :: Key -> IntMap a -> Maybe (Key, a)
-lookupLT k t = k `seq` case t of
+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
@@ -528,7 +539,7 @@ lookupLT k t = k `seq` case t of
 
 -- See Note: Local 'go' functions and capturing.
 lookupGT :: Key -> IntMap a -> Maybe (Key, a)
-lookupGT k t = k `seq` case t of
+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
@@ -548,7 +559,7 @@ lookupGT k t = k `seq` case t of
 
 -- See Note: Local 'go' functions and capturing.
 lookupLE :: Key -> IntMap a -> Maybe (Key, a)
-lookupLE k t = k `seq` case t of
+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
@@ -568,7 +579,7 @@ lookupLE k t = k `seq` case t of
 
 -- See Note: Local 'go' functions and capturing.
 lookupGE :: Key -> IntMap a -> Maybe (Key, a)
-lookupGE k t = k `seq` case t of
+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
@@ -630,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 -> 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)
-    Tip ky _
-      | k==ky         -> Tip k x
-      | otherwise     -> link 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.
@@ -668,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 -> 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)
-    Tip ky y
-      | k==ky         -> Tip k (f k x y)
-      | otherwise     -> link 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@)
@@ -695,16 +702,14 @@ 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,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')
-    Tip ky y
-      | k==ky         -> (Just y,Tip k (f k x y))
-      | otherwise     -> (Nothing,link 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)
 
 
 {--------------------------------------------------------------------
@@ -718,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.
@@ -749,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
@@ -775,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.
@@ -799,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)
 
 
 
@@ -818,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 -> link 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 -> link 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
@@ -922,6 +962,49 @@ differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMa
 differenceWithKey f m1 m2
   = mergeWithKey f id (const Nil) m1 m2
 
+-- | 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
+
 
 {--------------------------------------------------------------------
   Intersection
@@ -934,6 +1017,50 @@ intersection :: IntMap a -> IntMap b -> IntMap a
 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
+    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.
 --
 -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
@@ -1063,10 +1190,10 @@ mergeWithKey' bin' f g1 g2 = go
 
 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
@@ -1079,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
@@ -1097,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"
 
@@ -1113,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"
 
@@ -1295,11 +1422,11 @@ isSubmapOfBy _         Nil _           = True
 -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
 
 map :: (a -> b) -> IntMap a -> IntMap b
-map f t
-  = case t of
-      Bin p m l r -> Bin p m (map f l) (map f r)
-      Tip k x     -> Tip k (f x)
-      Nil         -> Nil
+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 #-}
@@ -1307,6 +1434,12 @@ map f t
 "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.
 --
@@ -1566,10 +1699,10 @@ 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) -> let lt' = union r lt 
-                                                        in lt' `seq` (lt', gt)
-                     else case go k r of (lt :*: gt) -> let gt' = union gt l
-                                                        in gt' `seq` (lt, gt')
+                     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
@@ -1596,19 +1729,19 @@ splitLookup k t =
       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' `seq` (lt', fnd, gt)
+                         (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 gt' `seq` (lt, fnd, gt')
+                         (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) -> let gt' = union gt r in gt' `seq` (lt, fnd, gt')
+            (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' `seq` (lt', fnd, gt)
+            (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)
@@ -1646,8 +1779,7 @@ foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
                         | 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' #-}
@@ -1681,8 +1813,7 @@ foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.
                         | 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' #-}
@@ -1717,8 +1848,7 @@ foldrWithKey' f z = \t ->      -- Use lambda t to be inlinable with two argument
                         | 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' #-}
@@ -1753,8 +1883,7 @@ foldlWithKey' f z = \t ->      -- Use lambda t to be inlinable with two argument
                         | 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' #-}
@@ -1814,8 +1943,7 @@ 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 STRICT_1_OF_2(computeBm)
-        computeBm acc (Bin _ _ l' r') = computeBm (computeBm acc 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"
 
@@ -1836,7 +1964,7 @@ fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1)
         -- 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 = prefix `seq` bmask `seq` case bits of
+        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 ->
@@ -1993,14 +2121,20 @@ fromAscListWithKey f (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0)
 --
 -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "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
@@ -2054,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
 --------------------------------------------------------------------}
@@ -2084,8 +2224,7 @@ instance (Read e) => Read (IntMap e) where
   Typeable
 --------------------------------------------------------------------}
 
-#include "Typeable.h"
-INSTANCE_TYPEABLE1(IntMap,intMapTc,"IntMap")
+INSTANCE_TYPEABLE1(IntMap)
 
 {--------------------------------------------------------------------
   Helpers
@@ -2111,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