[commit: containers] master: Use strictPair everywhere (c5e7ea3)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/containers

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/c5e7ea333a0505f1bdf1580d593d6423edb0ee62

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

commit c5e7ea333a0505f1bdf1580d593d6423edb0ee62
Author: Johan Tibell <johan.tibell at gmail.com>
Date:   Mon Nov 21 08:38:43 2011 -0800

    Use strictPair everywhere

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

 Data/IntMap/Strict.hs |   11 +----------
 Data/Map/Strict.hs    |   29 ++++++++++-------------------
 Data/Pair.hs          |    6 ++++++
 containers.cabal      |    1 +
 4 files changed, 18 insertions(+), 29 deletions(-)

diff --git a/Data/IntMap/Strict.hs b/Data/IntMap/Strict.hs
index 855544d..b286e3b 100644
--- a/Data/IntMap/Strict.hs
+++ b/Data/IntMap/Strict.hs
@@ -226,7 +226,7 @@ import Data.IntMap.Lazy hiding
     , fromAscListWithKey
     , fromDistinctAscList
     )
-
+import Data.Pair
 
 {--------------------------------------------------------------------
   Construction
@@ -875,12 +875,3 @@ fromDistinctAscList (z0 : zs0) = work z0 zs0 Nada
               p = mask px m
 
 data Stack a = Push {-# UNPACK #-} !Prefix !(IntMap a) !(Stack a) | Nada
-
-
-{--------------------------------------------------------------------
-  Utility
---------------------------------------------------------------------}
-
-strictPair :: a -> b -> (a, b)
-strictPair x y = x `seq` y `seq` (x, y)
-{-# INLINE strictPair #-}
diff --git a/Data/Map/Strict.hs b/Data/Map/Strict.hs
index ba95cfe..2c1c218 100644
--- a/Data/Map/Strict.hs
+++ b/Data/Map/Strict.hs
@@ -264,6 +264,7 @@ import Data.Map.Base hiding
     , updateMinWithKey
     , updateMaxWithKey
     )
+import Data.Pair
 
 -- Use macros to define strictness of functions.  STRICT_x_OF_y
 -- denotes an y-ary function strict in the x-th parameter. Similarly
@@ -419,18 +420,15 @@ insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a
 insertLookupWithKey = go
   where
     STRICT_2_3_OF_4(go)
-    go _ kx x Tip = (Nothing, singleton kx x)
+    go _ kx x Tip = Nothing `strictPair` singleton kx x
     go f kx x (Bin sy ky y l r) =
         case compare kx ky of
             LT -> let (found, l') = go f kx x l
-                      t = balanceL ky y l' r
-                  in t `seq` (found, t)
+                  in found `strictPair` balanceL ky y l' r
             GT -> let (found, r') = go f kx x r
-                      t = balanceR ky y l r'
-                  in t `seq` (found, t)
+                  in found `strictPair` balanceR ky y l r'
             EQ -> let x' = f kx x y
-                      t  = Bin sy kx x' l r
-                  in x' `seq` t `seq` (Just y, t)
+                  in x' `seq` (Just y `strictPair` Bin sy kx x' l r)
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINEABLE insertLookupWithKey #-}
 #else
@@ -524,14 +522,11 @@ updateLookupWithKey = go
    go f k (Bin sx kx x l r) =
           case compare k kx of
                LT -> let (found,l') = go f k l
-                         t = balanceR kx x l' r
-                     in t `seq` (found,t)
+                     in found `strictPair` balanceR kx x l' r
                GT -> let (found,r') = go f k r
-                         t = balanceL kx x l r'
-                     in t `seq` (found,t)
+                     in found `strictPair` balanceL kx x l r'
                EQ -> case f kx x of
-                       Just x' -> let t = Bin sx kx x' l r
-                                  in x' `seq` t `seq` (Just x',t)
+                       Just x' -> x' `seq` (Just x' `strictPair` Bin sx kx x' l r)
                        Nothing -> (Just x,glue l r)
 #if __GLASGOW_HASKELL__ >= 700
 {-# INLINEABLE updateLookupWithKey #-}
@@ -892,12 +887,8 @@ mapEitherWithKey :: Ord k =>
   (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)
 mapEitherWithKey _ Tip = (Tip, Tip)
 mapEitherWithKey f (Bin _ kx x l r) = case f kx x of
-  Left y  -> let l' = join kx y l1 r1
-                 r' = merge l2 r2
-             in y `seq` l' `seq` r' `seq` (l', r')
-  Right z -> let l' = merge l1 r1
-                 r' = join kx z l2 r2
-             in z `seq` l' `seq` r' `seq` (l', r')
+  Left y  -> y `seq` (join kx y l1 r1 `strictPair` merge l2 r2)
+  Right z -> z `seq` (merge l1 r1 `strictPair` join kx z l2 r2)
  where
     (l1,l2) = mapEitherWithKey f l
     (r1,r2) = mapEitherWithKey f r
diff --git a/Data/Pair.hs b/Data/Pair.hs
new file mode 100644
index 0000000..40c84ef
--- /dev/null
+++ b/Data/Pair.hs
@@ -0,0 +1,6 @@
+module Data.Pair (strictPair) where
+
+-- | Evaluate both argument to WHNF and create a pair of the result.
+strictPair :: a -> b -> (a, b)
+strictPair x y = x `seq` y `seq` (x, y)
+{-# INLINE strictPair #-}
diff --git a/containers.cabal b/containers.cabal
index 2ff8a37..ea3a037 100644
--- a/containers.cabal
+++ b/containers.cabal
@@ -33,6 +33,7 @@ Library
     other-modules:
         Data.IntMap.Base
         Data.Map.Base
+        Data.Pair
     exposed-modules:
         Data.IntMap
         Data.IntMap.Lazy