containers 0.3.0.0 → 0.4.0.0
raw patch · 5 files changed
+472/−742 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Data.Map: insertLookupWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Files
- Data/IntMap.hs +163/−243
- Data/IntSet.hs +2/−1
- Data/Map.hs +277/−486
- Data/Sequence.hs +20/−8
- containers.cabal +10/−4
Data/IntMap.hs view
@@ -1,4 +1,7 @@-{-# OPTIONS_GHC -cpp -XNoBangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_GHC -cpp -XNoBangPatterns -XScopedTypeVariables #-}+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap@@ -41,7 +44,11 @@ module Data.IntMap ( -- * Map type+#if !defined(TESTING) IntMap, Key -- instance Eq,Show+#else+ IntMap(..), Key -- instance Eq,Show+#endif -- * Operators , (!), (\\)@@ -51,7 +58,7 @@ , size , member , notMember- , lookup+ , lookup , findWithDefault -- * Construction@@ -105,7 +112,7 @@ -- * Conversion , elems , keys- , keysSet+ , keysSet , assocs -- ** Lists@@ -200,10 +207,10 @@ type Nat = Word natFromInt :: Key -> Nat-natFromInt i = fromIntegral i+natFromInt = fromIntegral intFromNat :: Nat -> Key-intFromNat w = fromIntegral w+intFromNat = fromIntegral shiftRL :: Nat -> Key -> Nat #if __GLASGOW_HASKELL__@@ -336,6 +343,7 @@ | (k == natFromInt kx) -> Just x | otherwise -> Nothing Nil -> Nothing+-- ^ inlining lookup doesn't seem to help. find' :: Key -> IntMap a -> a find' k m@@ -343,7 +351,6 @@ Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map") Just x -> x - -- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@ -- returns the value at key @k@ or returns @def@ when the key is not an -- element of the map.@@ -429,18 +436,20 @@ -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a-insertWithKey f k x t- = case t of- Bin p m l r - | nomatch k p m -> join k (Tip k x) p t- | zero k m -> Bin p m (insertWithKey f k x l) r- | otherwise -> Bin p m l (insertWithKey f k x r)- Tip ky y - | k==ky -> Tip k (f k x y)- | otherwise -> join k (Tip k x) ky t- Nil -> Tip k x+insertWithKey f k x = k `seq` go+ where+ go t@(Bin p m l r)+ | nomatch k p m = join k (Tip k x) p t+ | zero k m = Bin p m (go l) r+ | otherwise = Bin p m l (go r) + go t@(Tip ky y)+ | k==ky = Tip k (f k x y)+ | otherwise = join k (Tip k x) ky t + go 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@) -- and the second element equal to (@'insertWithKey' f k x map@).@@ -457,18 +466,20 @@ -- > 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- = case t of- Bin p m l r - | nomatch k p m -> (Nothing,join k (Tip k x) p t)- | zero k m -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)- | otherwise -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')- Tip ky y - | k==ky -> (Just y,Tip k (f k x y))- | otherwise -> (Nothing,join k (Tip k x) ky t)- Nil -> (Nothing,Tip k x)+insertLookupWithKey f k x = k `seq` go+ where+ go t@(Bin p m l r)+ | nomatch k p m = (Nothing,join k (Tip k x) p t)+ | zero k m = case go l of (found, l') -> (found,Bin p m l' r)+ | otherwise = case go r of (found, r') -> (found,Bin p m l r') + go t@(Tip ky y)+ | k==ky = (Just y,Tip k (f k x y))+ | otherwise = (Nothing,join k (Tip k x) ky t) + go Nil = (Nothing,Tip k x)++ {-------------------------------------------------------------------- Deletion [delete] is the inlined version of [deleteWith (\k x -> Nothing)]@@ -481,17 +492,19 @@ -- > delete 5 empty == empty delete :: Key -> IntMap a -> IntMap a-delete k t- = 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 = go+ where+ go t@(Bin p m l r)+ | nomatch k p m = t+ | zero k m = bin p m (go l) r+ | otherwise = bin p m l (go r) + go t@(Tip ky _)+ | k==ky = Nil+ | otherwise = t++ go 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. --@@ -512,8 +525,8 @@ -- > adjustWithKey f 7 empty == empty adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a-adjustWithKey f k m- = updateWithKey (\k' x -> Just (f k' x)) k m+adjustWithKey f+ = updateWithKey (\k' x -> Just (f k' x)) -- | /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@@ -525,8 +538,8 @@ -- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a-update f k m- = updateWithKey (\_ x -> f x) k m+update f+ = updateWithKey (\_ x -> f x) -- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is@@ -538,19 +551,21 @@ -- > 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- = 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 = go+ where+ go t@(Bin p m l r)+ | nomatch k p m = t+ | zero k m = bin p m (go l) r+ | otherwise = bin p m l (go r)++ go t@(Tip ky y)+ | k==ky = case f k y of Just y' -> Tip ky y' Nothing -> Nil- | otherwise -> t- Nil -> Nil+ | otherwise = t + go Nil = Nil+ -- | /O(min(n,W))/. Lookup and update. -- The function returns original value, if it is updated. -- This is different behavior than 'Data.Map.updateLookupWithKey'.@@ -562,41 +577,44 @@ -- > 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- = 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+updateLookupWithKey f k = go+ where+ go t@(Bin p m l r)+ | nomatch k p m = (Nothing,t)+ | zero k m = case updateLookupWithKey f k l of (found, l') -> (found,bin p m l' r)+ | otherwise = case updateLookupWithKey f k r of (found, r') -> (found,bin p m l r')++ go 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)- Nil -> (Nothing,Nil)-+ | otherwise = (Nothing,t) + go Nil = (Nothing,Nil) -- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. -- '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) -> Int -> IntMap a -> IntMap a-alter f k t- = case t of- Bin p m l r - | nomatch k p m -> case f Nothing of +alter f k = k `seq` go+ where + go t@(Bin p m l r)+ | nomatch k p m = case f Nothing of Nothing -> t- Just x -> join k (Tip k x) p t- | zero k m -> bin p m (alter f k l) r- | otherwise -> bin p m l (alter f k r)- Tip ky y - | k==ky -> case f (Just y) of+ Just x -> join k (Tip k x) p t+ | zero k m = bin p m (go l) r+ | otherwise = bin p m l (go r)++ go t@(Tip ky y) + | k==ky = case f (Just y) of Just x -> Tip ky x Nothing -> Nil- | otherwise -> case f Nothing of++ | otherwise = case f Nothing of Just x -> join k (Tip k x) ky t Nothing -> Tip ky y- Nil -> case f Nothing of++ go Nil = case f Nothing of Just x -> Tip k x Nothing -> Nil @@ -841,19 +859,19 @@ -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMinWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a-updateMinWithKey f t- = case t of- Bin p m l r | m < 0 -> let t' = updateMinWithKeyUnsigned f r in Bin p m l t'- Bin p m l r -> let t' = updateMinWithKeyUnsigned f l in Bin p m t' r- Tip k y -> Tip k (f k y)- Nil -> error "maxView: empty map has no maximal element"+updateMinWithKey f = go+ where+ go (Bin p m l r) | m < 0 = let t' = updateMinWithKeyUnsigned f r in Bin p m l t'+ go (Bin p m l r) = let t' = updateMinWithKeyUnsigned f l in Bin p m t' r+ go (Tip k y) = Tip k (f k y)+ go Nil = error "maxView: empty map has no maximal element" updateMinWithKeyUnsigned :: (Key -> a -> a) -> IntMap a -> IntMap a-updateMinWithKeyUnsigned f t- = case t of- Bin p m l r -> let t' = updateMinWithKeyUnsigned f l in Bin p m t' r- Tip k y -> Tip k (f k y)- Nil -> error "updateMinWithKeyUnsigned Nil"+updateMinWithKeyUnsigned f = go+ where+ go (Bin p m l r) = let t' = go l in Bin p m t' r+ go (Tip k y) = Tip k (f k y)+ go Nil = error "updateMinWithKeyUnsigned Nil" -- | /O(log n)/. Update the value at the maximal key. --@@ -861,19 +879,19 @@ -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMaxWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a-updateMaxWithKey f t- = case t of- Bin p m l r | m < 0 -> let t' = updateMaxWithKeyUnsigned f l in Bin p m t' r- Bin p m l r -> let t' = updateMaxWithKeyUnsigned f r in Bin p m l t'- Tip k y -> Tip k (f k y)- Nil -> error "maxView: empty map has no maximal element"+updateMaxWithKey f = go+ where+ go (Bin p m l r) | m < 0 = let t' = updateMaxWithKeyUnsigned f l in Bin p m t' r+ go (Bin p m l r) = let t' = updateMaxWithKeyUnsigned f r in Bin p m l t'+ go (Tip k y) = Tip k (f k y)+ go Nil = error "maxView: empty map has no maximal element" updateMaxWithKeyUnsigned :: (Key -> a -> a) -> IntMap a -> IntMap a-updateMaxWithKeyUnsigned f t- = case t of- Bin p m l r -> let t' = updateMaxWithKeyUnsigned f r in Bin p m l t'- Tip k y -> Tip k (f k y)- Nil -> error "updateMaxWithKeyUnsigned Nil"+updateMaxWithKeyUnsigned f = go+ where+ go (Bin p m l r) = let t' = go r in Bin p m l t'+ go (Tip k y) = Tip k (f k y)+ go Nil = error "updateMaxWithKeyUnsigned Nil" -- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and@@ -979,11 +997,13 @@ find (Bin _ _ _ r') = find r' find Nil = error "findMax Nil" --- | /O(log n)/. Delete the minimal key.+-- | /O(log n)/. Delete the minimal key. An error is thrown if the IntMap is already empty.+-- Note, this is not the same behavior Map. deleteMin :: IntMap a -> IntMap a deleteMin = maybe (error "deleteMin: empty map has no minimal element") snd . minView --- | /O(log n)/. Delete the maximal key.+-- | /O(log n)/. Delete the maximal key. An error is thrown if the IntMap is already empty.+-- Note, this is not the same behavior Map. deleteMax :: IntMap a -> IntMap a deleteMax = maybe (error "deleteMax: empty map has no maximal element") snd . maxView @@ -1088,8 +1108,7 @@ -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] map :: (a -> b) -> IntMap a -> IntMap b-map f m- = mapWithKey (\_ x -> f x) m+map f = mapWithKey (\_ x -> f x) -- | /O(n)/. Map a function over all values in the map. --@@ -1097,11 +1116,11 @@ -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b-mapWithKey f t - = case t of- Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)- Tip k x -> Tip k (f k x)- Nil -> Nil+mapWithKey f = go+ where+ go (Bin p m l r) = Bin p m (go l) (go r)+ go (Tip k x) = Tip k (f k x)+ go Nil = Nil -- | /O(n)/. The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys.@@ -1110,8 +1129,7 @@ -- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")]) mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)-mapAccum f a m- = mapAccumWithKey (\a' _ x -> f a' x) a m+mapAccum f = mapAccumWithKey (\a' _ x -> f a' x) -- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating -- argument through the map in ascending order of keys.@@ -1163,14 +1181,13 @@ -- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a-filterWithKey predicate t- = case t of- Bin p m l r - -> bin p m (filterWithKey predicate l) (filterWithKey predicate r)- Tip k x - | predicate k x -> t- | otherwise -> Nil- Nil -> Nil+filterWithKey p = go+ where+ go (Bin pr m l r) = bin pr m (go l) (go r)+ go t@(Tip k x)+ | p k x = t+ | otherwise = Nil+ go Nil = Nil -- | /O(n)/. Partition the map according to some predicate. The first -- map contains all elements that satisfy the predicate, the second all@@ -1210,8 +1227,7 @@ -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b-mapMaybe f m- = mapMaybeWithKey (\_ x -> f x) m+mapMaybe f = mapMaybeWithKey (\_ x -> f x) -- | /O(n)/. Map keys\/values and collect the 'Just' results. --@@ -1219,12 +1235,13 @@ -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b-mapMaybeWithKey f (Bin p m l r)- = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)-mapMaybeWithKey f (Tip k x) = case f k x of- Just y -> Tip k y- Nothing -> Nil-mapMaybeWithKey _ Nil = Nil+mapMaybeWithKey f = go+ where+ go (Bin p m l r) = bin p m (go l) (go r)+ go (Tip k x) = case f k x of+ Just y -> Tip k y+ Nothing -> Nil+ go Nil = Nil -- | /O(n)/. Map values and separate the 'Left' and 'Right' results. --@@ -1345,8 +1362,7 @@ -- > fold f 0 (fromList [(5,"a"), (3,"bbb")]) == 4 fold :: (a -> b -> b) -> b -> IntMap a -> b-fold f z t- = foldWithKey (\_ x y -> f x y) z t+fold f = foldWithKey (\_ x y -> f x y) -- | /O(n)/. Fold the keys and values in the map, such that -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.@@ -1358,8 +1374,8 @@ -- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)" foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b-foldWithKey f z t- = foldr f z t+foldWithKey+ = foldr foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b foldr f z t@@ -1370,13 +1386,11 @@ Nil -> z foldr' :: (Key -> a -> b -> b) -> b -> IntMap a -> b-foldr' f z t- = case t of- Bin _ _ l r -> foldr' f (foldr' f z r) l- Tip k x -> f k x z- Nil -> z--+foldr' f = go+ where+ go z (Bin _ _ l r) = go (go z r) l+ go z (Tip k x) = f k x z+ go z Nil = z {-------------------------------------------------------------------- List variations @@ -1388,8 +1402,8 @@ -- > elems empty == [] elems :: IntMap a -> [a]-elems m- = foldWithKey (\_ x xs -> x:xs) [] m+elems+ = foldWithKey (\_ x xs -> x:xs) [] -- | /O(n)/. Return all keys of the map in ascending order. --@@ -1397,8 +1411,8 @@ -- > keys empty == [] keys :: IntMap a -> [Key]-keys m- = foldWithKey (\k _ ks -> k:ks) [] m+keys+ = foldWithKey (\k _ ks -> k:ks) [] -- | /O(n*min(n,W))/. The set of all keys of the map. --@@ -1428,8 +1442,8 @@ -- > toList empty == [] toList :: IntMap a -> [(Key,a)]-toList t- = foldWithKey (\k x xs -> (k,x):xs) [] t+toList+ = foldWithKey (\k x xs -> (k,x):xs) [] -- | /O(n)/. Convert the map to a list of key\/value pairs where the -- keys are in ascending order.@@ -1515,14 +1529,20 @@ -- -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -fromDistinctAscList :: [(Key,a)] -> IntMap a+#ifdef __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 +#ifdef __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@@ -1809,109 +1829,9 @@ {-------------------------------------------------------------------- Utilities --------------------------------------------------------------------}-foldlStrict :: (a -> b -> a) -> a -> [b] -> a-foldlStrict f z xs- = case xs of- [] -> z- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx) -{--{--------------------------------------------------------------------- Testing---------------------------------------------------------------------}-testTree :: [Int] -> IntMap Int-testTree xs = fromList [(x,x*x*30696 `mod` 65521) | x <- xs]-test1 = testTree [1..20]-test2 = testTree [30,29..10]-test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]--{--------------------------------------------------------------------- QuickCheck---------------------------------------------------------------------}-qcheck prop- = check config prop+foldlStrict :: (a -> b -> a) -> a -> [b] -> a+foldlStrict f = go where- config = Config- { configMaxTest = 500- , configMaxFail = 5000- , configSize = \n -> (div n 2 + 3)- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]- }---{--------------------------------------------------------------------- Arbitrary, reasonably balanced trees---------------------------------------------------------------------}-instance Arbitrary a => Arbitrary (IntMap a) where- arbitrary = do{ ks <- arbitrary- ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks- ; return (fromList xs)- }---{--------------------------------------------------------------------- Single, Insert, Delete---------------------------------------------------------------------}-prop_Single :: Key -> Int -> Bool-prop_Single k x- = (insert k x empty == singleton k x)--prop_InsertDelete :: Key -> Int -> IntMap Int -> Property-prop_InsertDelete k x t- = not (member k t) ==> delete k (insert k x t) == t--prop_UpdateDelete :: Key -> IntMap Int -> Bool -prop_UpdateDelete k t- = update (const Nothing) k t == delete k t---{--------------------------------------------------------------------- Union---------------------------------------------------------------------}-prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool-prop_UnionInsert k x t- = union (singleton k x) t == insert k x t--prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool-prop_UnionAssoc t1 t2 t3- = union t1 (union t2 t3) == union (union t1 t2) t3--prop_UnionComm :: IntMap Int -> IntMap Int -> Bool-prop_UnionComm t1 t2- = (union t1 t2 == unionWith (\x y -> y) t2 t1)---prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool-prop_Diff xs ys- = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys))) - == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))--prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool-prop_Int xs ys- = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys))) - == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))--{--------------------------------------------------------------------- Lists---------------------------------------------------------------------}-prop_Ordered- = forAll (choose (5,100)) $ \n ->- let xs = concat [[(x-n,()),(x-n,())] | x <- [0..2*n::Int]] - in fromAscList xs == fromList xs--prop_List :: [Key] -> Bool-prop_List xs- = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])---{--------------------------------------------------------------------- updateMin / updateMax ---------------------------------------------------------------------}-prop_UpdateMinMax :: [Key] -> Bool-prop_UpdateMinMax xs =- let m = fromList [(x,0)|x<-xs]- minKey = fst . head . Prelude.filter ((==1).snd) . assocs . updateMin succ $ m- maxKey = fst . head . Prelude.filter ((==1).snd) . assocs . updateMax succ $ m- in all (>=minKey) xs && all (<=maxKey) xs---}+ go z [] = z+ go z (x:xs) = z `seq` go (f z x) xs
Data/IntSet.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS -cpp #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-} ----------------------------------------------------------------------------- -- | -- Module : Data.IntSet
Data/Map.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -XNoBangPatterns #-} -----------------------------------------------------------------------------@@ -22,12 +23,12 @@ -- trees of /bounded balance/) as described by: -- -- * Stephen Adams, \"/Efficient sets: a balancing act/\",--- Journal of Functional Programming 3(4):553-562, October 1993,--- <http://www.swiss.ai.mit.edu/~adams/BB/>.+-- Journal of Functional Programming 3(4):553-562, October 1993,+-- <http://www.swiss.ai.mit.edu/~adams/BB/>. -- -- * J. Nievergelt and E.M. Reingold,--- \"/Binary search trees of bounded balance/\",--- SIAM journal of computing 2(1), March 1973.+-- \"/Binary search trees of bounded balance/\",+-- SIAM journal of computing 2(1), March 1973. -- -- Note that the implementation is /left-biased/ -- the elements of a -- first argument are always preferred to the second, for example in@@ -39,12 +40,15 @@ module Data.Map ( -- * Map type- Map -- instance Eq,Show,Read+#if !defined(TESTING)+ Map -- instance Eq,Show,Read+#else+ Map(..) -- instance Eq,Show,Read+#endif -- * Operators , (!), (\\) - -- * Query , null , size@@ -59,8 +63,12 @@ -- ** Insertion , insert- , insertWith, insertWithKey, insertLookupWithKey- , insertWith', insertWithKey'+ , insertWith+ , insertWith'+ , insertWithKey+ , insertWithKey'+ , insertLookupWithKey+ , insertLookupWithKey' -- ** Delete\/Update , delete@@ -78,7 +86,7 @@ , unionWith , unionWithKey , unions- , unionsWith+ , unionsWith -- ** Difference , difference@@ -106,6 +114,7 @@ , foldWithKey , foldrWithKey , foldlWithKey+ -- , foldlWithKey' -- * Conversion , elems@@ -172,6 +181,15 @@ , showTree , showTreeWith , valid++#if defined(TESTING)+ -- * Internals+ , bin+ , balanced+ , join+ , merge+#endif+ ) where import Prelude hiding (lookup,map,filter,null)@@ -187,14 +205,6 @@ #endif import Data.Typeable (Typeable2(..), TyCon, mkTyCon, mkTyConApp) -{---- for quick check-import qualified Prelude-import qualified List-import Debug.QuickCheck -import List(nub,sort) --}- #if __GLASGOW_HASKELL__ import Text.Read import Data.Data (Data(..), mkNoRepType, gcast2)@@ -259,10 +269,8 @@ -- > Data.Map.null (singleton 1 'a') == False null :: Map k a -> Bool-null t- = case t of- Tip -> True- Bin {} -> False+null Tip = True+null (Bin {}) = False -- | /O(1)/. The number of elements in the map. --@@ -271,10 +279,8 @@ -- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3 size :: Map k a -> Int-size t- = case t of- Tip -> 0- Bin sz _ _ _ _ -> sz+size Tip = 0+size (Bin sz _ _ _ _) = sz -- | /O(log n)/. Lookup the value at a key in the map.@@ -307,24 +313,24 @@ -- > Pete's currency: Nothing lookup :: Ord k => k -> Map k a -> Maybe a-lookup k t- = case t of- Tip -> Nothing- Bin _ kx x l r- -> case compare k kx of- LT -> lookup k l- GT -> lookup k r- EQ -> Just x +lookup k = k `seq` go+ where+ go Tip = Nothing+ go (Bin _ kx x l r) =+ case compare k kx of+ LT -> go l+ GT -> go r+ EQ -> Just x lookupAssoc :: Ord k => k -> Map k a -> Maybe (k,a)-lookupAssoc k t- = case t of- Tip -> Nothing- Bin _ kx x l r- -> case compare k kx of- LT -> lookupAssoc k l- GT -> lookupAssoc k r- EQ -> Just (kx,x)+lookupAssoc k = k `seq` go+ where+ go Tip = Nothing+ go (Bin _ kx x l r) =+ case compare k kx of+ LT -> go l+ GT -> go r+ EQ -> Just (kx,x) -- | /O(log n)/. Is the key a member of the map? See also 'notMember'. --@@ -332,10 +338,9 @@ -- > member 1 (fromList [(5,'a'), (3,'b')]) == False member :: Ord k => k -> Map k a -> Bool-member k m- = case lookup k m of- Nothing -> False- Just _ -> True+member k m = case lookup k m of+ Nothing -> False+ Just _ -> True -- | /O(log n)/. Is the key not a member of the map? See also 'member'. --@@ -347,11 +352,11 @@ -- | /O(log n)/. Find the value at a key. -- Calls 'error' when the element can not be found.+-- Consider using 'lookup' when elements may not be present. find :: Ord k => k -> Map k a -> a-find k m- = case lookup k m of- Nothing -> error "Map.find: element not in the map"- Just x -> x+find k m = case lookup k m of+ Nothing -> error "Map.find: element not in the map"+ Just x -> x -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns -- the value at key @k@ or returns default value @def@@@ -361,12 +366,9 @@ -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a' findWithDefault :: Ord k => a -> k -> Map k a -> a-findWithDefault def k m- = case lookup k m of- Nothing -> def- Just x -> x--+findWithDefault def k m = case lookup k m of+ Nothing -> def+ Just x -> x {-------------------------------------------------------------------- Construction@@ -377,8 +379,7 @@ -- > size empty == 0 empty :: Map k a-empty - = Tip+empty = Tip -- | /O(1)/. A map with a single element. --@@ -386,8 +387,7 @@ -- > size (singleton 1 'a') == 1 singleton :: k -> a -> Map k a-singleton k x - = Bin 1 k x Tip Tip+singleton k x = Bin 1 k x Tip Tip {-------------------------------------------------------------------- Insertion@@ -402,14 +402,14 @@ -- > insert 5 'x' empty == singleton 5 'x' insert :: Ord k => k -> a -> Map k a -> Map k a-insert kx x t- = case t of- Tip -> singleton kx x- Bin sz ky y l r- -> case compare kx ky of- LT -> balance ky y (insert kx x l) r- GT -> balance ky y l (insert kx x r)- EQ -> Bin sz kx x l r+insert kx x = kx `seq` go+ where+ go Tip = singleton kx x+ go (Bin sz ky y l r) =+ case compare kx ky of+ LT -> balance ky y (go l) r+ GT -> balance ky y l (go r)+ EQ -> Bin sz kx x l r -- | /O(log n)/. Insert with a function, combining new value and old value. -- @'insertWith' f key value mp@ @@ -422,14 +422,17 @@ -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx" insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWith f k x m - = insertWithKey (\_ x' y' -> f x' y') k x m+insertWith f = insertWithKey (\_ x' y' -> f x' y') -- | Same as 'insertWith', but the combining function is applied strictly.+-- This is often the most desirable behavior.+--+-- For example, to update a counter:+--+-- > insertWith' (+) k 1 m+-- insertWith' :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWith' f k x m - = insertWithKey' (\_ x' y' -> f x' y') k x m-+insertWith' f = insertWithKey' (\_ x' y' -> f x' y') -- | /O(log n)/. Insert with a function, combining key, new value and old value. -- @'insertWithKey' f key value mp@ @@ -444,26 +447,25 @@ -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithKey f kx x t- = case t of- Tip -> singleton kx x- Bin sy ky y l r- -> case compare kx ky of- LT -> balance ky y (insertWithKey f kx x l) r- GT -> balance ky y l (insertWithKey f kx x r)- EQ -> Bin sy kx (f kx x y) l r+insertWithKey f kx x = kx `seq` go+ where+ go Tip = singleton kx x+ go (Bin sy ky y l r) =+ case compare kx ky of+ LT -> balance ky y (go l) r+ GT -> balance ky y l (go r)+ EQ -> Bin sy kx (f kx x y) l r -- | Same as 'insertWithKey', but the combining function is applied strictly. insertWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithKey' f kx x t- = case t of- Tip -> singleton kx x- Bin sy ky y l r- -> case compare kx ky of- LT -> balance ky y (insertWithKey' f kx x l) r- GT -> balance ky y l (insertWithKey' f kx x r)- EQ -> let x' = f kx x y in seq x' (Bin sy kx x' l r)-+insertWithKey' f kx x = kx `seq` go+ where+ go Tip = singleton kx $! x+ go (Bin sy ky y l r) =+ case compare kx ky of+ LT -> balance ky y (go l) r+ GT -> balance ky y l (go r)+ EQ -> let x' = f kx x y in seq x' (Bin sy kx x' l r) -- | /O(log n)/. Combines insert operation with old value retrieval. -- The expression (@'insertLookupWithKey' f k x map@)@@ -481,16 +483,33 @@ -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")]) -insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)-insertLookupWithKey f kx x t- = case t of- Tip -> (Nothing, singleton kx x)- Bin sy ky y l r- -> case compare kx ky of- LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)- GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')- EQ -> (Just y, Bin sy kx (f kx x y) l r)+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a+ -> (Maybe a, Map k a)+insertLookupWithKey f kx x = kx `seq` go+ where+ go Tip = (Nothing, singleton kx x)+ go (Bin sy ky y l r) =+ case compare kx ky of+ LT -> let (found, l') = go l+ in (found, balance ky y l' r)+ GT -> let (found, r') = go r+ in (found, balance ky y l r')+ EQ -> (Just y, Bin sy kx (f kx x y) l r) +-- | /O(log n)/. A strict version of 'insertLookupWithKey'.+insertLookupWithKey' :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a+ -> (Maybe a, Map k a)+insertLookupWithKey' f kx x = kx `seq` go+ where+ go Tip = x `seq` (Nothing, singleton kx x)+ go (Bin sy ky y l r) =+ case compare kx ky of+ LT -> let (found, l') = go l+ in (found, balance ky y l' r)+ GT -> let (found, r') = go r+ in (found, balance ky y l r')+ EQ -> let x' = f kx x y in x' `seq` (Just y, Bin sy kx x' l r)+ {-------------------------------------------------------------------- Deletion [delete] is the inlined version of [deleteWith (\k x -> Nothing)]@@ -503,14 +522,14 @@ -- > delete 5 empty == empty delete :: Ord k => k -> Map k a -> Map k a-delete k t- = case t of- Tip -> Tip- Bin _ kx x l r- -> case compare k kx of- LT -> balance kx x (delete k l) r- GT -> balance kx x l (delete k r)- EQ -> glue l r+delete k = k `seq` go+ where+ go Tip = Tip+ go (Bin _ kx x l r) =+ case compare k kx of+ LT -> balance kx x (go l) r+ GT -> balance kx x l (go r)+ EQ -> glue l r -- | /O(log n)/. Update a value at a specific key with the result of the provided function. -- When the key is not@@ -521,8 +540,7 @@ -- > adjust ("new " ++) 7 empty == empty adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a-adjust f k m- = adjustWithKey (\_ x -> f x) k m+adjust f = adjustWithKey (\_ x -> f x) -- | /O(log n)/. Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned.@@ -533,8 +551,7 @@ -- > adjustWithKey f 7 empty == empty adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a-adjustWithKey f k m- = updateWithKey (\k' x' -> Just (f k' x')) k m+adjustWithKey f = updateWithKey (\k' x' -> Just (f k' x')) -- | /O(log n)/. 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@@ -546,8 +563,7 @@ -- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a-update f k m- = updateWithKey (\_ x -> f x) k m+update f = updateWithKey (\_ x -> f x) -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',@@ -560,16 +576,16 @@ -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a-updateWithKey f k t- = case t of- Tip -> Tip- Bin sx kx x l r - -> case compare k kx of- LT -> balance kx x (updateWithKey f k l) r- GT -> balance kx x l (updateWithKey f k r)- EQ -> case f kx x of- Just x' -> Bin sx kx x' l r- Nothing -> glue l r+updateWithKey f k = k `seq` go+ where+ go Tip = Tip+ go (Bin sx kx x l r) =+ case compare k kx of+ LT -> balance kx x (go l) r+ GT -> balance kx x l (go r)+ EQ -> case f kx x of+ Just x' -> Bin sx kx x' l r+ Nothing -> glue l r -- | /O(log n)/. Lookup and update. See also 'updateWithKey'. -- The function returns changed value, if it is updated.@@ -581,13 +597,13 @@ -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a") updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)-updateLookupWithKey f k t- = case t of- Tip -> (Nothing,Tip)- Bin sx kx x l r - -> case compare k kx of- LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)- GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r') +updateLookupWithKey f k = k `seq` go+ where+ go Tip = (Nothing,Tip)+ go (Bin sx kx x l r) =+ case compare k kx of+ LT -> let (found,l') = go l in (found,balance kx x l' r)+ GT -> let (found,r') = go r in (found,balance kx x l r') EQ -> case f kx x of Just x' -> (Just x',Bin sx kx x' l r) Nothing -> (Just x,glue l r)@@ -605,15 +621,15 @@ -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")] alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a-alter f k t- = case t of- Tip -> case f Nothing of+alter f k = k `seq` go+ where+ go Tip = case f Nothing of Nothing -> Tip- Just x -> singleton k x- Bin sx kx x l r - -> case compare k kx of- LT -> balance kx x (alter f k l) r- GT -> balance kx x l (alter f k r)+ Just x -> singleton k x++ go (Bin sx kx x l r) = case compare k kx of+ LT -> balance kx x (go l) r+ GT -> balance kx x l (go r) EQ -> case f (Just x) of Just x' -> Bin sx kx x' l r Nothing -> glue l r@@ -645,13 +661,13 @@ -- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")])) == False lookupIndex :: Ord k => k -> Map k a -> Maybe Int-lookupIndex k t = f 0 t+lookupIndex k = k `seq` go 0 where- f _ Tip = Nothing- f idx (Bin _ kx _ l r)- = case compare k kx of- LT -> f idx l- GT -> f (idx + size l + 1) r + go idx Tip = idx `seq` Nothing+ go idx (Bin _ kx _ l r)+ = idx `seq` case compare k kx of+ LT -> go idx l+ GT -> go (idx + size l + 1) r EQ -> Just (idx + size l) -- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an@@ -684,16 +700,17 @@ -- > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a-updateAt _ _ Tip = error "Map.updateAt: index out of range"-updateAt f i (Bin sx kx x l r)- = case compare i sizeL of- LT -> balance kx x (updateAt f i l) r- GT -> balance kx x l (updateAt f (i-sizeL-1) r)+updateAt f i0 t = i0 `seq` go i0 t+ where+ go _ Tip = error "Map.updateAt: index out of range"+ go i (Bin sx kx x l r) = case compare i sizeL of+ LT -> balance kx x (go i l) r+ GT -> balance kx x l (go (i-sizeL-1) r) EQ -> case f kx x of Just x' -> Bin sx kx x' l r Nothing -> glue l r- where- sizeL = size l+ where + sizeL = size l -- | /O(log n)/. Delete the element at /index/. -- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).@@ -776,13 +793,13 @@ -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a-updateMinWithKey f t- = case t of- Bin sx kx x Tip r -> case f kx x of- Nothing -> r- Just x' -> Bin sx kx x' Tip r- Bin _ kx x l r -> balance kx x (updateMinWithKey f l) r- Tip -> Tip+updateMinWithKey f = go+ where+ go (Bin sx kx x Tip r) = case f kx x of+ Nothing -> r+ Just x' -> Bin sx kx x' Tip r+ go (Bin _ kx x l r) = balance kx x (go l) r+ go Tip = Tip -- | /O(log n)/. Update the value at the maximal key. --@@ -790,13 +807,13 @@ -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a-updateMaxWithKey f t- = case t of- Bin sx kx x l Tip -> case f kx x of+updateMaxWithKey f = go+ where+ go (Bin sx kx x l Tip) = case f kx x of Nothing -> l Just x' -> Bin sx kx x' l Tip- Bin _ kx x l r -> balance kx x l (updateMaxWithKey f r)- Tip -> Tip+ go (Bin _ kx x l r) = balance kx x l (go r)+ go Tip = Tip -- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and -- the map stripped of that element, or 'Nothing' if passed an empty map.@@ -806,7 +823,7 @@ minViewWithKey :: Map k a -> Maybe ((k,a), Map k a) minViewWithKey Tip = Nothing-minViewWithKey x = Just (deleteFindMin x)+minViewWithKey x = Just (deleteFindMin x) -- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and -- the map stripped of that element, or 'Nothing' if passed an empty map.@@ -816,7 +833,7 @@ maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a) maxViewWithKey Tip = Nothing-maxViewWithKey x = Just (deleteFindMax x)+maxViewWithKey x = Just (deleteFindMax x) -- | /O(log n)/. Retrieves the value associated with minimal key of the -- map, and the map stripped of that element, or 'Nothing' if passed an@@ -827,7 +844,7 @@ minView :: Map k a -> Maybe (a, Map k a) minView Tip = Nothing-minView x = Just (first snd $ deleteFindMin x)+minView x = Just (first snd $ deleteFindMin x) -- | /O(log n)/. Retrieves the value associated with maximal key of the -- map, and the map stripped of that element, or 'Nothing' if passed an@@ -837,7 +854,7 @@ maxView :: Map k a -> Maybe (a, Map k a) maxView Tip = Nothing-maxView x = Just (first snd $ deleteFindMax x)+maxView x = Just (first snd $ deleteFindMax x) -- Update the 1st component of a tuple (special case of Control.Arrow.first) first :: (a -> b) -> (a,c) -> (b,c)@@ -896,29 +913,6 @@ where cmpkx k = compare kx k -{--XXX unused code---- right-biased hedge union-hedgeUnionR :: Ord a- => (a -> Ordering) -> (a -> Ordering) -> Map a b -> Map a b- -> Map a b-hedgeUnionR _ _ t1 Tip- = t1-hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)- = join kx x (filterGt cmplo l) (filterLt cmphi r)-hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2- = join kx newx (hedgeUnionR cmplo cmpkx l lt) - (hedgeUnionR cmpkx cmphi r gt)- where- cmpkx k = compare kx k- lt = trim cmplo cmpkx t2- (found,gt) = trimLookupLo kx cmphi t2- newx = case found of- Nothing -> x- Just (_,y) -> y--}- {-------------------------------------------------------------------- Union with a combining function --------------------------------------------------------------------}@@ -1114,8 +1108,7 @@ -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). -- isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool-isSubmapOf m1 m2- = isSubmapOfBy (==) m1 m2+isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2 {- | /O(n+m)/. The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if@@ -1195,11 +1188,12 @@ -- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a-filterWithKey _ Tip = Tip-filterWithKey p (Bin _ kx x l r)- | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)- | otherwise = merge (filterWithKey p l) (filterWithKey p r)-+filterWithKey p = go+ where+ go Tip = Tip+ go (Bin _ kx x l r)+ | p kx x = join kx x (go l) (go r)+ | otherwise = merge (go l) (go r) -- | /O(n)/. Partition the map according to a predicate. The first -- map contains all elements that satisfy the predicate, the second all@@ -1236,8 +1230,7 @@ -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a" mapMaybe :: Ord k => (a -> Maybe b) -> Map k a -> Map k b-mapMaybe f m- = mapMaybeWithKey (\_ x -> f x) m+mapMaybe f = mapMaybeWithKey (\_ x -> f x) -- | /O(n)/. Map keys\/values and collect the 'Just' results. --@@ -1245,10 +1238,12 @@ -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> Map k a -> Map k b-mapMaybeWithKey _ Tip = Tip-mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of- Just y -> join kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)- Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f = go+ where+ go Tip = Tip+ go (Bin _ kx x l r) = case f kx x of+ Just y -> join kx y (go l) (go r)+ Nothing -> merge (go l) (go r) -- | /O(n)/. Map values and separate the 'Left' and 'Right' results. --@@ -1278,7 +1273,7 @@ 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+ where (l1,l2) = mapEitherWithKey f l (r1,r2) = mapEitherWithKey f r @@ -1290,8 +1285,7 @@ -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] map :: (a -> b) -> Map k a -> Map k b-map f m- = mapWithKey (\_ x -> f x) m+map f = mapWithKey (\_ x -> f x) -- | /O(n)/. Map a function over all values in the map. --@@ -1299,9 +1293,10 @@ -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")] mapWithKey :: (k -> a -> b) -> Map k a -> Map k b-mapWithKey _ Tip = Tip-mapWithKey f (Bin sx kx x l r) - = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)+mapWithKey f = go+ where+ go Tip = Tip+ go (Bin sx kx x l r) = Bin sx kx (f kx x) (go l) (go r) -- | /O(n)/. The function 'mapAccum' threads an accumulating -- argument through the map in ascending order of keys.@@ -1326,26 +1321,26 @@ -- | /O(n)/. The function 'mapAccumL' threads an accumulating -- argument throught the map in ascending order of keys. mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumL f a t- = case t of- Tip -> (a,Tip)- Bin sx kx x l r- -> let (a1,l') = mapAccumL f a l- (a2,x') = f a1 kx x- (a3,r') = mapAccumL f a2 r- in (a3,Bin sx kx x' l' r')+mapAccumL f = go+ where+ go a Tip = (a,Tip)+ go a (Bin sx kx x l r) =+ let (a1,l') = go a l+ (a2,x') = f a1 kx x+ (a3,r') = go a2 r+ in (a3,Bin sx kx x' l' r') -- | /O(n)/. The function 'mapAccumR' threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumRWithKey f a t- = case t of- Tip -> (a,Tip)- Bin sx kx x l r - -> let (a1,r') = mapAccumRWithKey f a r- (a2,x') = f a1 kx x- (a3,l') = mapAccumRWithKey f a2 l- in (a3,Bin sx kx x' l' r')+mapAccumRWithKey f = go+ where+ go a Tip = (a,Tip)+ go a (Bin sx kx x l r) =+ let (a1,r') = go a r+ (a2,x') = f a1 kx x+ (a3,l') = go a2 l+ in (a3,Bin sx kx x' l' r') -- | /O(n*log n)/. -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.@@ -1411,10 +1406,8 @@ -- -- > let f a len = len + (length a) -- > fold f 0 (fromList [(5,"a"), (3,"bbb")]) == 4- fold :: (a -> b -> b) -> b -> Map k a -> b-fold f z m- = foldWithKey (\_ x' z' -> f x' z') z m+fold f = foldWithKey (\_ x' z' -> f x' z') -- | /O(n)/. Fold the keys and values in the map, such that -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.@@ -1427,35 +1420,35 @@ -- -- This is identical to 'foldrWithKey', and you should use that one instead of -- this one. This name is kept for backward compatibility.- foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b-foldWithKey f z t- = foldrWithKey f z t--{--XXX unused code---- | /O(n)/. In-order fold.-foldi :: (k -> a -> b -> b -> b) -> b -> Map k a -> b -foldi _ z Tip = z-foldi f z (Bin _ kx x l r) = f kx x (foldi f z l) (foldi f z r)--}+foldWithKey = foldrWithKey+{-# DEPRECATED foldWithKey "Use foldrWithKey instead" #-} -- | /O(n)/. Post-order fold. The function will be applied from the lowest -- value to the highest. foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b-foldrWithKey _ z Tip = z-foldrWithKey f z (Bin _ kx x l r) =- foldrWithKey f (f kx x (foldrWithKey f z r)) l-+foldrWithKey f = go+ where+ go z Tip = z+ go z (Bin _ kx x l r) = go (f kx x (go z r)) l -- | /O(n)/. Pre-order fold. The function will be applied from the highest -- value to the lowest. foldlWithKey :: (b -> k -> a -> b) -> b -> Map k a -> b-foldlWithKey _ z Tip = z-foldlWithKey f z (Bin _ kx x l r) =- foldlWithKey f (f (foldlWithKey f z l) kx x) r+foldlWithKey f = go+ where+ go z Tip = z+ go z (Bin _ kx x l r) = go (f (go z l) kx x) r +{-+-- | /O(n)/. A strict version of 'foldlWithKey'.+foldlWithKey' :: (b -> k -> a -> b) -> b -> Map k a -> b+foldlWithKey' f = go+ where+ go z Tip = z+ go z (Bin _ kx x l r) = z `seq` go (f (go z l) kx x) r+-}+ {-------------------------------------------------------------------- List variations --------------------------------------------------------------------}@@ -1685,20 +1678,22 @@ [filterLt k t] filter all keys <[k] from tree [t] --------------------------------------------------------------------} filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a-filterGt _ Tip = Tip-filterGt cmp (Bin _ kx x l r)- = case cmp kx of- LT -> join kx x (filterGt cmp l) r- GT -> filterGt cmp r- EQ -> r- +filterGt cmp = go+ where+ go Tip = Tip+ go (Bin _ kx x l r) = case cmp kx of+ LT -> join kx x (go l) r+ GT -> go r+ EQ -> r+ filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a-filterLt _ Tip = Tip-filterLt cmp (Bin _ kx x l r)- = case cmp kx of- LT -> filterLt cmp l- GT -> join kx x l (filterLt cmp r)- EQ -> l+filterLt cmp = go+ where+ go Tip = Tip+ go (Bin _ kx x l r) = case cmp kx of+ LT -> go l+ GT -> join kx x l (go r)+ EQ -> l {-------------------------------------------------------------------- Split@@ -1714,12 +1709,13 @@ -- > 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 _ Tip = (Tip,Tip)-split k (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 k = go+ where+ go Tip = (Tip, Tip)+ go (Bin _ kx x l r) = case compare k kx of+ LT -> let (lt,gt) = go l in (lt,join kx x gt r)+ GT -> let (lt,gt) = go r in (join kx x l lt,gt)+ EQ -> (l,r) -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just -- like 'split' but also returns @'lookup' k map@.@@ -1731,32 +1727,24 @@ -- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty) splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)-splitLookup _ Tip = (Tip,Nothing,Tip)-splitLookup k (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)+splitLookup k = go+ where+ go Tip = (Tip,Nothing,Tip)+ go (Bin _ kx x l r) = case compare k kx of+ LT -> let (lt,z,gt) = go l in (lt,z,join kx x gt r)+ GT -> let (lt,z,gt) = go r in (join kx x l lt,z,gt) EQ -> (l,Just x,r) -- | /O(log n)/. splitLookupWithKey :: Ord k => k -> Map k a -> (Map k a,Maybe (k,a),Map k a)-splitLookupWithKey _ Tip = (Tip,Nothing,Tip)-splitLookupWithKey k (Bin _ kx x l r)- = case compare k kx of- LT -> let (lt,z,gt) = splitLookupWithKey k l in (lt,z,join kx x gt r)- GT -> let (lt,z,gt) = splitLookupWithKey k r in (join kx x l lt,z,gt)+splitLookupWithKey k = go+ where+ go Tip = (Tip,Nothing,Tip)+ go (Bin _ kx x l r) = case compare k kx of+ LT -> let (lt,z,gt) = go l in (lt,z,join kx x gt r)+ GT -> let (lt,z,gt) = go r in (join kx x l lt,z,gt) EQ -> (l,Just (kx, x),r) -{--XXX unused code---- | /O(log n)/. Performs a 'split' but also returns whether the pivot--- element was found in the original set.-splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)-splitMember x t = let (l,m,r) = splitLookup x t in- (l,maybe False (const True) m,r)--}- {-------------------------------------------------------------------- Utility functions that maintain the balance properties of the tree. All constructors assume that all values in [l] < [k] and all values@@ -1891,7 +1879,7 @@ invariants, his implementation uses an invalid ratio of [1]. --------------------------------------------------------------------} delta,ratio :: Int-delta = 5+delta = 4 ratio = 2 balance :: k -> a -> Map k a -> Map k a -> Map k a@@ -1989,17 +1977,6 @@ return (fromList xs,t) #endif -{--XXX unused code---- parses a pair of things with the syntax a:=b-readPair :: (Read a, Read b) => ReadS (a,b)-readPair s = do (a, ct1) <- reads s- (":=", ct2) <- lex ct1- (b, ct3) <- reads ct2- return ((a,b), ct3)--}- {-------------------------------------------------------------------- Show --------------------------------------------------------------------}@@ -2007,21 +1984,6 @@ showsPrec d m = showParen (d > 10) $ showString "fromList " . shows (toList m) -{--XXX unused code--showMap :: (Show k,Show a) => [(k,a)] -> ShowS-showMap [] - = showString "{}" -showMap (x:xs) - = showChar '{' . showElem x . showTail xs- where- showTail [] = showChar '}'- showTail (x':xs') = showString ", " . showElem x' . showTail xs'- - showElem (k,x') = shows k . showString " := " . shows x'--}- -- | /O(n)/. Show the tree that implements the map. The tree is shown -- in a compressed, hanging format. See 'showTreeWith'. showTree :: (Show k,Show a) => Map k a -> String@@ -2167,180 +2129,9 @@ Utilities --------------------------------------------------------------------} foldlStrict :: (a -> b -> a) -> a -> [b] -> a-foldlStrict f z xs- = case xs of- [] -> z- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)---{--{--------------------------------------------------------------------- Testing---------------------------------------------------------------------}-testTree xs = fromList [(x,"*") | x <- xs]-test1 = testTree [1..20]-test2 = testTree [30,29..10]-test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]--{--------------------------------------------------------------------- QuickCheck---------------------------------------------------------------------}-qcheck prop- = check config prop+foldlStrict f = go where- config = Config- { configMaxTest = 500- , configMaxFail = 5000- , configSize = \n -> (div n 2 + 3)- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]- }---{--------------------------------------------------------------------- Arbitrary, reasonably balanced trees---------------------------------------------------------------------}-instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where- arbitrary = sized (arbtree 0 maxkey)- where maxkey = 10000--arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)-arbtree lo hi n- | n <= 0 = return Tip- | lo >= hi = return Tip- | otherwise = do{ x <- arbitrary - ; i <- choose (lo,hi)- ; m <- choose (1,30)- ; let (ml,mr) | m==(1::Int)= (1,2)- | m==2 = (2,1)- | m==3 = (1,1)- | otherwise = (2,2)- ; l <- arbtree lo (i-1) (n `div` ml)- ; r <- arbtree (i+1) hi (n `div` mr)- ; return (bin (toEnum i) x l r)- } ---{--------------------------------------------------------------------- Valid tree's---------------------------------------------------------------------}-forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property-forValid f- = forAll arbitrary $ \t -> --- classify (balanced t) "balanced" $- classify (size t == 0) "empty" $- classify (size t > 0 && size t <= 10) "small" $- classify (size t > 10 && size t <= 64) "medium" $- classify (size t > 64) "large" $- balanced t ==> f t--forValidIntTree :: Testable a => (Map Int Int -> a) -> Property-forValidIntTree f- = forValid f--forValidUnitTree :: Testable a => (Map Int () -> a) -> Property-forValidUnitTree f- = forValid f---prop_Valid - = forValidUnitTree $ \t -> valid t--{--------------------------------------------------------------------- Single, Insert, Delete---------------------------------------------------------------------}-prop_Single :: Int -> Int -> Bool-prop_Single k x- = (insert k x empty == singleton k x)--prop_InsertValid :: Int -> Property-prop_InsertValid k- = forValidUnitTree $ \t -> valid (insert k () t)--prop_InsertDelete :: Int -> Map Int () -> Property-prop_InsertDelete k t- = (lookup k t == Nothing) ==> delete k (insert k () t) == t--prop_DeleteValid :: Int -> Property-prop_DeleteValid k- = forValidUnitTree $ \t -> - valid (delete k (insert k () t))--{--------------------------------------------------------------------- Balance---------------------------------------------------------------------}-prop_Join :: Int -> Property -prop_Join k - = forValidUnitTree $ \t ->- let (l,r) = split k t- in valid (join k () l r)--prop_Merge :: Int -> Property -prop_Merge k- = forValidUnitTree $ \t ->- let (l,r) = split k t- in valid (merge l r)+ go z [] = z+ go z (x:xs) = z `seq` go (f z x) xs -{--------------------------------------------------------------------- Union---------------------------------------------------------------------}-prop_UnionValid :: Property-prop_UnionValid- = forValidUnitTree $ \t1 ->- forValidUnitTree $ \t2 ->- valid (union t1 t2)--prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool-prop_UnionInsert k x t- = union (singleton k x) t == insert k x t--prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool-prop_UnionAssoc t1 t2 t3- = union t1 (union t2 t3) == union (union t1 t2) t3--prop_UnionComm :: Map Int Int -> Map Int Int -> Bool-prop_UnionComm t1 t2- = (union t1 t2 == unionWith (\x y -> y) t2 t1)--prop_UnionWithValid - = forValidIntTree $ \t1 ->- forValidIntTree $ \t2 ->- valid (unionWithKey (\k x y -> x+y) t1 t2)--prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_UnionWith xs ys- = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys))) - == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))--prop_DiffValid- = forValidUnitTree $ \t1 ->- forValidUnitTree $ \t2 ->- valid (difference t1 t2)--prop_Diff :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_Diff xs ys- = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys))) - == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))--prop_IntValid- = forValidUnitTree $ \t1 ->- forValidUnitTree $ \t2 ->- valid (intersection t1 t2)--prop_Int :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_Int xs ys- = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys))) - == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))--{--------------------------------------------------------------------- Lists---------------------------------------------------------------------}-prop_Ordered- = forAll (choose (5,100)) $ \n ->- let xs = [(x,()) | x <- [0..n::Int]] - in fromAscList xs == fromList xs--prop_List :: [Int] -> Bool-prop_List xs- = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])--}
Data/Sequence.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS -cpp #-} ----------------------------------------------------------------------------- -- |@@ -169,7 +170,9 @@ instance Functor Seq where fmap f (Seq xs) = Seq (fmap (fmap f) xs)+#ifdef __GLASGOW_HASKELL__ x <$ s = replicate (length s) x+#endif instance Foldable Seq where foldr f z (Seq xs) = foldr (flip (foldr f)) z xs@@ -517,7 +520,7 @@ {-# SPECIALIZE applicativeTree :: Int -> Int -> Id a -> Id (FingerTree a) #-} -- Special note: the Id specialization automatically does node sharing, -- reducing memory usage of the resulting tree to /O(log n)/.-applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)+applicativeTree :: forall f a. Applicative f => Int -> Int -> f a -> f (FingerTree a) applicativeTree n mSize m = mSize `seq` case n of 0 -> emptyTree 1 -> liftA Single m@@ -540,6 +543,8 @@ deepA = liftA3 (Deep (n * mSize)) mSize' = 3 * mSize n3 = liftA3 (Node3 mSize') m m m++ emptyTree :: forall b. f (FingerTree b) emptyTree = pure Empty ------------------------------------------------------------------------@@ -1442,7 +1447,7 @@ {-# INLINE breakr #-} -- | @'breakr' p@ is equivalent to @'spanr' (not . p)@. breakr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-breakr p xs = foldr (\ i _ -> flipPair (splitAt i xs)) (xs, empty) (findIndicesR p xs)+breakr p xs = foldr (\ i _ -> flipPair (splitAt (i + 1) xs)) (xs, empty) (findIndicesR p xs) where flipPair (x, y) = (y, x) -- | /O(n)/. The 'partition' function takes a predicate @p@ and a@@ -1500,8 +1505,8 @@ findIndicesL p xs = build (\ c n -> let g i x z = if p x then c i z else z in foldrWithIndex g n xs) #else-findIndicesL p xs = foldrWithIndex g [] xs where-g i x is = if p x then i:is else is+findIndicesL p xs = foldrWithIndex g [] xs+ where g i x is = if p x then i:is else is #endif {-# INLINE findIndicesR #-}@@ -1512,8 +1517,8 @@ findIndicesR p xs = build (\ c n -> let g z i x = if p x then c i z else z in foldlWithIndex g n xs) #else-findIndicesR p xs = foldlWithIndex g [] xs where-g is i x = if p x then i:is else is+findIndicesR p xs = foldlWithIndex g [] xs+ where g is i x = if p x then i:is else is #endif ------------------------------------------------------------------------@@ -1574,7 +1579,11 @@ -- like 'zipWith', but assumes length xs <= length ys zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith' f xs ys = snd (mapAccumL ((\ (z :< zs) x -> (zs, f x z)) . viewl) ys xs)+zipWith' f xs ys = snd (mapAccumL k ys xs)+ where+ k kys x = case viewl kys of+ (z :< zs) -> (zs, f x z)+ EmptyL -> error "zipWith': unexpected EmptyL" -- | /O(min(n1,n2,n3))/. 'zip3' takes three sequences and returns a -- sequence of triples, analogous to 'zip'.@@ -1679,7 +1688,10 @@ -- balanced Seq whose elements are that list using the applicativeTree -- generalization. fromList2 :: Int -> [a] -> Seq a-fromList2 n = execState (replicateA n (State (\ (x:xs) -> (xs, x))))+fromList2 n = execState (replicateA n (State ht))+ where+ ht (x:xs) = (xs, x)+ ht [] = error "fromList2: short list" -- | A 'PQueue' is a simple pairing heap. data PQueue e = PQueue e (PQL e)
containers.cabal view
@@ -1,5 +1,5 @@ name: containers-version: 0.3.0.0+version: 0.4.0.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org@@ -21,16 +21,22 @@ Library { build-depends: base >= 4.2 && < 6, array+ ghc-options: -O2+ if impl(ghc>6.10)+ Ghc-Options: -fregs-graph exposed-modules:- Data.Graph Data.IntMap Data.IntSet Data.Map- Data.Sequence Data.Set- Data.Tree include-dirs: include extensions: CPP+ if !impl(nhc98) {+ exposed-modules:+ Data.Graph+ Data.Sequence+ Data.Tree+ } if impl(ghc) { extensions: DeriveDataTypeable, MagicHash, Rank2Types }