containers 0.5.0.0 → 0.5.1.0

raw patch · 23 files changed

+691/−451 lines, 23 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Data/Graph.hs +1/−1
• Data/IntMap.hs +1/−1
• Data/IntMap/Base.hs +61/−41
• Data/IntMap/Lazy.hs +1/−1
• Data/IntMap/Strict.hs +56/−46
• Data/IntSet.hs +1/−0
• Data/IntSet/Base.hs +111/−78
• Data/Map/Base.hs +110/−56
• Data/Map/Lazy.hs +1/−1
• Data/Map/Strict.hs +87/−46
• Data/Set/Base.hs +82/−30
• Data/StrictPair.hs +8/−5
• benchmarks/IntMap.hs +3/−0
• benchmarks/IntSet.hs +6/−3
• benchmarks/Makefile +1/−1
• benchmarks/Map.hs +6/−1
• benchmarks/Set.hs +7/−3
• containers.cabal +1/−1
• tests/intmap-properties.hs +12/−8
• tests/intset-properties.hs +67/−53
• tests/map-properties.hs +15/−11
• tests/seq-properties.hs +2/−8
• tests/set-properties.hs +51/−56

@@ -17,7 +17,7 @@ -- -- A version of the graph algorithms described in: -----   /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/,+--   /Structuring Depth-First Search Algorithms in Haskell/, --   by David King and John Launchbury. -- -----------------------------------------------------------------------------

@@ -90,6 +90,6 @@ -- /O(n)/. Fold the keys and values in the map using the given -- right-associative binary operator. This function is an equivalent -- of 'foldrWithKey' and is present for compatibility only.-foldWithKey :: (Int -> a -> b -> b) -> b -> IntMap a -> b+foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b foldWithKey = foldrWithKey {-# INLINE foldWithKey #-}

@@ -222,6 +222,9 @@ import Control.Monad ( liftM ) import Control.DeepSeq (NFData(rnf)) +import Data.IntSet.Base (Key)+import Data.StrictPair+ #if __GLASGOW_HASKELL__ import Text.Read import Data.Data (Data(..), mkNoRepType)@@ -285,7 +288,6 @@  type Prefix = Int type Mask   = Int-type Key    = Int  {--------------------------------------------------------------------   Operators@@ -1402,16 +1404,18 @@ -- > 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. --@@ -1457,15 +1461,17 @@ -- >     == (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@@ -1479,18 +1485,23 @@  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' `seq` (lt', gt)+                     else case go k r of (lt :*: gt) -> let gt' = union gt l+                                                        in gt' `seq` (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.@@ -1503,14 +1514,23 @@  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' `seq` (lt', fnd, gt)+                     else case go k r of+                         (lt, fnd, gt) -> let gt' = union gt l+                                          in gt' `seq` (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 gt' `seq` (lt, fnd, gt')+        | otherwise      = case go k' r of+            (lt, fnd, gt) -> let lt' = union l lt in lt' `seq` (lt', fnd, gt)     go k' t'@(Tip ky y) | k' > ky   = (t', Nothing, Nil)                         | k' < ky   = (Nil, Nothing, t')                         | otherwise = (Nil, Just y, Nil)@@ -1599,7 +1619,7 @@ -- -- > 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 :: (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                         | otherwise -> go (go z r) l@@ -1613,7 +1633,7 @@ -- | /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' :: (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                         | otherwise -> go (go z r) l@@ -1635,7 +1655,7 @@ -- -- > 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 :: (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                         | otherwise -> go (go z l) r@@ -1649,7 +1669,7 @@ -- | /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' :: (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                         | otherwise -> go (go z l) r

@@ -16,7 +16,7 @@ -- (dictionaries). -- -- API of this module is strict in the keys, but lazy in the values.--- If you need value-strict maps, use 'Data.IntMap.Strict' instead.+-- If you need value-strict maps, use "Data.IntMap.Strict" instead. -- The 'IntMap' type itself is shared between the lazy and strict modules, -- meaning that the same 'IntMap' value can be passed to functions in -- both modules (although that is rarely needed).

@@ -16,7 +16,7 @@ -- (dictionaries). -- -- API of this module is strict in both the keys and the values.--- If you need value-lazy maps, use 'Data.IntMap.Lazy' instead.+-- If you need value-lazy maps, use "Data.IntMap.Lazy" instead. -- The 'IntMap' type itself is shared between the lazy and strict modules, -- meaning that the same 'IntMap' value can be passed to functions in -- both modules (although that is rarely needed).@@ -49,7 +49,7 @@ -- (32 or 64). -- -- Be aware that the 'Functor', 'Traversable' and 'Data' instances--- are the same as for the 'Data.IntMap.Lazy' module, so if they are used+-- are the same as for the "Data.IntMap.Lazy" module, so if they are used -- on strict maps, the resulting maps will be lazy. ----------------------------------------------------------------------------- @@ -390,16 +390,18 @@ -- > 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` x `seq`-  case t of-    Bin p m l r-      | nomatch k p m -> Nothing `strictPair` join k (Tip k x) p t-      | zero k m      -> let (found,l') = insertLookupWithKey f k x l in (found `strictPair` Bin p m l' r)-      | otherwise     -> let (found,r') = insertLookupWithKey f k x r in (found `strictPair` Bin p m l r')-    Tip ky y-      | k==ky         -> (Just y `strictPair` (Tip k $! f k x y))-      | otherwise     -> (Nothing `strictPair` join k (Tip k x) ky t)-    Nil -> Nothing `strictPair` Tip k x+insertLookupWithKey f0 k0 x0 t0 = k0 `seq` x0 `seq` toPair $ go f0 k0 x0 t0+  where+    go f k x t =+      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') = go f k x l in (found :*: Bin p m l' r)+          | otherwise     -> let (found :*: r') = go 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   {--------------------------------------------------------------------@@ -475,18 +477,20 @@ -- > 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 `strictPair` bin p m l' r)-      | otherwise     -> let (found,r') = updateLookupWithKey f k r in (found `strictPair` bin p m l r')-    Tip ky y-      | k==ky         -> case f k y of-                           Just y' -> y' `seq` (Just y `strictPair` Tip ky y')-                           Nothing -> (Just y, Nil)-      | otherwise     -> (Nothing,t)-    Nil -> (Nothing,Nil)+updateLookupWithKey f0 k0 t0 = k0 `seq` toPair $ go f0 k0 t0+  where+    go f k t =+      case t of+        Bin p m l r+          | nomatch k p m -> (Nothing :*: t)+          | zero k m      -> let (found :*: l') = go f k l in (found :*: bin p m l' r)+          | otherwise     -> let (found :*: r') = go f k r in (found :*: bin p m l r')+        Tip ky y+          | k==ky         -> case f k y of+                               Just y' -> y' `seq` (Just y :*: Tip ky y')+                               Nothing -> (Just y :*: Nil)+          | otherwise     -> (Nothing :*: t)+        Nil -> (Nothing :*: Nil)   @@ -743,24 +747,28 @@ -- the accumulating argument and the both elements of the -- result of the function. mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)-mapAccumL f a t-  = case t of-      Bin p m l r -> let (a1,l') = mapAccumL f a l-                         (a2,r') = mapAccumL f a1 r-                     in (a2 `strictPair` Bin p m l' r')-      Tip k x     -> let (a',x') = f a k x in x' `seq` (a' `strictPair` Tip k x')-      Nil         -> (a `strictPair` Nil)+mapAccumL f0 a0 t0 = toPair $ go f0 a0 t0+  where+    go f a t+      = case t of+          Bin p m l r -> let (a1 :*: l') = go f a l+                             (a2 :*: r') = go f a1 r+                         in (a2 :*: Bin p m l' r')+          Tip k x     -> let (a',x') = f a k x in x' `seq` (a' :*: Tip k x')+          Nil         -> (a :*: Nil)  -- | /O(n)/. The function @'mapAccumR'@ threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)-mapAccumRWithKey f a t-  = case t of-      Bin p m l r -> let (a1,r') = mapAccumRWithKey f a r-                         (a2,l') = mapAccumRWithKey f a1 l-                     in (a2 `strictPair` Bin p m l' r')-      Tip k x     -> let (a',x') = f a k x in x' `seq` (a' `strictPair` Tip k x')-      Nil         -> (a `strictPair` Nil)+mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0+  where+    go f a t+      = case t of+          Bin p m l r -> let (a1 :*: r') = go f a r+                             (a2 :*: l') = go f a1 l+                         in (a2 :*: Bin p m l' r')+          Tip k x     -> let (a',x') = f a k x in x' `seq` (a' :*: Tip k x')+          Nil         -> (a :*: Nil)  -- | /O(n*log n)/. -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.@@ -822,15 +830,17 @@ -- >     == (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 `strictPair` 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  -> y `seq` (Tip k y, Nil)-  Right z -> z `seq` (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  -> y `seq` (Tip k y :*: Nil)+      Right z -> z `seq` (Nil :*: Tip k z)+    go _ Nil = (Nil :*: Nil)  {--------------------------------------------------------------------   Conversions

@@ -56,6 +56,7 @@ #else               IntSet(..)      -- instance Eq,Show #endif+            , Key              -- * Operators             , (\\)

@@ -77,7 +77,7 @@  module Data.IntSet.Base (             -- * Set type-              IntSet(..)      -- instance Eq,Show+              IntSet(..), Key -- instance Eq,Show              -- * Operators             , (\\)@@ -168,6 +168,8 @@ import Data.Typeable import Control.DeepSeq (NFData) +import Data.StrictPair+ #if __GLASGOW_HASKELL__ import Text.Read import Data.Data (Data(..), mkNoRepType)@@ -258,6 +260,7 @@ type Prefix = Int type Mask   = Int type BitMap = Word+type Key    = Int  instance Monoid IntSet where     mempty  = empty@@ -301,7 +304,7 @@ -- | /O(min(n,W))/. Is the value a member of the set?  -- See Note: Local 'go' functions and capturing]-member :: Int -> IntSet -> Bool+member :: Key -> IntSet -> Bool member x = x `seq` go   where     go (Bin p m l r)@@ -312,7 +315,7 @@     go Nil = False  -- | /O(min(n,W))/. Is the element not in the set?-notMember :: Int -> IntSet -> Bool+notMember :: Key -> IntSet -> Bool notMember k = not . member k  -- | /O(log n)/. Find largest element smaller than the given one.@@ -321,7 +324,7 @@ -- > lookupLT 5 (fromList [3, 5]) == Just 3  -- See Note: Local 'go' functions and capturing.-lookupLT :: Int -> IntSet -> Maybe Int+lookupLT :: Key -> IntSet -> Maybe Key lookupLT x t = x `seq` case t of     Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r     _ -> go Nil t@@ -342,7 +345,7 @@ -- > lookupGT 5 (fromList [3, 5]) == Nothing  -- See Note: Local 'go' functions and capturing.-lookupGT :: Int -> IntSet -> Maybe Int+lookupGT :: Key -> IntSet -> Maybe Key lookupGT x t = x `seq` case t of     Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r     _ -> go Nil t@@ -364,7 +367,7 @@ -- > lookupLE 5 (fromList [3, 5]) == Just 5  -- See Note: Local 'go' functions and capturing.-lookupLE :: Int -> IntSet -> Maybe Int+lookupLE :: Key -> IntSet -> Maybe Key lookupLE x t = x `seq` case t of     Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r     _ -> go Nil t@@ -386,7 +389,7 @@ -- > lookupGE 6 (fromList [3, 5]) == Nothing  -- See Note: Local 'go' functions and capturing.-lookupGE :: Int -> IntSet -> Maybe Int+lookupGE :: Key -> IntSet -> Maybe Key lookupGE x t = x `seq` case t of     Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r     _ -> go Nil t@@ -404,14 +407,14 @@  -- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is -- given, it has m > 0.-unsafeFindMin :: IntSet -> Maybe Int+unsafeFindMin :: IntSet -> Maybe Key unsafeFindMin Nil = Nothing unsafeFindMin (Tip kx bm) = Just $ kx + lowestBitSet bm 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 :: IntSet -> Maybe Int+unsafeFindMax :: IntSet -> Maybe Key unsafeFindMax Nil = Nothing unsafeFindMax (Tip kx bm) = Just $ kx + highestBitSet bm unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r@@ -426,7 +429,7 @@ {-# INLINE empty #-}  -- | /O(1)/. A set of one element.-singleton :: Int -> IntSet+singleton :: Key -> IntSet singleton x   = Tip (prefixOf x) (bitmapOf x) {-# INLINE singleton #-}@@ -436,7 +439,7 @@ --------------------------------------------------------------------} -- | /O(min(n,W))/. Add a value to the set. There is no left- or right bias for -- IntSets.-insert :: Int -> IntSet -> IntSet+insert :: Key -> IntSet -> IntSet insert x = x `seq` insertBM (prefixOf x) (bitmapOf x)  -- Helper function for insert and union.@@ -454,7 +457,7 @@  -- | /O(min(n,W))/. Delete a value in the set. Returns the -- original set when the value was not present.-delete :: Int -> IntSet -> IntSet+delete :: Key -> IntSet -> IntSet delete x = x `seq` deleteBM (prefixOf x) (bitmapOf x)  -- Deletes all values mentioned in the BitMap from the set.@@ -641,7 +644,7 @@   Filter --------------------------------------------------------------------} -- | /O(n)/. Filter all elements that satisfy some predicate.-filter :: (Int -> Bool) -> IntSet -> IntSet+filter :: (Key -> Bool) -> IntSet -> IntSet filter predicate t   = case t of       Bin p m l r@@ -654,20 +657,22 @@         {-# INLINE bitPred #-}  -- | /O(n)/. partition the set according to some predicate.-partition :: (Int -> Bool) -> IntSet -> (IntSet,IntSet)-partition predicate t-  = case t of-      Bin p m l r-        -> let (l1,l2) = partition predicate l-               (r1,r2) = partition predicate r-           in (bin p m l1 r1, bin p m l2 r2)-      Tip kx bm-        -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm-           in  (tip kx bm1, tip kx (bm `xor` bm1))-      Nil -> (Nil,Nil)-  where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi-                         | otherwise           = bm-        {-# INLINE bitPred #-}+partition :: (Key -> Bool) -> IntSet -> (IntSet,IntSet)+partition 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 kx bm+            -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm+               in  tip kx bm1 :*: tip kx (bm `xor` bm1)+          Nil -> (Nil :*: Nil)+      where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi+                             | otherwise           = bm+            {-# INLINE bitPred #-}   -- | /O(min(n,W))/. The expression (@'split' x set@) is a pair @(set1,set2)@@@ -675,43 +680,67 @@ -- comprises the elements of @set@ greater than @x@. -- -- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5])-split :: Int -> IntSet -> (IntSet,IntSet)+split :: Key -> IntSet -> (IntSet,IntSet) split x t =-  case t of Bin _ m l r | m < 0 -> if x >= 0 then case go x l of (lt, gt) -> (union lt r, gt)-                                             else case go x r of (lt, gt) -> (lt, union gt l)-            _ -> go x t+  case t of+      Bin _ m l r+          | m < 0 -> if x >= 0  -- handle negative numbers.+                     then case go x l of (lt :*: gt) -> let lt' = union lt r+                                                        in lt' `seq` (lt', gt)+                     else case go x r of (lt :*: gt) -> let gt' = union gt l+                                                        in gt' `seq` (lt, gt')+      _ -> case go x t of+          (lt :*: gt) -> (lt, gt)   where-    go x' t'@(Bin p m l r) | match x' p m = if zero x' m then case go x' l of (lt, gt) -> (lt, union gt r)-                                                         else case go x' r of (lt, gt) -> (union lt l, gt)-                           | otherwise   = if x' < p then (Nil, t')-                                                     else (t', Nil)-    go x' t'@(Tip kx' bm) | kx' > x'          = (Nil, t')-                            -- equivalent to kx' > prefixOf x'-                          | kx' < prefixOf x' = (t', Nil)-                          | otherwise = (tip kx' (bm .&. lowerBitmap), tip kx' (bm .&. higherBitmap))-                              where lowerBitmap = bitmapOf x' - 1-                                    higherBitmap = complement (lowerBitmap + bitmapOf x')-    go _ Nil = (Nil, Nil)+    go !x' t'@(Bin p m l r)+        | match x' p m = if zero x' m+                         then case go x' l of+                             (lt :*: gt) -> lt :*: union gt r+                         else case go x' r of+                             (lt :*: gt) -> union lt l :*: gt+        | otherwise   = if x' < p then (Nil :*: t')+                        else (t' :*: Nil)+    go x' t'@(Tip kx' bm)+        | kx' > x'          = (Nil :*: t')+          -- equivalent to kx' > prefixOf x'+        | kx' < prefixOf x' = (t' :*: Nil)+        | otherwise = tip kx' (bm .&. lowerBitmap) :*: tip kx' (bm .&. higherBitmap)+            where lowerBitmap = bitmapOf x' - 1+                  higherBitmap = complement (lowerBitmap + bitmapOf x')+    go _ Nil = (Nil :*: Nil)  -- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot -- element was found in the original set.-splitMember :: Int -> IntSet -> (IntSet,Bool,IntSet)+splitMember :: Key -> IntSet -> (IntSet,Bool,IntSet) splitMember x t =-  case t of Bin _ m l r | m < 0 -> if x >= 0 then case go x l of (lt, fnd, gt) -> (union lt r, fnd, gt)-                                             else case go x r of (lt, fnd, gt) -> (lt, fnd, union gt l)-            _ -> go x t+  case t of+      Bin _ m l r | m < 0 -> if x >= 0+                             then case go x l of+                                 (lt, fnd, gt) -> let lt' = union lt r+                                                  in lt' `seq` (lt', fnd, gt)+                             else case go x r of+                                 (lt, fnd, gt) -> let gt' = union gt l+                                                  in gt' `seq` (lt, fnd, gt')+      _ -> go x t   where-    go x' t'@(Bin p m l r) | match x' p m = if zero x' m then case go x' l of (lt, fnd, gt) -> (lt, fnd, union gt r)-                                                         else case go x' r of (lt, fnd, gt) -> (union lt l, fnd, gt)-                           | otherwise   = if x' < p then (Nil, False, t')-                                                     else (t', False, Nil)-    go x' t'@(Tip kx' bm) | kx' > x'          = (Nil, False, t')-                            -- equivalent to kx' > prefixOf x'-                          | kx' < prefixOf x' = (t', False, Nil)-                          | otherwise = (tip kx' (bm .&. lowerBitmap), (bm .&. bitmapOfx') /= 0, tip kx' (bm .&. higherBitmap))-                              where bitmapOfx' = bitmapOf x'-                                    lowerBitmap = bitmapOfx' - 1-                                    higherBitmap = complement (lowerBitmap + bitmapOfx')+    go x' t'@(Bin p m l r)+        | match x' p m = if zero x' m+                         then case go x' l of+                             (lt, fnd, gt) -> (lt, fnd, union gt r)+                         else case go x' r of+                             (lt, fnd, gt) -> (union lt l, fnd, gt)+        | otherwise   = if x' < p then (Nil, False, t') else (t', False, Nil)+    go x' t'@(Tip kx' bm)+        | kx' > x'          = (Nil, False, t')+          -- equivalent to kx' > prefixOf x'+        | kx' < prefixOf x' = (t', False, Nil)+        | otherwise = let lt = tip kx' (bm .&. lowerBitmap)+                          found = (bm .&. bitmapOfx') /= 0+                          gt = tip kx' (bm .&. higherBitmap)+                      in lt `seq` found `seq` gt `seq` (lt, found, gt)+            where bitmapOfx' = bitmapOf x'+                  lowerBitmap = bitmapOfx' - 1+                  higherBitmap = complement (lowerBitmap + bitmapOfx')     go _ Nil = (Nil, False, Nil)  @@ -721,7 +750,7 @@  -- | /O(min(n,W))/. Retrieves the maximal key of the set, and the set -- stripped of that element, or 'Nothing' if passed an empty set.-maxView :: IntSet -> Maybe (Int, IntSet)+maxView :: IntSet -> Maybe (Key, IntSet) maxView 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)@@ -733,7 +762,7 @@  -- | /O(min(n,W))/. Retrieves the minimal key of the set, and the set -- stripped of that element, or 'Nothing' if passed an empty set.-minView :: IntSet -> Maybe (Int, IntSet)+minView :: IntSet -> Maybe (Key, IntSet) minView 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')@@ -746,18 +775,18 @@ -- | /O(min(n,W))/. Delete and find the minimal element. -- -- > deleteFindMin set = (findMin set, deleteMin set)-deleteFindMin :: IntSet -> (Int, IntSet)+deleteFindMin :: IntSet -> (Key, IntSet) deleteFindMin = fromMaybe (error "deleteFindMin: empty set has no minimal element") . minView  -- | /O(min(n,W))/. Delete and find the maximal element. -- -- > deleteFindMax set = (findMax set, deleteMax set)-deleteFindMax :: IntSet -> (Int, IntSet)+deleteFindMax :: IntSet -> (Key, IntSet) deleteFindMax = fromMaybe (error "deleteFindMax: empty set has no maximal element") . maxView   -- | /O(min(n,W))/. The minimal element of the set.-findMin :: IntSet -> Int+findMin :: IntSet -> Key findMin Nil = error "findMin: empty set has no minimal element" findMin (Tip kx bm) = kx + lowestBitSet bm findMin (Bin _ m l r)@@ -768,7 +797,7 @@           find Nil            = error "findMin Nil"  -- | /O(min(n,W))/. The maximal element of a set.-findMax :: IntSet -> Int+findMax :: IntSet -> Key findMax Nil = error "findMax: empty set has no maximal element" findMax (Tip kx bm) = kx + highestBitSet bm findMax (Bin _ m l r)@@ -797,7 +826,7 @@ -- It's worth noting that the size of the result may be smaller if, -- for some @(x,y)@, @x \/= y && f x == f y@ -map :: (Int->Int) -> IntSet -> IntSet+map :: (Key -> Key) -> IntSet -> IntSet map f = fromList . List.map f . toList  {--------------------------------------------------------------------@@ -808,7 +837,7 @@ -- for compatibility only. -- -- /Please note that fold will be deprecated in the future and removed./-fold :: (Int -> b -> b) -> b -> IntSet -> b+fold :: (Key -> b -> b) -> b -> IntSet -> b fold = foldr {-# INLINE fold #-} @@ -818,7 +847,7 @@ -- For example, -- -- > toAscList set = foldr (:) [] set-foldr :: (Int -> b -> b) -> b -> IntSet -> b+foldr :: (Key -> b -> b) -> b -> IntSet -> b 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                         | otherwise -> go (go z r) l@@ -832,7 +861,7 @@ -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value.-foldr' :: (Int -> b -> b) -> b -> IntSet -> b+foldr' :: (Key -> b -> b) -> b -> IntSet -> b 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                         | otherwise -> go (go z r) l@@ -850,7 +879,7 @@ -- For example, -- -- > toDescList set = foldl (flip (:)) [] set-foldl :: (a -> Int -> a) -> a -> IntSet -> a+foldl :: (a -> Key -> a) -> a -> IntSet -> a 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                         | otherwise -> go (go z l) r@@ -865,7 +894,7 @@ -- | /O(n)/. A strict version of 'foldl'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value.-foldl' :: (a -> Int -> a) -> a -> IntSet -> a+foldl' :: (a -> Key -> a) -> a -> IntSet -> a 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                         | otherwise -> go (go z l) r@@ -882,7 +911,7 @@ --------------------------------------------------------------------} -- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order. -- Subject to list fusion.-elems :: IntSet -> [Int]+elems :: IntSet -> [Key] elems   = toAscList @@ -890,28 +919,28 @@   Lists --------------------------------------------------------------------} -- | /O(n)/. Convert the set to a list of elements. Subject to list fusion.-toList :: IntSet -> [Int]+toList :: IntSet -> [Key] toList   = toAscList  -- | /O(n)/. Convert the set to an ascending list of elements. Subject to list -- fusion.-toAscList :: IntSet -> [Int]+toAscList :: IntSet -> [Key] toAscList = foldr (:) []  -- | /O(n)/. Convert the set to a descending list of elements. Subject to list -- fusion.-toDescList :: IntSet -> [Int]+toDescList :: IntSet -> [Key] toDescList = foldl (flip (:)) []  -- List fusion for the list generating functions. #if __GLASGOW_HASKELL__ -- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion. -- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.-foldrFB :: (Int -> b -> b) -> b -> IntSet -> b+foldrFB :: (Key -> b -> b) -> b -> IntSet -> b foldrFB = foldr {-# INLINE[0] foldrFB #-}-foldlFB :: (a -> Int -> a) -> a -> IntSet -> a+foldlFB :: (a -> Key -> a) -> a -> IntSet -> a foldlFB = foldl {-# INLINE[0] foldlFB #-} @@ -935,7 +964,7 @@   -- | /O(n*min(n,W))/. Create a set from a list of integers.-fromList :: [Int] -> IntSet+fromList :: [Key] -> IntSet fromList xs   = foldlStrict ins empty xs   where@@ -943,7 +972,7 @@  -- | /O(n)/. Build a set from an ascending list of elements. -- /The precondition (input list is ascending) is not checked./-fromAscList :: [Int] -> IntSet+fromAscList :: [Key] -> IntSet fromAscList [] = Nil fromAscList (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0)   where@@ -954,7 +983,7 @@  -- | /O(n)/. Build a set from an ascending list of distinct elements. -- /The precondition (input list is strictly ascending) is not checked./-fromDistinctAscList :: [Int] -> IntSet+fromDistinctAscList :: [Key] -> IntSet fromDistinctAscList []         = Nil fromDistinctAscList (z0 : zs0) = work (prefixOf z0) (bitmapOf z0) zs0 Nada   where@@ -1468,9 +1497,13 @@     Derrick Lehmer and published in 1964 in a book edited by Beckenbach.)" ----------------------------------------------------------------------} bitcount :: Int -> Word -> Int+#if MIN_VERSION_base(4,5,0)+bitcount a x = a + popCount x+#else bitcount a0 x0 = go a0 x0   where go a 0 = a         go a x = go (a + 1) (x .&. (x-1))+#endif {-# INLINE bitcount #-}  

@@ -250,6 +250,7 @@             , balanceR             , delta             , join+            , insertMax             , merge             , glue             , trim@@ -263,6 +264,7 @@ import Prelude hiding (lookup,map,filter,foldr,foldl,null) import qualified Data.Set.Base as Set import Data.StrictPair+import Data.Bits (shiftL, shiftR) import Data.Monoid (Monoid(..)) import Control.Applicative (Applicative(..), (<$>)) import Data.Traversable (Traversable(traverse))@@ -1548,13 +1550,15 @@ -- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])  partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)-partitionWithKey _ Tip = (Tip,Tip)-partitionWithKey p (Bin _ kx x l r)-  | p kx x    = (join kx x l1 r1,merge l2 r2)-  | otherwise = (merge l1 r1,join kx x l2 r2)+partitionWithKey p0 t0 = toPair $ go p0 t0   where-    (l1,l2) = partitionWithKey p l-    (r1,r2) = partitionWithKey p r+    go _ Tip = (Tip :*: Tip)+    go p (Bin _ kx x l r)+      | p kx x    = join kx x l1 r1 :*: merge l2 r2+      | otherwise = merge l1 r1 :*: join kx x l2 r2+      where+        (l1 :*: l2) = go p l+        (r1 :*: r2) = go p r  -- | /O(n)/. Map values and collect the 'Just' results. --@@ -1598,13 +1602,15 @@ -- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])  mapEitherWithKey :: (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  -> (join kx y l1 r1, merge l2 r2)-  Right z -> (merge l1 r1, join kx z l2 r2)- where-    (l1,l2) = mapEitherWithKey f l-    (r1,r2) = mapEitherWithKey f r+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go _ Tip = (Tip :*: Tip)+    go f (Bin _ kx x l r) = case f kx x of+      Left y  -> join kx y l1 r1 :*: merge l2 r2+      Right z -> merge l1 r1 :*: join kx z l2 r2+     where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r  {--------------------------------------------------------------------   Mapping@@ -1911,15 +1917,52 @@ -- If the list contains more than one value for the same key, the last value -- for the key is retained. --+-- If the keys of the list are ordered, linear-time implementation is used,+-- with the performance equal to 'fromDistinctAscList'.+-- -- > fromList [] == empty -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] -- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] +-- For some reason, when 'singleton' is used in fromList or in+-- create, it is not inlined, so we inline it manually. fromList :: Ord k => [(k,a)] -> Map k a-fromList xs-  = foldlStrict ins empty xs+fromList [] = Tip+fromList [(kx, x)] = Bin 1 kx x Tip Tip+fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = fromList' (Bin 1 kx0 x0 Tip Tip) xs0+                           | otherwise = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0   where-    ins t (k,x) = insert k x t+    not_ordered _ [] = False+    not_ordered kx ((ky,_) : _) = kx >= ky+    {-# INLINE not_ordered #-}++    fromList' t0 xs = foldlStrict ins t0 xs+      where ins t (k,x) = insert k x t++    STRICT_1_OF_3(go)+    go _ t [] = t+    go _ t [(kx, x)] = insertMax kx x t+    go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs+                              | otherwise = case create s xss of+                                  (r, ys, []) -> go (s `shiftL` 1) (join kx x l r) ys+                                  (r, _,  ys) -> fromList' (join kx x l r) ys++    -- The create is returning a triple (tree, xs, ys). Both xs and ys+    -- represent not yet processed elements and only one of them can be nonempty.+    -- If ys is nonempty, the keys in ys are not ordered with respect to tree+    -- and must be inserted using fromList'. Otherwise the keys have been+    -- ordered so far.+    STRICT_1_OF_2(create)+    create _ [] = (Tip, [], [])+    create s xs@(xp : xss)+      | s == 1 = case xp of (kx, x) | not_ordered kx xss -> (Bin 1 kx x Tip Tip, [], xss)+                                    | otherwise -> (Bin 1 kx x Tip Tip, xss, [])+      | otherwise = case create (s `shiftR` 1) xs of+                      res@(_, [], _) -> res+                      (l, [(ky, y)], zs) -> (insertMax ky y l, [], zs)+                      (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)+                                               | otherwise -> case create (s `shiftR` 1) yss of+                                                   (r, zs, ws) -> (join ky y l r, zs, ws) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromList #-} #endif@@ -2082,24 +2125,25 @@ -- > valid (fromDistinctAscList [(3,"b"), (5,"a")])          == True -- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False +-- For some reason, when 'singleton' is used in fromDistinctAscList or in+-- create, it is not inlined, so we inline it manually. fromDistinctAscList :: [(k,a)] -> Map k a-fromDistinctAscList xs-  = create const (length xs) xs+fromDistinctAscList [] = Tip+fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0   where-    -- 1) use continuations so that we use heap space instead of stack space.-    -- 2) special case for n==5 to create bushier trees.-    create c 0 xs' = c Tip xs'-    create c 5 xs' = case xs' of-                       ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)-                            -> c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3)) (singleton k5 x5)) xx-                       _ -> error "fromDistinctAscList create"-    create c n xs' = seq nr $ create (createR nr c) nl xs'-      where nl = n `div` 2-            nr = n - nl - 1+    STRICT_1_OF_3(go)+    go _ t [] = t+    go s l ((kx, x) : xs) = case create s xs of+                              (r, ys) -> go (s `shiftL` 1) (join kx x l r) ys -    createR n c l ((k,x):ys) = create (createB l k x c) n ys-    createR _ _ _ []         = error "fromDistinctAscList createR []"-    createB l k x c r zs     = c (bin k x l r) zs+    STRICT_1_OF_2(create)+    create _ [] = (Tip, [])+    create s xs@(x' : xs')+      | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip, xs')+      | otherwise = case create (s `shiftR` 1) xs of+                      res@(_, []) -> res+                      (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of+                        (r, zs) -> (join ky y l r, zs)   {--------------------------------------------------------------------@@ -2145,23 +2189,27 @@  -- See Note: Type of local 'go' function trimLookupLo :: Ord k => k -> MaybeS k -> Map k a -> (Maybe a, Map k a)-trimLookupLo lk NothingS t = greater lk t-  where greater :: Ord k => k -> Map k a -> (Maybe a, Map k a)-        greater lo t'@(Bin _ kx x l r) = case compare lo kx of LT -> lookup lo l `strictPair` t'-                                                               EQ -> (Just x, r)-                                                               GT -> greater lo r-        greater _ Tip = (Nothing, Tip)-trimLookupLo lk (JustS hk) t = middle lk hk t-  where middle :: Ord k => k -> k -> Map k a -> (Maybe a, Map k a)-        middle lo hi t'@(Bin _ kx x l r) = case compare lo kx of LT | kx < hi -> lookup lo l `strictPair` t'-                                                                    | otherwise -> middle lo hi l-                                                                 EQ -> Just x `strictPair` lesser hi r-                                                                 GT -> middle lo hi r-        middle _ _ Tip = (Nothing, Tip)+trimLookupLo lk0 mhk0 t0 = toPair $ go lk0 mhk0 t0+  where+    go lk NothingS t = greater lk t+      where greater :: Ord k => k -> Map k a -> StrictPair (Maybe a) (Map k a)+            greater lo t'@(Bin _ kx x l r) = case compare lo kx of+                LT -> lookup lo l :*: t'+                EQ -> (Just x :*: r)+                GT -> greater lo r+            greater _ Tip = (Nothing :*: Tip)+    go lk (JustS hk) t = middle lk hk t+      where middle :: Ord k => k -> k -> Map k a -> StrictPair (Maybe a) (Map k a)+            middle lo hi t'@(Bin _ kx x l r) = case compare lo kx of+                LT | kx < hi -> lookup lo l :*: t'+                   | otherwise -> middle lo hi l+                EQ -> Just x :*: lesser hi r+                GT -> middle lo hi r+            middle _ _ Tip = (Nothing :*: Tip) -        lesser :: Ord k => k -> Map k a -> Map k a-        lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l-        lesser _ t' = t'+            lesser :: Ord k => k -> Map k a -> Map k a+            lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l+            lesser _ t' = t' #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE trimLookupLo #-} #endif@@ -2209,13 +2257,15 @@ -- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)  split :: Ord k => k -> Map k a -> (Map k a,Map k a)-split k t = k `seq`-  case t of-    Tip            -> (Tip, Tip)-    Bin _ kx x l r -> case compare k kx of-      LT -> let (lt,gt) = split k l in (lt,join kx x gt r)-      GT -> let (lt,gt) = split k r in (join kx x l lt,gt)-      EQ -> (l,r)+split k0 t0 = k0 `seq` toPair $ go k0 t0+  where+    go k t =+      case t of+        Tip            -> (Tip :*: Tip)+        Bin _ kx x l r -> case compare k kx of+          LT -> let (lt :*: gt) = go k l in lt :*: join kx x gt r+          GT -> let (lt :*: gt) = go k r in join kx x l lt :*: gt+          EQ -> (l :*: r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE split #-} #endif@@ -2234,8 +2284,12 @@   case t of     Tip            -> (Tip,Nothing,Tip)     Bin _ kx x l r -> case compare k kx of-      LT -> let (lt,z,gt) = splitLookup k l in (lt,z,join kx x gt r)-      GT -> let (lt,z,gt) = splitLookup k r in (join kx x l lt,z,gt)+      LT -> let (lt,z,gt) = splitLookup k l+                gt' = join kx x gt r+            in gt' `seq` (lt,z,gt')+      GT -> let (lt,z,gt) = splitLookup k r+                lt' = join kx x l lt+            in lt' `seq` (lt',z,gt)       EQ -> (l,Just x,r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE splitLookup #-}

@@ -16,7 +16,7 @@ -- (dictionaries). -- -- API of this module is strict in the keys, but lazy in the values.--- If you need value-strict maps, use 'Data.Map.Strict' instead.+-- If you need value-strict maps, use "Data.Map.Strict" instead. -- The 'Map' type itself is shared between the lazy and strict modules, -- meaning that the same 'Map' value can be passed to functions in -- both modules (although that is rarely needed).

@@ -16,7 +16,7 @@ -- (dictionaries). -- -- API of this module is strict in both the keys and the values.--- If you need value-lazy maps, use 'Data.Map.Lazy' instead.+-- If you need value-lazy maps, use "Data.Map.Lazy" instead. -- The 'Map' type is shared between the lazy and strict modules, -- meaning that the same 'Map' value can be passed to functions in -- both modules (although that is rarely needed).@@ -45,7 +45,7 @@ -- the Big-O notation (<http://en.wikipedia.org/wiki/Big_O_notation>). -- -- Be aware that the 'Functor', 'Traversable' and 'Data' instances--- are the same as for the 'Data.Map.Lazy' module, so if they are used+-- are the same as for the "Data.Map.Lazy" module, so if they are used -- on strict maps, the resulting maps will be lazy. ----------------------------------------------------------------------------- @@ -267,6 +267,7 @@     ) import qualified Data.Set.Base as Set import Data.StrictPair+import Data.Bits (shiftL, shiftR)  -- Use macros to define strictness of functions.  STRICT_x_OF_y -- denotes an y-ary function strict in the x-th parameter. Similarly@@ -274,6 +275,8 @@ -- y-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+#define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined #define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined #define STRICT_1_2_OF_3(fn) fn arg1 arg2 _ | arg1 `seq` arg2 `seq` False = undefined #define STRICT_2_3_OF_4(fn) fn _ arg1 arg2 _ | arg1 `seq` arg2 `seq` False = undefined@@ -434,19 +437,19 @@ -- See Map.Base.Note: Type of local 'go' function insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a                     -> (Maybe a, Map k a)-insertLookupWithKey = go+insertLookupWithKey f0 kx0 x0 t0 = toPair $ go f0 kx0 x0 t0   where-    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)+    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a)     STRICT_2_3_OF_4(go)-    go _ kx x Tip = Nothing `strictPair` singleton kx x+    go _ kx x Tip = Nothing :*: 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-                  in found `strictPair` balanceL ky y l' r-            GT -> let (found, r') = go f kx x r-                  in found `strictPair` balanceR ky y l r'+            LT -> let (found :*: l') = go f kx x l+                  in found :*: balanceL ky y l' r+            GT -> let (found :*: r') = go f kx x r+                  in found :*: balanceR ky y l r'             EQ -> let x' = f kx x y-                  in x' `seq` (Just y `strictPair` Bin sy kx x' l r)+                  in x' `seq` (Just y :*: Bin sy kx x' l r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE insertLookupWithKey #-} #else@@ -547,20 +550,20 @@  -- See Map.Base.Note: Type of local 'go' function updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)-updateLookupWithKey = go+updateLookupWithKey f0 k0 t0 = toPair $ go f0 k0 t0  where-   go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)+   go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a)    STRICT_2_OF_3(go)-   go _ _ Tip = (Nothing,Tip)+   go _ _ Tip = (Nothing :*: Tip)    go f k (Bin sx kx x l r) =           case compare k kx of-               LT -> let (found,l') = go f k l-                     in found `strictPair` balanceR kx x l' r-               GT -> let (found,r') = go f k r-                     in found `strictPair` balanceL kx x l r'+               LT -> let (found :*: l') = go f k l+                     in found :*: balanceR kx x l' r+               GT -> let (found :*: r') = go f k r+                     in found :*: balanceL kx x l r'                EQ -> case f kx x of-                       Just x' -> x' `seq` (Just x' `strictPair` Bin sx kx x' l r)-                       Nothing -> (Just x,glue l r)+                       Just x' -> x' `seq` (Just x' :*: Bin sx kx x' l r)+                       Nothing -> (Just x :*: glue l r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE updateLookupWithKey #-} #else@@ -899,13 +902,15 @@ -- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])  mapEitherWithKey :: (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  -> 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+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go _ Tip = (Tip :*: Tip)+    go f (Bin _ kx x l r) = case f kx x of+      Left y  -> y `seq` (join kx y l1 r1 :*: merge l2 r2)+      Right z -> z `seq` (merge l1 r1 :*: join kx z l2 r2)+     where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r  {--------------------------------------------------------------------   Mapping@@ -1006,15 +1011,52 @@ -- If the list contains more than one value for the same key, the last value -- for the key is retained. --+-- If the keys of the list are ordered, linear-time implementation is used,+-- with the performance equal to 'fromDistinctAscList'.+-- -- > fromList [] == empty -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] -- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] +-- For some reason, when 'singleton' is used in fromList or in+-- create, it is not inlined, so we inline it manually. fromList :: Ord k => [(k,a)] -> Map k a-fromList xs-  = foldlStrict ins empty xs+fromList [] = Tip+fromList [(kx, x)] = x `seq` Bin 1 kx x Tip Tip+fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = x0 `seq` fromList' (Bin 1 kx0 x0 Tip Tip) xs0+                           | otherwise = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0   where-    ins t (k,x) = insert k x t+    not_ordered _ [] = False+    not_ordered kx ((ky,_) : _) = kx >= ky+    {-# INLINE not_ordered #-}++    fromList' t0 xs = foldlStrict ins t0 xs+      where ins t (k,x) = insert k x t++    STRICT_1_OF_3(go)+    go _ t [] = t+    go _ t [(kx, x)] = x `seq` insertMax kx x t+    go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs+                              | otherwise = case create s xss of+                                  (r, ys, []) -> x `seq` go (s `shiftL` 1) (join kx x l r) ys+                                  (r, _,  ys) -> x `seq` fromList' (join kx x l r) ys++    -- The create is returning a triple (tree, xs, ys). Both xs and ys+    -- represent not yet processed elements and only one of them can be nonempty.+    -- If ys is nonempty, the keys in ys are not ordered with respect to tree+    -- and must be inserted using fromList'. Otherwise the keys have been+    -- ordered so far.+    STRICT_1_OF_2(create)+    create _ [] = (Tip, [], [])+    create s xs@(xp : xss)+      | s == 1 = case xp of (kx, x) | not_ordered kx xss -> x `seq` (Bin 1 kx x Tip Tip, [], xss)+                                    | otherwise -> x `seq` (Bin 1 kx x Tip Tip, xss, [])+      | otherwise = case create (s `shiftR` 1) xs of+                      res@(_, [], _) -> res+                      (l, [(ky, y)], zs) -> y `seq` (insertMax ky y l, [], zs)+                      (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)+                                               | otherwise -> case create (s `shiftR` 1) yss of+                                                   (r, zs, ws) -> y `seq` (join ky y l r, zs, ws) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromList #-} #endif@@ -1117,23 +1159,22 @@ -- > valid (fromDistinctAscList [(3,"b"), (5,"a")])          == True -- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False +-- For some reason, when 'singleton' is used in fromDistinctAscList or in+-- create, it is not inlined, so we inline it manually. fromDistinctAscList :: [(k,a)] -> Map k a-fromDistinctAscList xs-  = create const (length xs) xs+fromDistinctAscList [] = Tip+fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0   where-    -- 1) use continuations so that we use heap space instead of stack space.-    -- 2) special case for n==5 to create bushier trees.-    create c 0 xs' = c Tip xs'-    create c 5 xs' = case xs' of-                       ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx)-                            -> x1 `seq` x2 `seq` x3 `seq` x4 `seq` x5 `seq`-                               c (bin k4 x4 (bin k2 x2 (singleton k1 x1) (singleton k3 x3))-                                  (singleton k5 x5)) xx-                       _ -> error "fromDistinctAscList create"-    create c n xs' = seq nr $ create (createR nr c) nl xs'-      where nl = n `div` 2-            nr = n - nl - 1+    STRICT_1_OF_3(go)+    go _ t [] = t+    go s l ((kx, x) : xs) = case create s xs of+                              (r, ys) -> x `seq` go (s `shiftL` 1) (join kx x l r) ys -    createR n c l ((k,x):ys) = x `seq` create (createB l k x c) n ys-    createR _ _ _ []         = error "fromDistinctAscList createR []"-    createB l k x c r zs     = x `seq` c (bin k x l r) zs+    STRICT_1_OF_2(create)+    create _ [] = (Tip, [])+    create s xs@(x' : xs')+      | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip, xs')+      | otherwise = case create (s `shiftR` 1) xs of+                      res@(_, []) -> res+                      (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of+                        (r, zs) -> y `seq` (join ky y l r, zs)

@@ -177,11 +177,14 @@  import Prelude hiding (filter,foldl,foldr,null,map) import qualified Data.List as List+import Data.Bits (shiftL, shiftR) import Data.Monoid (Monoid(..)) import qualified Data.Foldable as Foldable import Data.Typeable import Control.DeepSeq (NFData(rnf)) +import Data.StrictPair+ #if __GLASGOW_HASKELL__ import GHC.Exts ( build ) import Text.Read@@ -623,11 +626,13 @@ -- the predicate and one with all elements that don't satisfy the predicate. -- See also 'split'. partition :: (a -> Bool) -> Set a -> (Set a,Set a)-partition _ Tip = (Tip, Tip)-partition p (Bin _ x l r) = case (partition p l, partition p r) of-  ((l1, l2), (r1, r2))-    | p x       -> (join x l1 r1, merge l2 r2)-    | otherwise -> (merge l1 r1, join x l2 r2)+partition p0 t0 = toPair $ go p0 t0+  where+    go _ Tip = (Tip :*: Tip)+    go p (Bin _ x l r) = case (go p l, go p r) of+      ((l1 :*: l2), (r1 :*: r2))+        | p x       -> join x l1 r1 :*: merge l2 r2+        | otherwise -> merge l1 r1 :*: join x l2 r2  {----------------------------------------------------------------------   Map@@ -773,10 +778,49 @@ #endif  -- | /O(n*log n)/. Create a set from a list of elements.+--+-- If the elemens are ordered, linear-time implementation is used,+-- with the performance equal to 'fromDistinctAscList'.++-- For some reason, when 'singleton' is used in fromList or in+-- create, it is not inlined, so we inline it manually. fromList :: Ord a => [a] -> Set a-fromList = foldlStrict ins empty+fromList [] = Tip+fromList [x] = Bin 1 x Tip Tip+fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0+                    | otherwise = go (1::Int) (Bin 1 x0 Tip Tip) xs0   where-    ins t x = insert x t+    not_ordered _ [] = False+    not_ordered x (y : _) = x >= y+    {-# INLINE not_ordered #-}++    fromList' t0 xs = foldlStrict ins t0 xs+      where ins t x = insert x t++    STRICT_1_OF_3(go)+    go _ t [] = t+    go _ t [x] = insertMax x t+    go s l xs@(x : xss) | not_ordered x xss = fromList' l xs+                        | otherwise = case create s xss of+                            (r, ys, []) -> go (s `shiftL` 1) (join x l r) ys+                            (r, _,  ys) -> fromList' (join x l r) ys++    -- The create is returning a triple (tree, xs, ys). Both xs and ys+    -- represent not yet processed elements and only one of them can be nonempty.+    -- If ys is nonempty, the keys in ys are not ordered with respect to tree+    -- and must be inserted using fromList'. Otherwise the keys have been+    -- ordered so far.+    STRICT_1_OF_2(create)+    create _ [] = (Tip, [], [])+    create s xs@(x : xss)+      | s == 1 = if not_ordered x xss then (Bin 1 x Tip Tip, [], xss)+                                      else (Bin 1 x Tip Tip, xss, [])+      | otherwise = case create (s `shiftR` 1) xs of+                      res@(_, [], _) -> res+                      (l, [y], zs) -> (insertMax y l, [], zs)+                      (l, ys@(y:yss), _) | not_ordered y yss -> (l, [], ys)+                                         | otherwise -> case create (s `shiftR` 1) yss of+                                                   (r, zs, ws) -> (join y l r, zs, ws) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromList #-} #endif@@ -811,24 +855,26 @@  -- | /O(n)/. Build a set from an ascending list of distinct elements in linear time. -- /The precondition (input list is strictly ascending) is not checked./++-- For some reason, when 'singleton' is used in fromDistinctAscList or in+-- create, it is not inlined, so we inline it manually. fromDistinctAscList :: [a] -> Set a-fromDistinctAscList xs-  = create const (length xs) xs+fromDistinctAscList [] = Tip+fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0   where-    -- 1) use continutations so that we use heap space instead of stack space.-    -- 2) special case for n==5 to create bushier trees.-    create c 0 xs' = c Tip xs'-    create c 5 xs' = case xs' of-                       (x1:x2:x3:x4:x5:xx)-                            -> c (bin x4 (bin x2 (singleton x1) (singleton x3)) (singleton x5)) xx-                       _ -> error "fromDistinctAscList create 5"-    create c n xs' = seq nr $ create (createR nr c) nl xs'-      where nl = n `div` 2-            nr = n - nl - 1+    STRICT_1_OF_3(go)+    go _ t [] = t+    go s l (x : xs) = case create s xs of+                        (r, ys) -> go (s `shiftL` 1) (join x l r) ys -    createR n c l (x:ys) = create (createB l x c) n ys-    createR _ _ _ []     = error "fromDistinctAscList createR []"-    createB l x c r zs   = c (bin x l r) zs+    STRICT_1_OF_2(create)+    create _ [] = (Tip, [])+    create s xs@(x : xs')+      | s == 1 = (Bin 1 x Tip Tip, xs')+      | otherwise = case create (s `shiftR` 1) xs of+                      res@(_, []) -> res+                      (l, y:ys) -> case create (s `shiftR` 1) ys of+                        (r, zs) -> (join y l r, zs)  {--------------------------------------------------------------------   Eq converts the set to a list. In a lazy setting, this@@ -958,12 +1004,14 @@ -- where @set1@ comprises the elements of @set@ less than @x@ and @set2@ -- comprises the elements of @set@ greater than @x@. split :: Ord a => a -> Set a -> (Set a,Set a)-split _ Tip = (Tip,Tip)-split x (Bin _ y l r)-  = case compare x y of-      LT -> let (lt,gt) = split x l in (lt,join y gt r)-      GT -> let (lt,gt) = split x r in (join y l lt,gt)-      EQ -> (l,r)+split x0 t0 = toPair $ go x0 t0+  where+    go _ Tip = (Tip :*: Tip)+    go x (Bin _ y l r)+      = case compare x y of+          LT -> let (lt :*: gt) = go x l in (lt :*: join y gt r)+          GT -> let (lt :*: gt) = go x r in (join y l lt :*: gt)+          EQ -> (l :*: r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE split #-} #endif@@ -974,8 +1022,12 @@ splitMember _ Tip = (Tip, False, Tip) splitMember x (Bin _ y l r)    = case compare x y of-       LT -> let (lt, found, gt) = splitMember x l in (lt, found, join y gt r)-       GT -> let (lt, found, gt) = splitMember x r in (join y l lt, found, gt)+       LT -> let (lt, found, gt) = splitMember x l+                 gt' = join y gt r+             in gt' `seq` (lt, found, gt')+       GT -> let (lt, found, gt) = splitMember x r+                 lt' = join y l lt+             in lt' `seq` (lt', found, gt)        EQ -> (l, True, r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE splitMember #-}

@@ -1,6 +1,9 @@-module Data.StrictPair (strictPair) where+module Data.StrictPair (StrictPair(..), toPair) 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 #-}+-- | Same as regular Haskell pairs, but (x :*: _|_) = (_|_ :*: y) =+-- _|_+data StrictPair a b = !a :*: !b++toPair :: StrictPair a b -> (a, b)+toPair (x :*: y) = (x, y)+{-# INLINE toPair #-}

@@ -39,6 +39,9 @@         , bench "alter"  $ whnf (alt keys) m         , bench "mapMaybe" $ whnf (M.mapMaybe maybeDel) m         , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m+        , bench "fromList" $ whnf M.fromList elems+        , bench "fromAscList" $ whnf M.fromAscList elems+        , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems         ]   where     elems = zip keys values

@@ -32,11 +32,14 @@         , bench "union" $ whnf (S.union s_even) s_odd         , bench "difference" $ whnf (S.difference s) s_even         , bench "intersection" $ whnf (S.intersection s) s_even+        , bench "fromList" $ whnf S.fromList elems+        , bench "fromAscList" $ whnf S.fromAscList elems+        , bench "fromDistinctAscList" $ whnf S.fromDistinctAscList elems         ]   where-    elems = [1..2^10]-    elems_even = [2,4..2^10]-    elems_odd = [1,3..2^10]+    elems = [1..2^12]+    elems_even = [2,4..2^12]+    elems_odd = [1,3..2^12]  member :: [Int] -> S.IntSet -> Int member xs s = foldl' (\n x -> if S.member x s then n + 1 else n) 0 xs

@@ -4,7 +4,7 @@ 	ghc -O2 -DTESTING $< -i../$(TOP) -o $@ -outputdir tmp -rtsopts  bench-%.csv: bench-%-	./bench-$* -v -u bench-$*.csv+	./bench-$* $(BENCHMARK) -v -u bench-$*.csv  .PHONY: force clean veryclean force:

@@ -57,9 +57,14 @@         , bench "union" $ whnf (M.union m_even) m_odd         , bench "difference" $ whnf (M.difference m) m_even         , bench "intersection" $ whnf (M.intersection m) m_even+        , bench "split" $ whnf (M.split (bound `div` 2)) m+        , bench "fromList" $ whnf M.fromList elems+        , bench "fromList-desc" $ whnf M.fromList (reverse elems)+        , bench "fromAscList" $ whnf M.fromAscList elems+        , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems         ]   where-    bound = 2^10+    bound = 2^12     elems = zip keys values     elems_even = zip evens evens     elems_odd = zip odds odds

@@ -33,11 +33,15 @@         , bench "union" $ whnf (S.union s_even) s_odd         , bench "difference" $ whnf (S.difference s) s_even         , bench "intersection" $ whnf (S.intersection s) s_even+        , bench "fromList" $ whnf S.fromList elems+        , bench "fromList-desc" $ whnf S.fromList (reverse elems)+        , bench "fromAscList" $ whnf S.fromAscList elems+        , bench "fromDistinctAscList" $ whnf S.fromDistinctAscList elems         ]   where-    elems = [1..2^10]-    elems_even = [2,4..2^10]-    elems_odd = [1,3..2^10]+    elems = [1..2^12]+    elems_even = [2,4..2^12]+    elems_odd = [1,3..2^12]  member :: [Int] -> S.Set Int -> Int member xs s = foldl' (\n x -> if S.member x s then n + 1 else n) 0 xs

@@ -1,5 +1,5 @@ name: containers-version: 0.5.0.0+version: 0.5.1.0 license: BSD3 license-file: LICENSE maintainer: fox@ucw.cz

@@ -27,7 +27,7 @@ default (Int)  main :: IO ()-main = defaultMainWithOpts+main = defaultMain          [                testCase "index"      test_index              , testCase "size"       test_size@@ -137,6 +137,7 @@              , testProperty "fromList then toList" prop_list              , testProperty "toDescList"           prop_descList              , testProperty "toAscList+toDescList" prop_ascDescList+             , testProperty "fromList"             prop_fromList              , testProperty "alter"                prop_alter              , testProperty "index"                prop_index              , testProperty "null"                 prop_null@@ -165,13 +166,7 @@              , testProperty "foldl'"               prop_foldl'              , testProperty "keysSet"              prop_keysSet              , testProperty "fromSet"              prop_fromSet-             ] opts--  where-    opts = mempty { ropt_test_options = Just $ mempty { topt_maximum_generated_tests = Just 500-                                                      , topt_maximum_unsuitable_generated_tests = Just 500-                                                      }-                  }+             ]  {--------------------------------------------------------------------   Arbitrary, reasonably balanced trees@@ -852,6 +847,15 @@ prop_ascDescList :: [Int] -> Bool prop_ascDescList xs = toAscList m == reverse (toDescList m)   where m = fromList $ zip xs $ repeat ()++prop_fromList :: [Int] -> Bool+prop_fromList xs+  = case fromList (zip xs xs) of+      t -> t == fromAscList (zip sort_xs sort_xs) &&+           t == fromDistinctAscList (zip nub_sort_xs nub_sort_xs) &&+           t == List.foldr (uncurry insert) empty (zip xs xs)+  where sort_xs = sort xs+        nub_sort_xs = List.map List.head $ List.group sort_xs  ---------------------------------------------------------------- 

@@ -1,4 +1,10 @@+{-# LANGUAGE CPP #-}+#if MIN_VERSION_base(4,5,0)+import Data.Bits ((.&.), popCount)+import Data.Word (Word)+#else import Data.Bits ((.&.))+#endif import Data.IntSet import Data.List (nub,sort) import qualified Data.List as List@@ -12,59 +18,57 @@ import Test.QuickCheck hiding ((.&.))  main :: IO ()-main = defaultMainWithOpts [ testCase "lookupLT" test_lookupLT-                           , testCase "lookupGT" test_lookupGT-                           , testCase "lookupLE" test_lookupLE-                           , testCase "lookupGE" test_lookupGE-                           , testCase "split" test_split-                           , testProperty "prop_Single" prop_Single-                           , testProperty "prop_Member" prop_Member-                           , testProperty "prop_NotMember" prop_NotMember-                           , testProperty "prop_LookupLT" prop_LookupLT-                           , testProperty "prop_LookupGT" prop_LookupGT-                           , testProperty "prop_LookupLE" prop_LookupLE-                           , testProperty "prop_LookupGE" prop_LookupGE-                           , testProperty "prop_InsertDelete" prop_InsertDelete-                           , testProperty "prop_MemberFromList" prop_MemberFromList-                           , testProperty "prop_UnionInsert" prop_UnionInsert-                           , testProperty "prop_UnionAssoc" prop_UnionAssoc-                           , testProperty "prop_UnionComm" prop_UnionComm-                           , testProperty "prop_Diff" prop_Diff-                           , testProperty "prop_Int" prop_Int-                           , testProperty "prop_Ordered" prop_Ordered-                           , testProperty "prop_List" prop_List-                           , testProperty "prop_DescList" prop_DescList-                           , testProperty "prop_AscDescList" prop_AscDescList-                           , testProperty "prop_fromList" prop_fromList-                           , testProperty "prop_MaskPow2" prop_MaskPow2-                           , testProperty "prop_Prefix" prop_Prefix-                           , testProperty "prop_LeftRight" prop_LeftRight-                           , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf-                           , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2-                           , testProperty "prop_isSubsetOf" prop_isSubsetOf-                           , testProperty "prop_isSubsetOf2" prop_isSubsetOf2-                           , testProperty "prop_size" prop_size-                           , testProperty "prop_findMax" prop_findMax-                           , testProperty "prop_findMin" prop_findMin-                           , testProperty "prop_ord" prop_ord-                           , testProperty "prop_readShow" prop_readShow-                           , testProperty "prop_foldR" prop_foldR-                           , testProperty "prop_foldR'" prop_foldR'-                           , testProperty "prop_foldL" prop_foldL-                           , testProperty "prop_foldL'" prop_foldL'-                           , testProperty "prop_map" prop_map-                           , testProperty "prop_maxView" prop_maxView-                           , testProperty "prop_minView" prop_minView-                           , testProperty "prop_split" prop_split-                           , testProperty "prop_splitMember" prop_splitMember-                           , testProperty "prop_partition" prop_partition-                           , testProperty "prop_filter" prop_filter-                           ] opts-  where-    opts = mempty { ropt_test_options = Just $ mempty { topt_maximum_generated_tests = Just 500-                                                      , topt_maximum_unsuitable_generated_tests = Just 500-                                                      }-                  }+main = defaultMain [ testCase "lookupLT" test_lookupLT+                   , testCase "lookupGT" test_lookupGT+                   , testCase "lookupLE" test_lookupLE+                   , testCase "lookupGE" test_lookupGE+                   , testCase "split" test_split+                   , testProperty "prop_Single" prop_Single+                   , testProperty "prop_Member" prop_Member+                   , testProperty "prop_NotMember" prop_NotMember+                   , testProperty "prop_LookupLT" prop_LookupLT+                   , testProperty "prop_LookupGT" prop_LookupGT+                   , testProperty "prop_LookupLE" prop_LookupLE+                   , testProperty "prop_LookupGE" prop_LookupGE+                   , testProperty "prop_InsertDelete" prop_InsertDelete+                   , testProperty "prop_MemberFromList" prop_MemberFromList+                   , testProperty "prop_UnionInsert" prop_UnionInsert+                   , testProperty "prop_UnionAssoc" prop_UnionAssoc+                   , testProperty "prop_UnionComm" prop_UnionComm+                   , testProperty "prop_Diff" prop_Diff+                   , testProperty "prop_Int" prop_Int+                   , testProperty "prop_Ordered" prop_Ordered+                   , testProperty "prop_List" prop_List+                   , testProperty "prop_DescList" prop_DescList+                   , testProperty "prop_AscDescList" prop_AscDescList+                   , testProperty "prop_fromList" prop_fromList+                   , testProperty "prop_MaskPow2" prop_MaskPow2+                   , testProperty "prop_Prefix" prop_Prefix+                   , testProperty "prop_LeftRight" prop_LeftRight+                   , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf+                   , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2+                   , testProperty "prop_isSubsetOf" prop_isSubsetOf+                   , testProperty "prop_isSubsetOf2" prop_isSubsetOf2+                   , testProperty "prop_size" prop_size+                   , testProperty "prop_findMax" prop_findMax+                   , testProperty "prop_findMin" prop_findMin+                   , testProperty "prop_ord" prop_ord+                   , testProperty "prop_readShow" prop_readShow+                   , testProperty "prop_foldR" prop_foldR+                   , testProperty "prop_foldR'" prop_foldR'+                   , testProperty "prop_foldL" prop_foldL+                   , testProperty "prop_foldL'" prop_foldL'+                   , testProperty "prop_map" prop_map+                   , testProperty "prop_maxView" prop_maxView+                   , testProperty "prop_minView" prop_minView+                   , testProperty "prop_split" prop_split+                   , testProperty "prop_splitMember" prop_splitMember+                   , testProperty "prop_partition" prop_partition+                   , testProperty "prop_filter" prop_filter+#if MIN_VERSION_base(4,5,0)+                   , testProperty "prop_bitcount" prop_bitcount+#endif+                   ]  ---------------------------------------------------------------- -- Unit tests@@ -310,3 +314,13 @@  prop_filter :: IntSet -> Int -> Bool prop_filter s i = partition odd s == (filter odd s, filter even s)++#if MIN_VERSION_base(4,5,0)+prop_bitcount :: Int -> Word -> Bool+prop_bitcount a w = bitcount_orig a w == bitcount_new a w+  where+    bitcount_orig a0 x0 = go a0 x0+      where go a 0 = a+            go a x = go (a + 1) (x .&. (x-1))+    bitcount_new a x = a + popCount x+#endif

@@ -27,7 +27,7 @@ default (Int)  main :: IO ()-main = defaultMainWithOpts+main = defaultMain          [ testCase "ticket4242" test_ticket4242          , testCase "index"      test_index          , testCase "size"       test_size@@ -126,7 +126,7 @@          , testCase "minViewWithKey" test_minViewWithKey          , testCase "maxViewWithKey" test_maxViewWithKey          , testCase "valid" test_valid-         , testProperty "fromList"             prop_fromList+         , testProperty "valid"                prop_valid          , testProperty "insert to singleton"  prop_singleton          , testProperty "insert"               prop_insert          , testProperty "insert then lookup"   prop_insertLookup@@ -158,6 +158,7 @@          , testProperty "fromList then toList" prop_list          , testProperty "toDescList"           prop_descList          , testProperty "toAscList+toDescList" prop_ascDescList+         , testProperty "fromList"             prop_fromList          , testProperty "alter"                prop_alter          , testProperty "index"                prop_index          , testProperty "null"                 prop_null@@ -188,13 +189,7 @@          , testProperty "foldl'"               prop_foldl'          , testProperty "keysSet"              prop_keysSet          , testProperty "fromSet"              prop_fromSet-         ] opts--  where-    opts = mempty { ropt_test_options = Just $ mempty { topt_maximum_generated_tests = Just 500-                                                      , topt_maximum_unsuitable_generated_tests = Just 500-                                                      }-                  }+         ]  {--------------------------------------------------------------------   Arbitrary, reasonably balanced trees@@ -831,8 +826,8 @@ -- QuickCheck ---------------------------------------------------------------- -prop_fromList :: UMap -> Bool-prop_fromList t = valid t+prop_valid :: UMap -> Bool+prop_valid t = valid t  prop_singleton :: Int -> Int -> Bool prop_singleton k x = insert k x empty == singleton k x@@ -989,6 +984,15 @@ prop_ascDescList :: [Int] -> Bool prop_ascDescList xs = toAscList m == reverse (toDescList m)   where m = fromList $ zip xs $ repeat ()++prop_fromList :: [Int] -> Bool+prop_fromList xs+  = case fromList (zip xs xs) of+      t -> t == fromAscList (zip sort_xs sort_xs) &&+           t == fromDistinctAscList (zip nub_sort_xs nub_sort_xs) &&+           t == List.foldr (uncurry insert) empty (zip xs xs)+  where sort_xs = sort xs+        nub_sort_xs = List.map List.head $ List.group sort_xs  ---------------------------------------------------------------- 

@@ -21,7 +21,7 @@   main :: IO ()-main = defaultMainWithOpts+main = defaultMain        [ testProperty "fmap" prop_fmap        , testProperty "(<$)" prop_constmap        , testProperty "foldr" prop_foldr@@ -90,13 +90,7 @@        , testProperty "zipWith3" prop_zipWith3        , testProperty "zip4" prop_zip4        , testProperty "zipWith4" prop_zipWith4-       ] opts--  where-    opts = mempty { ropt_test_options = Just $ mempty { topt_maximum_generated_tests = Just 500-                                                      , topt_maximum_unsuitable_generated_tests = Just 500-                                                      }-                  }+       ]  ------------------------------------------------------------------------ -- Arbitrary

@@ -11,62 +11,57 @@ import Test.QuickCheck  main :: IO ()-main = defaultMainWithOpts [ testCase "lookupLT" test_lookupLT-                           , testCase "lookupGT" test_lookupGT-                           , testCase "lookupLE" test_lookupLE-                           , testCase "lookupGE" test_lookupGE-                           , testProperty "prop_Valid" prop_Valid-                           , testProperty "prop_Single" prop_Single-                           , testProperty "prop_Member" prop_Member-                           , testProperty "prop_NotMember" prop_NotMember-                           , testProperty "prop_LookupLT" prop_LookupLT-                           , testProperty "prop_LookupGT" prop_LookupGT-                           , testProperty "prop_LookupLE" prop_LookupLE-                           , testProperty "prop_LookupGE" prop_LookupGE-                           , testProperty "prop_InsertValid" prop_InsertValid-                           , testProperty "prop_InsertDelete" prop_InsertDelete-                           , testProperty "prop_DeleteValid" prop_DeleteValid-                           , testProperty "prop_Join" prop_Join-                           , testProperty "prop_Merge" prop_Merge-                           , testProperty "prop_UnionValid" prop_UnionValid-                           , testProperty "prop_UnionInsert" prop_UnionInsert-                           , testProperty "prop_UnionAssoc" prop_UnionAssoc-                           , testProperty "prop_UnionComm" prop_UnionComm-                           , testProperty "prop_DiffValid" prop_DiffValid-                           , testProperty "prop_Diff" prop_Diff-                           , testProperty "prop_IntValid" prop_IntValid-                           , testProperty "prop_Int" prop_Int-                           , testProperty "prop_Ordered" prop_Ordered-                           , testProperty "prop_List" prop_List-                           , testProperty "prop_DescList" prop_DescList-                           , testProperty "prop_AscDescList" prop_AscDescList-                           , testProperty "prop_fromList" prop_fromList-                           , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf-                           , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2-                           , testProperty "prop_isSubsetOf" prop_isSubsetOf-                           , testProperty "prop_isSubsetOf2" prop_isSubsetOf2-                           , testProperty "prop_size" prop_size-                           , testProperty "prop_findMax" prop_findMax-                           , testProperty "prop_findMin" prop_findMin-                           , testProperty "prop_ord" prop_ord-                           , testProperty "prop_readShow" prop_readShow-                           , testProperty "prop_foldR" prop_foldR-                           , testProperty "prop_foldR'" prop_foldR'-                           , testProperty "prop_foldL" prop_foldL-                           , testProperty "prop_foldL'" prop_foldL'-                           , testProperty "prop_map" prop_map-                           , testProperty "prop_maxView" prop_maxView-                           , testProperty "prop_minView" prop_minView-                           , testProperty "prop_split" prop_split-                           , testProperty "prop_splitMember" prop_splitMember-                           , testProperty "prop_partition" prop_partition-                           , testProperty "prop_filter" prop_filter-                           ] opts-  where-    opts = mempty { ropt_test_options = Just $ mempty { topt_maximum_generated_tests = Just 500-                                                      , topt_maximum_unsuitable_generated_tests = Just 500-                                                      }-                  }+main = defaultMain [ testCase "lookupLT" test_lookupLT+                   , testCase "lookupGT" test_lookupGT+                   , testCase "lookupLE" test_lookupLE+                   , testCase "lookupGE" test_lookupGE+                   , testProperty "prop_Valid" prop_Valid+                   , testProperty "prop_Single" prop_Single+                   , testProperty "prop_Member" prop_Member+                   , testProperty "prop_NotMember" prop_NotMember+                   , testProperty "prop_LookupLT" prop_LookupLT+                   , testProperty "prop_LookupGT" prop_LookupGT+                   , testProperty "prop_LookupLE" prop_LookupLE+                   , testProperty "prop_LookupGE" prop_LookupGE+                   , testProperty "prop_InsertValid" prop_InsertValid+                   , testProperty "prop_InsertDelete" prop_InsertDelete+                   , testProperty "prop_DeleteValid" prop_DeleteValid+                   , testProperty "prop_Join" prop_Join+                   , testProperty "prop_Merge" prop_Merge+                   , testProperty "prop_UnionValid" prop_UnionValid+                   , testProperty "prop_UnionInsert" prop_UnionInsert+                   , testProperty "prop_UnionAssoc" prop_UnionAssoc+                   , testProperty "prop_UnionComm" prop_UnionComm+                   , testProperty "prop_DiffValid" prop_DiffValid+                   , testProperty "prop_Diff" prop_Diff+                   , testProperty "prop_IntValid" prop_IntValid+                   , testProperty "prop_Int" prop_Int+                   , testProperty "prop_Ordered" prop_Ordered+                   , testProperty "prop_List" prop_List+                   , testProperty "prop_DescList" prop_DescList+                   , testProperty "prop_AscDescList" prop_AscDescList+                   , testProperty "prop_fromList" prop_fromList+                   , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf+                   , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2+                   , testProperty "prop_isSubsetOf" prop_isSubsetOf+                   , testProperty "prop_isSubsetOf2" prop_isSubsetOf2+                   , testProperty "prop_size" prop_size+                   , testProperty "prop_findMax" prop_findMax+                   , testProperty "prop_findMin" prop_findMin+                   , testProperty "prop_ord" prop_ord+                   , testProperty "prop_readShow" prop_readShow+                   , testProperty "prop_foldR" prop_foldR+                   , testProperty "prop_foldR'" prop_foldR'+                   , testProperty "prop_foldL" prop_foldL+                   , testProperty "prop_foldL'" prop_foldL'+                   , testProperty "prop_map" prop_map+                   , testProperty "prop_maxView" prop_maxView+                   , testProperty "prop_minView" prop_minView+                   , testProperty "prop_split" prop_split+                   , testProperty "prop_splitMember" prop_splitMember+                   , testProperty "prop_partition" prop_partition+                   , testProperty "prop_filter" prop_filter+                   ]  ---------------------------------------------------------------- -- Unit tests