containers 0.4.0.0 → 0.4.1.0
raw patch · 9 files changed
+5288/−4916 lines, 9 filesdep ~basePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Data.IntMap: insertWith' :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
+ Data.IntMap: insertWithKey' :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
+ Data.Map: foldlWithKey' :: (b -> k -> a -> b) -> b -> Map k a -> b
+ Data.Map: foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b
- Data.IntMap: alter :: (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
+ Data.IntMap: alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a
- Data.IntMap: findMax :: IntMap a -> (Int, a)
+ Data.IntMap: findMax :: IntMap a -> (Key, a)
- Data.IntMap: findMin :: IntMap a -> (Int, a)
+ Data.IntMap: findMin :: IntMap a -> (Key, a)
Files
- Data/Graph.hs +13/−14
- Data/IntMap.hs +226/−204
- Data/IntSet.hs +117/−216
- Data/Map.hs +2569/−2137
- Data/Sequence.hs +1851/−1843
- Data/Set.hs +433/−407
- Data/Tree.hs +55/−62
- containers.cabal +15/−14
- include/Typeable.h +9/−19
Data/Graph.hs view
@@ -69,10 +69,6 @@ import Data.Array import Data.List -#ifdef __HADDOCK__-import Prelude-#endif- ------------------------------------------------------------------------- -- - -- External interface@@ -320,12 +316,15 @@ -- Algorithm 1: depth first search numbering ------------------------------------------------------------ -preorder :: Tree a -> [a]-preorder (Node a ts) = a : preorderF ts+preorder' :: Tree a -> [a] -> [a]+preorder' (Node a ts) = (a :) . preorderF' ts -preorderF :: Forest a -> [a]-preorderF ts = concat (map preorder ts)+preorderF' :: Forest a -> [a] -> [a]+preorderF' ts = foldr (.) id $ map preorder' ts +preorderF :: Forest a -> [a]+preorderF ts = preorderF' ts []+ tabulate :: Bounds -> [Vertex] -> Table Int tabulate bnds vs = array bnds (zipWith (,) vs [1..]) @@ -336,14 +335,14 @@ -- Algorithm 2: topological sorting ------------------------------------------------------------ -postorder :: Tree a -> [a]-postorder (Node a ts) = postorderF ts ++ [a]+postorder :: Tree a -> [a] -> [a]+postorder (Node a ts) = postorderF ts . (a :) -postorderF :: Forest a -> [a]-postorderF ts = concat (map postorder ts)+postorderF :: Forest a -> [a] -> [a]+postorderF ts = foldr (.) id $ map postorder ts -postOrd :: Graph -> [Vertex]-postOrd = postorderF . dff+postOrd :: Graph -> [Vertex]+postOrd g = postorderF (dff g) [] -- | A topological sort of the graph. -- The order is partially specified by the condition that a vertex /i/
Data/IntMap.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# OPTIONS_GHC -cpp -XNoBangPatterns -XScopedTypeVariables #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, NoBangPatterns, MagicHash, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Data.IntMap@@ -42,7 +39,12 @@ -- (32 or 64). ----------------------------------------------------------------------------- -module Data.IntMap ( +-- It is essential that the bit fiddling functions like mask, zero, branchMask+-- etc are inlined. If they do not, the memory allocation skyrockets. The GHC+-- usually gets it right, but it is disastrous if it does not. Therefore we+-- explicitly mark these functions INLINE.++module Data.IntMap ( -- * Map type #if !defined(TESTING) IntMap, Key -- instance Eq,Show@@ -60,15 +62,19 @@ , notMember , lookup , findWithDefault- + -- * Construction , empty , singleton -- ** Insertion , insert- , insertWith, insertWithKey, insertLookupWithKey- + , insertWith+ , insertWith'+ , insertWithKey+ , insertWithKey'+ , insertLookupWithKey+ -- ** Delete\/Update , delete , adjust@@ -77,12 +83,12 @@ , updateWithKey , updateLookupWithKey , alter- + -- * Combine -- ** Union- , union - , unionWith + , union+ , unionWith , unionWithKey , unions , unionsWith@@ -91,9 +97,9 @@ , difference , differenceWith , differenceWithKey- + -- ** Intersection- , intersection + , intersection , intersectionWith , intersectionWithKey @@ -104,7 +110,7 @@ , mapAccum , mapAccumWithKey , mapAccumRWithKey- + -- ** Fold , fold , foldWithKey@@ -114,7 +120,7 @@ , keys , keysSet , assocs- + -- ** Lists , toList , fromList@@ -128,7 +134,7 @@ , fromAscListWithKey , fromDistinctAscList - -- * Filter + -- * Filter , filter , filterWithKey , partition@@ -139,18 +145,15 @@ , mapEither , mapEitherWithKey - , split - , splitLookup + , split+ , splitLookup -- * Submap , isSubmapOf, isSubmapOfBy , isProperSubmapOf, isProperSubmapOfBy- - -- * Min\/Max - , maxView- , minView- , findMin + -- * Min\/Max+ , findMin , findMax , deleteMin , deleteMax@@ -159,7 +162,9 @@ , updateMin , updateMax , updateMinWithKey- , updateMaxWithKey + , updateMaxWithKey+ , minView+ , maxView , minViewWithKey , maxViewWithKey @@ -168,7 +173,6 @@ , showTreeWith ) where - import Prelude hiding (lookup,map,filter,foldr,foldl,null) import Data.Bits import qualified Data.IntSet as IntSet@@ -208,9 +212,11 @@ natFromInt :: Key -> Nat natFromInt = fromIntegral+{-# INLINE natFromInt #-} intFromNat :: Nat -> Key intFromNat = fromIntegral+{-# INLINE intFromNat #-} shiftRL :: Nat -> Key -> Nat #if __GLASGOW_HASKELL__@@ -221,6 +227,7 @@ = W# (shiftRL# x i) #else shiftRL x i = shiftR x i+{-# INLINE shiftRL #-} #endif {--------------------------------------------------------------------@@ -234,7 +241,7 @@ -- > fromList [(5,'a'), (3,'b')] ! 5 == 'a' (!) :: IntMap a -> Key -> a-m ! k = find' k m+m ! k = find k m -- | Same as 'difference'. (\\) :: IntMap a -> IntMap b -> IntMap a@@ -328,25 +335,25 @@ notMember :: Key -> IntMap a -> Bool notMember k m = not $ member k m +-- The 'go' function in the lookup causes 10% speedup, but also an increased+-- memory allocation. It does not cause speedup with other methods like insert+-- and delete, so it is present only in lookup.+ -- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'. lookup :: Key -> IntMap a -> Maybe a-lookup k t- = let nk = natFromInt k in seq nk (lookupN nk t)+lookup k = k `seq` go+ where+ go (Bin _ m l r)+ | zero k m = go l+ | otherwise = go r+ go (Tip kx x)+ | k == kx = Just x+ | otherwise = Nothing+ go Nil = Nothing -lookupN :: Nat -> IntMap a -> Maybe a-lookupN k t- = case t of- Bin _ m l r - | zeroN k (natFromInt m) -> lookupN k l- | otherwise -> lookupN k r- Tip kx x - | (k == natFromInt kx) -> Just x- | otherwise -> Nothing- Nil -> Nothing--- ^ inlining lookup doesn't seem to help. -find' :: Key -> IntMap a -> a-find' k m+find :: Key -> IntMap a -> a+find k m = case lookup k m of Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map") Just x -> x@@ -398,16 +405,16 @@ -- > insert 5 'x' empty == singleton 5 'x' insert :: Key -> a -> IntMap a -> IntMap a-insert 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 (insert k x l) r- | otherwise -> Bin p m l (insert k x r)- Tip ky _- | k==ky -> Tip k x- | otherwise -> join k (Tip k x) ky t- Nil -> Tip k x+insert k x t = k `seq`+ case t of+ Bin p m l r+ | nomatch k p m -> join k (Tip k x) p t+ | zero k m -> Bin p m (insert k x l) r+ | otherwise -> Bin p m l (insert k x r)+ Tip ky _+ | k==ky -> Tip k x+ | otherwise -> join k (Tip k x) ky t+ Nil -> Tip k x -- right-biased insertion, used by 'union' -- | /O(min(n,W))/. Insert with a combining function.@@ -424,6 +431,11 @@ insertWith f k x t = insertWithKey (\_ x' y' -> f x' y') k x t +-- | Same as 'insertWith', but the combining function is applied strictly.+insertWith' :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWith' f k x t+ = insertWithKey' (\_ x' y' -> f x' y') k x t+ -- | /O(min(n,W))/. Insert with a combining function. -- @'insertWithKey' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does@@ -436,19 +448,29 @@ -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx" insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a-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+insertWithKey f k x t = k `seq`+ case t of+ Bin p m l r+ | nomatch k p m -> join k (Tip k x) p t+ | zero k m -> Bin p m (insertWithKey f k x l) r+ | otherwise -> Bin p m l (insertWithKey f k x r)+ Tip ky y+ | k==ky -> Tip k (f k x y)+ | otherwise -> join k (Tip k x) ky t+ Nil -> Tip k x +-- | Same as 'insertWithKey', but the combining function is applied strictly.+insertWithKey' :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWithKey' f k x t = k `seq`+ case t of+ Bin p m l r+ | nomatch k p m -> join k (Tip k x) p t+ | zero k m -> Bin p m (insertWithKey' f k x l) r+ | otherwise -> Bin p m l (insertWithKey' f k x r)+ Tip ky y+ | k==ky -> let x' = f k x y in seq x' (Tip k x')+ | otherwise -> join k (Tip k x) ky t+ 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@)@@ -466,18 +488,16 @@ -- > 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 = 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)+insertLookupWithKey f k x t = k `seq`+ case t of+ Bin p m l r+ | nomatch k p m -> (Nothing,join k (Tip k x) p t)+ | zero k m -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)+ | otherwise -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')+ Tip ky y+ | k==ky -> (Just y,Tip k (f k x y))+ | otherwise -> (Nothing,join k (Tip k x) ky t)+ Nil -> (Nothing,Tip k x) {--------------------------------------------------------------------@@ -492,18 +512,16 @@ -- > delete 5 empty == empty delete :: Key -> IntMap a -> IntMap a-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+delete k t = k `seq`+ case t of+ Bin p m l r+ | nomatch k p m -> t+ | zero k m -> bin p m (delete k l) r+ | otherwise -> bin p m l (delete k r)+ Tip ky _+ | k==ky -> Nil+ | otherwise -> t+ Nil -> Nil -- | /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.@@ -551,20 +569,18 @@ -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a-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-- go Nil = Nil+updateWithKey f k t = k `seq`+ case t of+ Bin p m l r+ | nomatch k p m -> t+ | zero k m -> bin p m (updateWithKey f k l) r+ | otherwise -> bin p m l (updateWithKey f k r)+ Tip ky y+ | k==ky -> case (f k y) of+ Just y' -> Tip ky y'+ Nothing -> Nil+ | otherwise -> t+ Nil -> Nil -- | /O(min(n,W))/. Lookup and update. -- The function returns original value, if it is updated.@@ -577,46 +593,43 @@ -- > 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 = 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')+updateLookupWithKey f k t = k `seq`+ case t of+ Bin p m l r+ | nomatch k p m -> (Nothing,t)+ | zero k m -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)+ | otherwise -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')+ Tip ky y+ | k==ky -> case (f k y) of+ Just y' -> (Just y,Tip ky y')+ Nothing -> (Just y,Nil)+ | otherwise -> (Nothing,t)+ Nil -> (Nothing,Nil) - 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) - 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 = 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 (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- Just x -> join k (Tip k x) ky t- Nothing -> Tip ky y-- go Nil = case f Nothing of- Just x -> Tip k x- Nothing -> Nil+alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a+alter f k t = k `seq`+ case t of+ Bin p m l r+ | nomatch k p m -> case f Nothing of+ Nothing -> t+ Just x -> join k (Tip k x) p t+ | zero k m -> bin p m (alter f k l) r+ | otherwise -> bin p m l (alter f k r)+ Tip ky y+ | k==ky -> case f (Just y) of+ Just x -> Tip ky x+ Nothing -> Nil+ | otherwise -> case f Nothing of+ Just x -> join k (Tip k x) ky t+ Nothing -> Tip ky y+ Nil -> case f Nothing of+ Just x -> Tip k x+ Nothing -> Nil {--------------------------------------------------------------------@@ -859,19 +872,19 @@ -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMinWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a-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"+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" updateMinWithKeyUnsigned :: (Key -> a -> a) -> IntMap a -> IntMap a-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"+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" -- | /O(log n)/. Update the value at the maximal key. --@@ -879,19 +892,19 @@ -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMaxWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a-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"+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" updateMaxWithKeyUnsigned :: (Key -> a -> a) -> IntMap a -> IntMap a-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"+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" -- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and@@ -909,7 +922,7 @@ Nil -> Nothing maxViewUnsigned :: IntMap a -> ((Key, a), IntMap a)-maxViewUnsigned t +maxViewUnsigned t = case t of Bin p m l r -> let (result,t') = maxViewUnsigned r in (result,bin p m l t') Tip k y -> ((k,y), Nil)@@ -930,7 +943,7 @@ Nil -> Nothing minViewUnsigned :: IntMap a -> ((Key, a), IntMap a)-minViewUnsigned t +minViewUnsigned t = case t of Bin p m l r -> let (result,t') = minViewUnsigned l in (result,bin p m t' r) Tip k y -> ((k,y),Nil)@@ -976,26 +989,26 @@ deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minView -- | /O(log n)/. The minimal key of the map.-findMin :: IntMap a -> (Int,a)+findMin :: IntMap a -> (Key, a) findMin Nil = error $ "findMin: empty map has no minimal element" findMin (Tip k v) = (k,v) findMin (Bin _ m l r)- | m < 0 = find r- | otherwise = find l- where find (Tip k v) = (k,v)- find (Bin _ _ l' _) = find l'- find Nil = error "findMax Nil"+ | m < 0 = go r+ | otherwise = go l+ where go (Tip k v) = (k,v)+ go (Bin _ _ l' _) = go l'+ go Nil = error "findMax Nil" -- | /O(log n)/. The maximal key of the map.-findMax :: IntMap a -> (Int,a)+findMax :: IntMap a -> (Key, a) findMax Nil = error $ "findMax: empty map has no maximal element" findMax (Tip k v) = (k,v)-findMax (Bin _ m l r) - | m < 0 = find l- | otherwise = find r- where find (Tip k v) = (k,v)- find (Bin _ _ _ r') = find r'- find Nil = error "findMax Nil"+findMax (Bin _ m l r)+ | m < 0 = go l+ | otherwise = go r+ where go (Tip k v) = (k,v)+ go (Bin _ _ _ r') = go r'+ go Nil = error "findMax Nil" -- | /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.@@ -1116,11 +1129,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 = 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+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 -- | /O(n)/. The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys.@@ -1181,13 +1194,14 @@ -- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a-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+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 -- | /O(n)/. Partition the map according to some predicate. The first -- map contains all elements that satisfy the predicate, the second all@@ -1235,13 +1249,12 @@ -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b-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+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 -- | /O(n)/. Map values and separate the 'Left' and 'Right' results. --@@ -1363,6 +1376,7 @@ fold :: (a -> b -> b) -> b -> IntMap a -> b fold f = foldWithKey (\_ x y -> f x y)+{-# INLINE fold #-} -- | /O(n)/. Fold the keys and values in the map, such that -- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.@@ -1376,22 +1390,22 @@ foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b foldWithKey = foldr+{-# INLINE foldWithKey #-} foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b foldr f z t = case t of- Bin 0 m l r | m < 0 -> foldr' f (foldr' f z l) r -- put negative numbers before.- Bin _ _ _ _ -> foldr' f z t+ Bin 0 m l r | m < 0 -> go (go z l) r -- put negative numbers before.+ Bin _ _ _ _ -> go z t Tip k x -> f k x z Nil -> z--foldr' :: (Key -> a -> b -> b) -> b -> IntMap a -> b-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+ go z' (Bin _ _ l r) = go (go z' r) l+ go z' (Tip k x) = f k x z'+ go z' Nil = z'+{-# INLINE foldr #-} + {-------------------------------------------------------------------- List variations --------------------------------------------------------------------}@@ -1726,6 +1740,7 @@ where m = branchMask p1 p2 p = mask p1 m+{-# INLINE join #-} {-------------------------------------------------------------------- @bin@ assures that we never have empty trees within a tree.@@ -1734,6 +1749,7 @@ bin _ _ l Nil = l bin _ _ Nil r = r bin p m l r = Bin p m l r+{-# INLINE bin #-} {--------------------------------------------------------------------@@ -1742,37 +1758,41 @@ zero :: Key -> Mask -> Bool zero i m = (natFromInt i) .&. (natFromInt m) == 0+{-# INLINE zero #-} nomatch,match :: Key -> Prefix -> Mask -> Bool nomatch i p m = (mask i m) /= p+{-# INLINE nomatch #-} match i p m = (mask i m) == p+{-# INLINE match #-} mask :: Key -> Mask -> Prefix mask i m = maskW (natFromInt i) (natFromInt m)+{-# INLINE mask #-} -zeroN :: Nat -> Nat -> Bool-zeroN i m = (i .&. m) == 0- {-------------------------------------------------------------------- Big endian operations --------------------------------------------------------------------} maskW :: Nat -> Nat -> Prefix maskW i m = intFromNat (i .&. (complement (m-1) `xor` m))+{-# INLINE maskW #-} shorter :: Mask -> Mask -> Bool shorter m1 m2 = (natFromInt m1) > (natFromInt m2)+{-# INLINE shorter #-} branchMask :: Prefix -> Prefix -> Mask branchMask p1 p2 = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))- +{-# INLINE branchMask #-}+ {---------------------------------------------------------------------- Finding the highest bit (mask) in a word [x] can be done efficiently in three ways:@@ -1824,6 +1844,7 @@ x4 -> case (x4 .|. shiftRL x4 16) of x5 -> case (x5 .|. shiftRL x5 32) of -- for 64 bit platforms x6 -> (x6 `xor` (shiftRL x6 1))+{-# INLINE highestBitMask #-} {--------------------------------------------------------------------@@ -1834,4 +1855,5 @@ foldlStrict f = go where go z [] = z- go z (x:xs) = z `seq` go (f z x) xs+ go z (x:xs) = let z' = f z x in z' `seq` go z' xs+{-# INLINE foldlStrict #-}
Data/IntSet.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE CPP, MagicHash #-} ----------------------------------------------------------------------------- -- | -- Module : Data.IntSet@@ -37,9 +36,18 @@ -- (32 or 64). ----------------------------------------------------------------------------- -module Data.IntSet ( +-- It is essential that the bit fiddling functions like mask, zero, branchMask+-- etc are inlined. If they do not, the memory allocation skyrockets. The GHC+-- usually gets it right, but it is disastrous if it does not. Therefore we+-- explicitly mark these functions INLINE.++module Data.IntSet ( -- * Set type+#if !defined(TESTING) IntSet -- instance Eq,Show+#else+ IntSet(..) -- instance Eq,Show+#endif -- * Operators , (\\)@@ -51,26 +59,33 @@ , notMember , isSubsetOf , isProperSubsetOf- + -- * Construction , empty , singleton , insert , delete- + -- * Combine- , union, unions+ , union+ , unions , difference , intersection- + -- * Filter , filter , partition , split , splitMember + -- * Map+ , map++ -- * Fold+ , fold+ -- * Min\/Max- , findMin + , findMin , findMax , deleteMin , deleteMax@@ -79,26 +94,26 @@ , maxView , minView - -- * Map- , map-- -- * Fold- , fold- -- * Conversion+ -- ** List , elems , toList , fromList- + -- ** Ordered list , toAscList , fromAscList , fromDistinctAscList- + -- * Debugging , showTree , showTreeWith++#if defined(TESTING)+ -- * Internals+ , match+#endif ) where @@ -110,14 +125,6 @@ import Data.Maybe (fromMaybe) import Data.Typeable -{---- just for testing-import Test.QuickCheck -import List (nub,sort)-import qualified List-import qualified Data.Set as Set--}- #if __GLASGOW_HASKELL__ import Text.Read import Data.Data (Data(..), mkNoRepType)@@ -139,9 +146,11 @@ natFromInt :: Int -> Nat natFromInt i = fromIntegral i+{-# INLINE natFromInt #-} intFromNat :: Nat -> Int intFromNat w = fromIntegral w+{-# INLINE intFromNat #-} shiftRL :: Nat -> Int -> Nat #if __GLASGOW_HASKELL__@@ -152,6 +161,7 @@ = W# (shiftRL# x i) #else shiftRL x i = shiftR x i+{-# INLINE shiftRL #-} #endif {--------------------------------------------------------------------@@ -218,36 +228,45 @@ Tip _ -> 1 Nil -> 0 +-- The 'go' function in the member and lookup causes 10% speedup, but also an+-- increased memory allocation. It does not cause speedup with other methods+-- like insert and delete, so it is present only in member and lookup.++-- Also mind the 'nomatch' line in member definition, which is not present in+-- lookup and not present in IntMap.hs. That condition stops the search if the+-- prefix of current vertex is different that the element looked for. The+-- member is correct both with and without this condition. With this condition,+-- elements not present are rejected sooner, but a little bit more work is done+-- for the elements in the set (we are talking about 3-5% slowdown). Any of+-- the solutions is better than the other, because we do not know the+-- distribution of input data. Current state is historic.+ -- | /O(min(n,W))/. Is the value a member of the set? member :: Int -> IntSet -> Bool-member x t- = case t of- Bin p m l r - | nomatch x p m -> False- | zero x m -> member x l- | otherwise -> member x r- Tip y -> (x==y)- Nil -> False- +member x = x `seq` go+ where+ go (Bin p m l r)+ | nomatch x p m = False+ | zero x m = go l+ | otherwise = go r+ go (Tip y) = x == y+ go Nil = False+ -- | /O(min(n,W))/. Is the element not in the set? notMember :: Int -> IntSet -> Bool notMember k = not . member k -- 'lookup' is used by 'intersection' for left-biasing lookup :: Int -> IntSet -> Maybe Int-lookup k t- = let nk = natFromInt k in seq nk (lookupN nk t)--lookupN :: Nat -> IntSet -> Maybe Int-lookupN k t- = case t of- Bin _ m l r- | zeroN k (natFromInt m) -> lookupN k l- | otherwise -> lookupN k r- Tip kx- | (k == natFromInt kx) -> Just kx- | otherwise -> Nothing- Nil -> Nothing+lookup k = k `seq` go+ where+ go (Bin _ m l r)+ | zero k m = go l+ | otherwise = go r+ go (Tip kx)+ | k == kx = Just kx+ | otherwise = Nothing+ go Nil = Nothing {-------------------------------------------------------------------- Construction@@ -269,43 +288,43 @@ -- an element of the set, it is replaced by the new one, ie. 'insert' -- is left-biased. insert :: Int -> IntSet -> IntSet-insert x t- = case t of- Bin p m l r - | nomatch x p m -> join x (Tip x) p t- | zero x m -> Bin p m (insert x l) r- | otherwise -> Bin p m l (insert x r)- Tip y - | x==y -> Tip x- | otherwise -> join x (Tip x) y t- Nil -> Tip x+insert x t = x `seq`+ case t of+ Bin p m l r+ | nomatch x p m -> join x (Tip x) p t+ | zero x m -> Bin p m (insert x l) r+ | otherwise -> Bin p m l (insert x r)+ Tip y+ | x==y -> Tip x+ | otherwise -> join x (Tip x) y t+ Nil -> Tip x -- right-biased insertion, used by 'union' insertR :: Int -> IntSet -> IntSet-insertR x t- = case t of- Bin p m l r - | nomatch x p m -> join x (Tip x) p t- | zero x m -> Bin p m (insert x l) r- | otherwise -> Bin p m l (insert x r)- Tip y - | x==y -> t- | otherwise -> join x (Tip x) y t- Nil -> Tip x+insertR x t = x `seq`+ case t of+ Bin p m l r+ | nomatch x p m -> join x (Tip x) p t+ | zero x m -> Bin p m (insert x l) r+ | otherwise -> Bin p m l (insert x r)+ Tip y+ | x==y -> t+ | otherwise -> join x (Tip x) y t+ Nil -> Tip x -- | /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 x t- = case t of- Bin p m l r - | nomatch x p m -> t- | zero x m -> bin p m (delete x l) r- | otherwise -> bin p m l (delete x r)- Tip y - | x==y -> Nil- | otherwise -> t- Nil -> Nil+delete x t = x `seq`+ case t of+ Bin p m l r+ | nomatch x p m -> t+ | zero x m -> bin p m (delete x l) r+ | otherwise -> bin p m l (delete x r)+ Tip y+ | x==y -> Nil+ | otherwise -> t+ Nil -> Nil {--------------------------------------------------------------------@@ -647,19 +666,16 @@ fold :: (Int -> b -> b) -> b -> IntSet -> b fold f z t = case t of- Bin 0 m l r | m < 0 -> foldr f (foldr f z l) r - -- put negative numbers before.- Bin _ _ _ _ -> foldr f z t+ Bin 0 m l r | m < 0 -> go (go z l) r -- put negative numbers before.+ Bin _ _ _ _ -> go z t Tip x -> f x z Nil -> z+ where+ go z' (Bin _ _ l r) = go (go z' r) l+ go z' (Tip x) = f x z'+ go z' Nil = z'+{-# INLINE fold #-} -foldr :: (Int -> b -> b) -> b -> IntSet -> b-foldr f z t- = case t of- Bin _ _ l r -> foldr f (foldr f z r) l- Tip x -> f x z- Nil -> z- {-------------------------------------------------------------------- List variations --------------------------------------------------------------------}@@ -880,6 +896,7 @@ where m = branchMask p1 p2 p = mask p1 m+{-# INLINE join #-} {-------------------------------------------------------------------- @bin@ assures that we never have empty trees within a tree.@@ -888,6 +905,7 @@ bin _ _ l Nil = l bin _ _ Nil r = r bin p m l r = Bin p m l r+{-# INLINE bin #-} {--------------------------------------------------------------------@@ -896,22 +914,23 @@ zero :: Int -> Mask -> Bool zero i m = (natFromInt i) .&. (natFromInt m) == 0+{-# INLINE zero #-} nomatch,match :: Int -> Prefix -> Mask -> Bool nomatch i p m = (mask i m) /= p+{-# INLINE nomatch #-} match i p m = (mask i m) == p+{-# INLINE match #-} -- Suppose a is largest such that 2^a divides 2*m. -- Then mask i m is i with the low a bits zeroed out. mask :: Int -> Mask -> Prefix mask i m = maskW (natFromInt i) (natFromInt m)--zeroN :: Nat -> Nat -> Bool-zeroN i m = (i .&. m) == 0+{-# INLINE mask #-} {-------------------------------------------------------------------- Big endian operations @@ -919,15 +938,18 @@ maskW :: Nat -> Nat -> Prefix maskW i m = intFromNat (i .&. (complement (m-1) `xor` m))+{-# INLINE maskW #-} shorter :: Mask -> Mask -> Bool shorter m1 m2 = (natFromInt m1) > (natFromInt m2)+{-# INLINE shorter #-} branchMask :: Prefix -> Prefix -> Mask branchMask p1 p2 = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))- +{-# INLINE branchMask #-}+ {---------------------------------------------------------------------- Finding the highest bit (mask) in a word [x] can be done efficiently in three ways:@@ -979,136 +1001,15 @@ x4 -> case (x4 .|. shiftRL x4 16) of x5 -> case (x5 .|. shiftRL x5 32) of -- for 64 bit platforms x6 -> (x6 `xor` (shiftRL x6 1))+{-# INLINE highestBitMask #-} {-------------------------------------------------------------------- Utilities --------------------------------------------------------------------} foldlStrict :: (a -> b -> a) -> a -> [b] -> a-foldlStrict f z xs- = case xs of- [] -> z- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)---{--{--------------------------------------------------------------------- Testing---------------------------------------------------------------------}-testTree :: [Int] -> IntSet-testTree xs = fromList 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 Arbitrary IntSet where- arbitrary = do{ xs <- arbitrary- ; return (fromList xs)- }---{--------------------------------------------------------------------- Single, Insert, Delete---------------------------------------------------------------------}-prop_Single :: Int -> Bool-prop_Single x- = (insert x empty == singleton x)--prop_InsertDelete :: Int -> IntSet -> Property-prop_InsertDelete k t- = not (member k t) ==> delete k (insert k t) == t---{--------------------------------------------------------------------- Union---------------------------------------------------------------------}-prop_UnionInsert :: Int -> IntSet -> Bool-prop_UnionInsert x t- = union t (singleton x) == insert x t--prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool-prop_UnionAssoc t1 t2 t3- = union t1 (union t2 t3) == union (union t1 t2) t3--prop_UnionComm :: IntSet -> IntSet -> Bool-prop_UnionComm t1 t2- = (union t1 t2 == union t2 t1)--prop_Diff :: [Int] -> [Int] -> Bool-prop_Diff xs ys- = toAscList (difference (fromList xs) (fromList ys))- == List.sort ((List.\\) (nub xs) (nub ys))--prop_Int :: [Int] -> [Int] -> Bool-prop_Int xs ys- = toAscList (intersection (fromList xs) (fromList ys))- == List.sort (nub ((List.intersect) (xs) (ys)))--{--------------------------------------------------------------------- Lists---------------------------------------------------------------------}-prop_Ordered- = forAll (choose (5,100)) $ \n ->- let xs = concat [[i-n,i-n]|i<-[0..2*n :: Int]]- in fromAscList xs == fromList xs--prop_List :: [Int] -> Bool-prop_List xs- = (sort (nub xs) == toAscList (fromList xs))--{--------------------------------------------------------------------- Bin invariants---------------------------------------------------------------------}-powersOf2 :: IntSet-powersOf2 = fromList [2^i | i <- [0..63]]---- Check the invariant that the mask is a power of 2.-prop_MaskPow2 :: IntSet -> Bool-prop_MaskPow2 (Bin _ msk left right) = member msk powersOf2 && prop_MaskPow2 left && prop_MaskPow2 right-prop_MaskPow2 _ = True---- Check that the prefix satisfies its invariant.-prop_Prefix :: IntSet -> Bool-prop_Prefix s@(Bin prefix msk left right) = all (\elem -> match elem prefix msk) (toList s) && prop_Prefix left && prop_Prefix right-prop_Prefix _ = True---- Check that the left elements don't have the mask bit set, and the right--- ones do.-prop_LeftRight :: IntSet -> Bool-prop_LeftRight (Bin _ msk left right) = and [x .&. msk == 0 | x <- toList left] && and [x .&. msk == msk | x <- toList right]-prop_LeftRight _ = True--{--------------------------------------------------------------------- IntSet operations are like Set operations---------------------------------------------------------------------}-toSet :: IntSet -> Set.Set Int-toSet = Set.fromList . toList---- Check that IntSet.isProperSubsetOf is the same as Set.isProperSubsetOf.-prop_isProperSubsetOf :: IntSet -> IntSet -> Bool-prop_isProperSubsetOf a b = isProperSubsetOf a b == Set.isProperSubsetOf (toSet a) (toSet b)---- In the above test, isProperSubsetOf almost always returns False (since a--- random set is almost never a subset of another random set). So this second--- test checks the True case.-prop_isProperSubsetOf2 :: IntSet -> IntSet -> Bool-prop_isProperSubsetOf2 a b = isProperSubsetOf a c == (a /= c) where- c = union a b--}+ go z [] = z+ go z (x:xs) = let z' = f z x in z' `seq` go z' xs+{-# INLINE foldlStrict #-}
Data/Map.hs view
@@ -1,2137 +1,2569 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -XNoBangPatterns #-}---------------------------------------------------------------------------------- |--- Module : Data.Map--- Copyright : (c) Daan Leijen 2002--- (c) Andriy Palamarchuk 2008--- License : BSD-style--- Maintainer : libraries@haskell.org--- Stability : provisional--- Portability : portable------ An efficient implementation of maps from keys to values (dictionaries).------ Since many function names (but not the type name) clash with--- "Prelude" names, this module is usually imported @qualified@, e.g.------ > import Data.Map (Map)--- > import qualified Data.Map as Map------ The implementation of 'Map' is based on /size balanced/ binary trees (or--- 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/>.------ * J. Nievergelt and E.M. Reingold,--- \"/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--- 'union' or 'insert'.------ Operation comments contain the operation time complexity in--- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.--------------------------------------------------------------------------------module Data.Map ( - -- * Map type-#if !defined(TESTING)- Map -- instance Eq,Show,Read-#else- Map(..) -- instance Eq,Show,Read-#endif-- -- * Operators- , (!), (\\)-- -- * Query- , null- , size- , member- , notMember- , lookup- , findWithDefault- - -- * Construction- , empty- , singleton-- -- ** Insertion- , insert- , insertWith- , insertWith'- , insertWithKey- , insertWithKey'- , insertLookupWithKey- , insertLookupWithKey'- - -- ** Delete\/Update- , delete- , adjust- , adjustWithKey- , update- , updateWithKey- , updateLookupWithKey- , alter-- -- * Combine-- -- ** Union- , union - , unionWith - , unionWithKey- , unions- , unionsWith-- -- ** Difference- , difference- , differenceWith- , differenceWithKey- - -- ** Intersection- , intersection - , intersectionWith- , intersectionWithKey-- -- * Traversal- -- ** Map- , map- , mapWithKey- , mapAccum- , mapAccumWithKey- , mapAccumRWithKey- , mapKeys- , mapKeysWith- , mapKeysMonotonic-- -- ** Fold- , fold- , foldWithKey- , foldrWithKey- , foldlWithKey- -- , foldlWithKey'-- -- * Conversion- , elems- , keys- , keysSet- , assocs- - -- ** Lists- , toList- , fromList- , fromListWith- , fromListWithKey-- -- ** Ordered lists- , toAscList- , toDescList- , fromAscList- , fromAscListWith- , fromAscListWithKey- , fromDistinctAscList-- -- * Filter - , filter- , filterWithKey- , partition- , partitionWithKey-- , mapMaybe- , mapMaybeWithKey- , mapEither- , mapEitherWithKey-- , split - , splitLookup -- -- * Submap- , isSubmapOf, isSubmapOfBy- , isProperSubmapOf, isProperSubmapOfBy-- -- * Indexed - , lookupIndex- , findIndex- , elemAt- , updateAt- , deleteAt-- -- * Min\/Max- , findMin- , findMax- , deleteMin- , deleteMax- , deleteFindMin- , deleteFindMax- , updateMin- , updateMax- , updateMinWithKey- , updateMaxWithKey- , minView- , maxView- , minViewWithKey- , maxViewWithKey- - -- * Debugging- , showTree- , showTreeWith- , valid--#if defined(TESTING)- -- * Internals- , bin- , balanced- , join- , merge-#endif-- ) where--import Prelude hiding (lookup,map,filter,null)-import qualified Data.Set as Set-import qualified Data.List as List-import Data.Monoid (Monoid(..))-import Control.Applicative (Applicative(..), (<$>))-import Data.Traversable (Traversable(traverse))-import Data.Foldable (Foldable(foldMap))-#ifndef __GLASGOW_HASKELL__-import Data.Typeable ( Typeable, typeOf, typeOfDefault- , Typeable1, typeOf1, typeOf1Default)-#endif-import Data.Typeable (Typeable2(..), TyCon, mkTyCon, mkTyConApp)--#if __GLASGOW_HASKELL__-import Text.Read-import Data.Data (Data(..), mkNoRepType, gcast2)-#endif--{--------------------------------------------------------------------- Operators---------------------------------------------------------------------}-infixl 9 !,\\ ------ | /O(log n)/. Find the value at a key.--- Calls 'error' when the element can not be found.------ > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map--- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'--(!) :: Ord k => Map k a -> k -> a-m ! k = find k m---- | Same as 'difference'.-(\\) :: Ord k => Map k a -> Map k b -> Map k a-m1 \\ m2 = difference m1 m2--{--------------------------------------------------------------------- Size balanced trees.---------------------------------------------------------------------}--- | A Map from keys @k@ to values @a@. -data Map k a = Tip - | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a) --type Size = Int--instance (Ord k) => Monoid (Map k v) where- mempty = empty- mappend = union- mconcat = unions--#if __GLASGOW_HASKELL__--{--------------------------------------------------------------------- A Data instance ---------------------------------------------------------------------}---- This instance preserves data abstraction at the cost of inefficiency.--- We omit reflection services for the sake of data abstraction.--instance (Data k, Data a, Ord k) => Data (Map k a) where- gfoldl f z m = z fromList `f` toList m- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNoRepType "Data.Map.Map"- dataCast2 f = gcast2 f--#endif--{--------------------------------------------------------------------- Query---------------------------------------------------------------------}--- | /O(1)/. Is the map empty?------ > Data.Map.null (empty) == True--- > Data.Map.null (singleton 1 'a') == False--null :: Map k a -> Bool-null Tip = True-null (Bin {}) = False---- | /O(1)/. The number of elements in the map.------ > size empty == 0--- > size (singleton 1 'a') == 1--- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3--size :: Map k a -> Int-size Tip = 0-size (Bin sz _ _ _ _) = sz----- | /O(log n)/. Lookup the value at a key in the map.------ The function will return the corresponding value as @('Just' value)@,--- or 'Nothing' if the key isn't in the map.------ An example of using @lookup@:------ > import Prelude hiding (lookup)--- > import Data.Map--- >--- > employeeDept = fromList([("John","Sales"), ("Bob","IT")])--- > deptCountry = fromList([("IT","USA"), ("Sales","France")])--- > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])--- >--- > employeeCurrency :: String -> Maybe String--- > employeeCurrency name = do--- > dept <- lookup name employeeDept--- > country <- lookup dept deptCountry--- > lookup country countryCurrency--- >--- > main = do--- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John"))--- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete"))------ The output of this program:------ > John's currency: Just "Euro"--- > Pete's currency: Nothing--lookup :: Ord k => k -> Map k a -> Maybe a-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 = 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'.------ > member 5 (fromList [(5,'a'), (3,'b')]) == True--- > 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---- | /O(log n)/. Is the key not a member of the map? See also 'member'.------ > notMember 5 (fromList [(5,'a'), (3,'b')]) == False--- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True--notMember :: Ord k => k -> Map k a -> Bool-notMember k m = not $ member k m---- | /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---- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns--- the value at key @k@ or returns default value @def@--- when the key is not in the map.------ > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'--- > 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--{--------------------------------------------------------------------- Construction---------------------------------------------------------------------}--- | /O(1)/. The empty map.------ > empty == fromList []--- > size empty == 0--empty :: Map k a-empty = Tip---- | /O(1)/. A map with a single element.------ > singleton 1 'a' == fromList [(1, 'a')]--- > size (singleton 1 'a') == 1--singleton :: k -> a -> Map k a-singleton k x = Bin 1 k x Tip Tip--{--------------------------------------------------------------------- Insertion---------------------------------------------------------------------}--- | /O(log n)/. Insert a new key and value in the map.--- If the key is already present in the map, the associated value is--- replaced with the supplied value. 'insert' is equivalent to--- @'insertWith' 'const'@.------ > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]--- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]--- > insert 5 'x' empty == singleton 5 'x'--insert :: Ord k => k -> a -> Map k a -> Map k a-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@ --- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert the pair @(key, f new_value old_value)@.------ > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]--- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"--insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-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 = 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@ --- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert the pair @(key,f key new_value old_value)@.--- Note that the key passed to f is the same key passed to 'insertWithKey'.------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]--- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > 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 = 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 = 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@)--- is a pair where the first element is equal to (@'lookup' k map@)--- and the second element equal to (@'insertWithKey' f k x map@).------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])--- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])--- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")------ This is how to define @insertLookup@ using @insertLookupWithKey@:------ > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t--- > 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 = 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)]---------------------------------------------------------------------}--- | /O(log n)/. Delete a key and its value from the map. When the key is not--- a member of the map, the original map is returned.------ > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > delete 5 empty == empty--delete :: Ord k => k -> Map k a -> Map k a-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--- a member of the map, the original map is returned.------ > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjust ("new " ++) 7 empty == empty--adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a-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.------ > let f key x = (show key) ++ ":new " ++ x--- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjustWithKey f 7 empty == empty--adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a-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--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f x = if x == "a" then Just "new a" else Nothing--- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > 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 = 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',--- the element is deleted. If it is (@'Just' y@), the key @k@ is bound--- to the new value @y@.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > 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 = 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.--- Returns the original key value if the map entry is deleted. ------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])--- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])--- > 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 = 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)---- | /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 a 'Map'.--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.------ > let f _ = Nothing--- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- >--- > let f _ = Just "c"--- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]--- > 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 = k `seq` go- where- go Tip = case f Nothing of- Nothing -> Tip- 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--{--------------------------------------------------------------------- Indexing---------------------------------------------------------------------}--- | /O(log n)/. Return the /index/ of a key. The index is a number from--- /0/ up to, but not including, the 'size' of the map. Calls 'error' when--- the key is not a 'member' of the map.------ > findIndex 2 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map--- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0--- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1--- > findIndex 6 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map--findIndex :: Ord k => k -> Map k a -> Int-findIndex k t- = case lookupIndex k t of- Nothing -> error "Map.findIndex: element is not in the map"- Just idx -> idx---- | /O(log n)/. Lookup the /index/ of a key. The index is a number from--- /0/ up to, but not including, the 'size' of the map.------ > isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")])) == False--- > fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) == 0--- > fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) == 1--- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")])) == False--lookupIndex :: Ord k => k -> Map k a -> Maybe Int-lookupIndex k = k `seq` go 0- where- 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--- invalid index is used.------ > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b")--- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a")--- > elemAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range--elemAt :: Int -> Map k a -> (k,a)-elemAt _ Tip = error "Map.elemAt: index out of range"-elemAt i (Bin _ kx x l r)- = case compare i sizeL of- LT -> elemAt i l- GT -> elemAt (i-sizeL-1) r- EQ -> (kx,x)- where- sizeL = size l---- | /O(log n)/. Update the element at /index/. Calls 'error' when an--- invalid index is used.------ > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]--- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]--- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range--- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range--- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range--- > 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 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---- | /O(log n)/. Delete the element at /index/.--- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).------ > deleteAt 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--- > deleteAt 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > deleteAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range--- > deleteAt (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range--deleteAt :: Int -> Map k a -> Map k a-deleteAt i m- = updateAt (\_ _ -> Nothing) i m---{--------------------------------------------------------------------- Minimal, Maximal---------------------------------------------------------------------}--- | /O(log n)/. The minimal key of the map. Calls 'error' is the map is empty.------ > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")--- > findMin empty Error: empty map has no minimal element--findMin :: Map k a -> (k,a)-findMin (Bin _ kx x Tip _) = (kx,x)-findMin (Bin _ _ _ l _) = findMin l-findMin Tip = error "Map.findMin: empty map has no minimal element"---- | /O(log n)/. The maximal key of the map. Calls 'error' is the map is empty.------ > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")--- > findMax empty Error: empty map has no maximal element--findMax :: Map k a -> (k,a)-findMax (Bin _ kx x _ Tip) = (kx,x)-findMax (Bin _ _ _ _ r) = findMax r-findMax Tip = error "Map.findMax: empty map has no maximal element"---- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty.------ > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]--- > deleteMin empty == empty--deleteMin :: Map k a -> Map k a-deleteMin (Bin _ _ _ Tip r) = r-deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r-deleteMin Tip = Tip---- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty.------ > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]--- > deleteMax empty == empty--deleteMax :: Map k a -> Map k a-deleteMax (Bin _ _ _ l Tip) = l-deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)-deleteMax Tip = Tip---- | /O(log n)/. Update the value at the minimal key.------ > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]--- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMin :: (a -> Maybe a) -> Map k a -> Map k a-updateMin f m- = updateMinWithKey (\_ x -> f x) m---- | /O(log n)/. Update the value at the maximal key.------ > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]--- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMax :: (a -> Maybe a) -> Map k a -> Map k a-updateMax f m- = updateMaxWithKey (\_ x -> f x) m----- | /O(log n)/. Update the value at the minimal key.------ > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]--- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a-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.------ > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]--- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a-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- 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.------ > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")--- > minViewWithKey empty == Nothing--minViewWithKey :: Map k a -> Maybe ((k,a), Map k a)-minViewWithKey Tip = Nothing-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.------ > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")--- > maxViewWithKey empty == Nothing--maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a)-maxViewWithKey Tip = Nothing-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--- empty map.------ > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")--- > minView empty == Nothing--minView :: Map k a -> Maybe (a, Map k a)-minView Tip = Nothing-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------ > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")--- > maxView empty == Nothing--maxView :: Map k a -> Maybe (a, Map k a)-maxView Tip = Nothing-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)-first f (x,y) = (f x, y)--{--------------------------------------------------------------------- Union. ---------------------------------------------------------------------}--- | The union of a list of maps:--- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).------ > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]--- > == fromList [(3, "b"), (5, "a"), (7, "C")]--- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]--- > == fromList [(3, "B3"), (5, "A3"), (7, "C")]--unions :: Ord k => [Map k a] -> Map k a-unions ts- = foldlStrict union empty ts---- | The union of a list of maps, with a combining operation:--- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).------ > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]--- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]--unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a-unionsWith f ts- = foldlStrict (unionWith f) empty ts---- | /O(n+m)/.--- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. --- It prefers @t1@ when duplicate keys are encountered,--- i.e. (@'union' == 'unionWith' 'const'@).--- The implementation uses the efficient /hedge-union/ algorithm.--- Hedge-union is more efficient on (bigset \``union`\` smallset).------ > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]--union :: Ord k => Map k a -> Map k a -> Map k a-union Tip t2 = t2-union t1 Tip = t1-union t1 t2 = hedgeUnionL (const LT) (const GT) t1 t2---- left-biased hedge union-hedgeUnionL :: Ord a- => (a -> Ordering) -> (a -> Ordering) -> Map a b -> Map a b- -> Map a b-hedgeUnionL _ _ t1 Tip- = t1-hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)- = join kx x (filterGt cmplo l) (filterLt cmphi r)-hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2- = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2)) - (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))- where- cmpkx k = compare kx k--{--------------------------------------------------------------------- Union with a combining function---------------------------------------------------------------------}--- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.------ > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]--unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a-unionWith f m1 m2- = unionWithKey (\_ x y -> f x y) m1 m2---- | /O(n+m)/.--- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.--- Hedge-union is more efficient on (bigset \``union`\` smallset).------ > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value--- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]--unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a-unionWithKey _ Tip t2 = t2-unionWithKey _ t1 Tip = t1-unionWithKey f t1 t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2--hedgeUnionWithKey :: Ord a- => (a -> b -> b -> b)- -> (a -> Ordering) -> (a -> Ordering)- -> Map a b -> Map a b- -> Map a b-hedgeUnionWithKey _ _ _ t1 Tip- = t1-hedgeUnionWithKey _ cmplo cmphi Tip (Bin _ kx x l r)- = join kx x (filterGt cmplo l) (filterLt cmphi r)-hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2- = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt) - (hedgeUnionWithKey f 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) -> f kx x y--{--------------------------------------------------------------------- Difference---------------------------------------------------------------------}--- | /O(n+m)/. Difference of two maps. --- Return elements of the first map not existing in the second map.--- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.------ > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"--difference :: Ord k => Map k a -> Map k b -> Map k a-difference Tip _ = Tip-difference t1 Tip = t1-difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2--hedgeDiff :: Ord a- => (a -> Ordering) -> (a -> Ordering) -> Map a b -> Map a c- -> Map a b-hedgeDiff _ _ Tip _- = Tip-hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip - = join kx x (filterGt cmplo l) (filterLt cmphi r)-hedgeDiff cmplo cmphi t (Bin _ kx _ l r) - = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l) - (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)- where- cmpkx k = compare kx k ---- | /O(n+m)/. Difference with a combining function. --- When two equal keys are--- encountered, the combining function is applied to the values of these keys.--- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@. --- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.------ > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing--- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])--- > == singleton 3 "b:B"--differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a-differenceWith f m1 m2- = differenceWithKey (\_ x y -> f x y) m1 m2---- | /O(n+m)/. Difference with a combining function. When two equal keys are--- encountered, the combining function is applied to the key and both values.--- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@. --- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.------ > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing--- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])--- > == singleton 3 "3:b|B"--differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a-differenceWithKey _ Tip _ = Tip-differenceWithKey _ t1 Tip = t1-differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2--hedgeDiffWithKey :: Ord a- => (a -> b -> c -> Maybe b)- -> (a -> Ordering) -> (a -> Ordering)- -> Map a b -> Map a c- -> Map a b-hedgeDiffWithKey _ _ _ Tip _- = Tip-hedgeDiffWithKey _ cmplo cmphi (Bin _ kx x l r) Tip- = join kx x (filterGt cmplo l) (filterLt cmphi r)-hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r) - = case found of- Nothing -> merge tl tr- Just (ky,y) -> - case f ky y x of- Nothing -> merge tl tr- Just z -> join ky z tl tr- where- cmpkx k = compare kx k - lt = trim cmplo cmpkx t- (found,gt) = trimLookupLo kx cmphi t- tl = hedgeDiffWithKey f cmplo cmpkx lt l- tr = hedgeDiffWithKey f cmpkx cmphi gt r----{--------------------------------------------------------------------- Intersection---------------------------------------------------------------------}--- | /O(n+m)/. Intersection of two maps.--- Return data in the first map for the keys existing in both maps.--- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).------ > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"--intersection :: Ord k => Map k a -> Map k b -> Map k a-intersection m1 m2- = intersectionWithKey (\_ x _ -> x) m1 m2---- | /O(n+m)/. Intersection with a combining function.------ > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"--intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c-intersectionWith f m1 m2- = intersectionWithKey (\_ x y -> f x y) m1 m2---- | /O(n+m)/. Intersection with a combining function.--- Intersection is more efficient on (bigset \``intersection`\` smallset).------ > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar--- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"----intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c---intersectionWithKey f Tip t = Tip---intersectionWithKey f t Tip = Tip---intersectionWithKey f t1 t2 = intersectWithKey f t1 t2------intersectWithKey f Tip t = Tip---intersectWithKey f t Tip = Tip---intersectWithKey f t (Bin _ kx x l r)--- = case found of--- Nothing -> merge tl tr--- Just y -> join kx (f kx y x) tl tr--- where--- (lt,found,gt) = splitLookup kx t--- tl = intersectWithKey f lt l--- tr = intersectWithKey f gt r--intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c-intersectionWithKey _ Tip _ = Tip-intersectionWithKey _ _ Tip = Tip-intersectionWithKey f t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 x2 l2 r2) =- if s1 >= s2 then- let (lt,found,gt) = splitLookupWithKey k2 t1- tl = intersectionWithKey f lt l2- tr = intersectionWithKey f gt r2- in case found of- Just (k,x) -> join k (f k x x2) tl tr- Nothing -> merge tl tr- else let (lt,found,gt) = splitLookup k1 t2- tl = intersectionWithKey f l1 lt- tr = intersectionWithKey f r1 gt- in case found of- Just x -> join k1 (f k1 x1 x) tl tr- Nothing -> merge tl tr----{--------------------------------------------------------------------- Submap---------------------------------------------------------------------}--- | /O(n+m)/.--- 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--{- | /O(n+m)/.- The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if- all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when- applied to their respective values. For example, the following - expressions are all 'True':- - > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])-- But the following are all 'False':- - > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])- ---}-isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool-isSubmapOfBy f t1 t2- = (size t1 <= size t2) && (submap' f t1 t2)--submap' :: Ord a => (b -> c -> Bool) -> Map a b -> Map a c -> Bool-submap' _ Tip _ = True-submap' _ _ Tip = False-submap' f (Bin _ kx x l r) t- = case found of- Nothing -> False- Just y -> f x y && submap' f l lt && submap' f r gt- where- (lt,found,gt) = splitLookup kx t---- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). --- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).-isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool-isProperSubmapOf m1 m2- = isProperSubmapOfBy (==) m1 m2--{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).- The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when- @m1@ and @m2@ are not equal,- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when- applied to their respective values. For example, the following - expressions are all 'True':- - > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])- > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-- But the following are all 'False':- - > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])- > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])- - --}-isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool-isProperSubmapOfBy f t1 t2- = (size t1 < size t2) && (submap' f t1 t2)--{--------------------------------------------------------------------- Filter and partition---------------------------------------------------------------------}--- | /O(n)/. Filter all values that satisfy the predicate.------ > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty--- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty--filter :: Ord k => (a -> Bool) -> Map k a -> Map k a-filter p m- = filterWithKey (\_ x -> p x) m---- | /O(n)/. Filter all keys\/values that satisfy the predicate.------ > 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 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--- elements that fail the predicate. See also 'split'.------ > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")--- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)--- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])--partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)-partition p m- = partitionWithKey (\_ x -> p x) m---- | /O(n)/. Partition the map according to a predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.------ > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")--- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)--- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])--partitionWithKey :: Ord k => (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)- where- (l1,l2) = partitionWithKey p l- (r1,r2) = partitionWithKey p r---- | /O(n)/. Map values and collect the 'Just' results.------ > let f x = if x == "a" then Just "new a" else Nothing--- > 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 = mapMaybeWithKey (\_ x -> f x)---- | /O(n)/. Map keys\/values and collect the 'Just' results.------ > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing--- > 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 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.------ > let f a = if a < "c" then Left a else Right a--- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])--- >--- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--mapEither :: Ord k => (a -> Either b c) -> Map k a -> (Map k b, Map k c)-mapEither f m- = mapEitherWithKey (\_ x -> f x) m---- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.------ > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)--- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])--- >--- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])--mapEitherWithKey :: Ord k =>- (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)-mapEitherWithKey _ Tip = (Tip, Tip)-mapEitherWithKey f (Bin _ kx x l r) = case f kx x of- Left y -> (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--{--------------------------------------------------------------------- Mapping---------------------------------------------------------------------}--- | /O(n)/. Map a function over all values in the map.------ > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]--map :: (a -> b) -> Map k a -> Map k b-map f = mapWithKey (\_ x -> f x)---- | /O(n)/. Map a function over all values in the map.------ > let f key x = (show key) ++ ":" ++ x--- > 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 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.------ > let f a b = (a ++ b, b ++ "X")--- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])--mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccum f a m- = mapAccumWithKey (\a' _ x' -> f a' x') a m---- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating--- argument through the map in ascending order of keys.------ > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")--- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])--mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumWithKey f a t- = mapAccumL f a t---- | /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 = 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 = 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@.--- --- The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key. In this case the value at the smallest of--- these keys is retained.------ > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")]--- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"--- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"--mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a-mapKeys = mapKeysWith (\x _ -> x)---- | /O(n*log n)/.--- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.--- --- The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key. In this case the associated values will be--- combined using @c@.------ > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"--- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"--mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a-mapKeysWith c f = fromListWith c . List.map fFirst . toList- where fFirst (x,y) = (f x, y)----- | /O(n)/.--- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@--- is strictly monotonic.--- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.--- /The precondition is not checked./--- Semi-formally, we have:--- --- > and [x < y ==> f x < f y | x <- ls, y <- ls] --- > ==> mapKeysMonotonic f s == mapKeys f s--- > where ls = keys s------ This means that @f@ maps distinct original keys to distinct resulting keys.--- This function has better performance than 'mapKeys'.------ > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]--- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True--- > valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) == False--mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a-mapKeysMonotonic _ Tip = Tip-mapKeysMonotonic f (Bin sz k x l r) =- Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)--{--------------------------------------------------------------------- Folds ---------------------------------------------------------------------}---- | /O(n)/. Fold the values in the map, such that--- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.--- For example,------ > elems map = fold (:) [] map------ > 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 = 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'@.--- For example,------ > keys map = foldWithKey (\k x ks -> k:ks) [] map------ > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"--- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"------ 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 = 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 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 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 ---------------------------------------------------------------------}--- | /O(n)/.--- Return all elements of the map in the ascending order of their keys.------ > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]--- > elems empty == []--elems :: Map k a -> [a]-elems m- = [x | (_,x) <- assocs m]---- | /O(n)/. Return all keys of the map in ascending order.------ > keys (fromList [(5,"a"), (3,"b")]) == [3,5]--- > keys empty == []--keys :: Map k a -> [k]-keys m- = [k | (k,_) <- assocs m]---- | /O(n)/. The set of all keys of the map.------ > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5]--- > keysSet empty == Data.Set.empty--keysSet :: Map k a -> Set.Set k-keysSet m = Set.fromDistinctAscList (keys m)---- | /O(n)/. Return all key\/value pairs in the map in ascending key order.------ > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--- > assocs empty == []--assocs :: Map k a -> [(k,a)]-assocs m- = toList m--{--------------------------------------------------------------------- Lists - use [foldlStrict] to reduce demand on the control-stack---------------------------------------------------------------------}--- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.--- If the list contains more than one value for the same key, the last value--- for the key is retained.------ > 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")]--fromList :: Ord k => [(k,a)] -> Map k a -fromList xs - = foldlStrict ins empty xs- where- ins t (k,x) = insert k x t---- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.------ > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]--- > fromListWith (++) [] == empty--fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a -fromListWith f xs- = fromListWithKey (\_ x y -> f x y) xs---- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.------ > let f k a1 a2 = (show k) ++ a1 ++ a2--- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]--- > fromListWithKey f [] == empty--fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a -fromListWithKey f xs - = foldlStrict ins empty xs- where- ins t (k,x) = insertWithKey f k x t---- | /O(n)/. Convert to a list of key\/value pairs.------ > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--- > toList empty == []--toList :: Map k a -> [(k,a)]-toList t = toAscList t---- | /O(n)/. Convert to an ascending list.------ > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--toAscList :: Map k a -> [(k,a)]-toAscList t = foldrWithKey (\k x xs -> (k,x):xs) [] t---- | /O(n)/. Convert to a descending list.-toDescList :: Map k a -> [(k,a)]-toDescList t = foldlWithKey (\xs k x -> (k,x):xs) [] t--{--------------------------------------------------------------------- Building trees from ascending/descending lists can be done in linear time.- - Note that if [xs] is ascending that: - fromAscList xs == fromList xs- fromAscListWith f xs == fromListWith f xs---------------------------------------------------------------------}--- | /O(n)/. Build a map from an ascending list in linear time.--- /The precondition (input list is ascending) is not checked./------ > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]--- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]--- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True--- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False--fromAscList :: Eq k => [(k,a)] -> Map k a -fromAscList xs- = fromAscListWithKey (\_ x _ -> x) xs---- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.--- /The precondition (input list is ascending) is not checked./------ > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]--- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True--- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False--fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a -fromAscListWith f xs- = fromAscListWithKey (\_ x y -> f x y) xs---- | /O(n)/. Build a map from an ascending list in linear time with a--- combining function for equal keys.--- /The precondition (input list is ascending) is not checked./------ > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2--- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]--- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True--- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False--fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a -fromAscListWithKey f xs- = fromDistinctAscList (combineEq f xs)- where- -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]- combineEq _ xs'- = case xs' of- [] -> []- [x] -> [x]- (x:xx) -> combineEq' x xx-- combineEq' z [] = [z]- combineEq' z@(kz,zz) (x@(kx,xx):xs')- | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs'- | otherwise = z:combineEq' x xs'----- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.--- /The precondition is not checked./------ > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]--- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True--- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False--fromDistinctAscList :: [(k,a)] -> Map k a -fromDistinctAscList xs- = build const (length xs) xs- where- -- 1) use continutations so that we use heap space instead of stack space.- -- 2) special case for n==5 to build bushier trees. - build c 0 xs' = c Tip xs'- build 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 build"- build c n xs' = seq nr $ build (buildR nr c) nl xs'- where- nl = n `div` 2- nr = n - nl - 1-- buildR n c l ((k,x):ys) = build (buildB l k x c) n ys- buildR _ _ _ [] = error "fromDistinctAscList buildR []"- buildB l k x c r zs = c (bin k x l r) zs- ---{--------------------------------------------------------------------- Utility functions that return sub-ranges of the original- tree. Some functions take a comparison function as argument to- allow comparisons against infinite values. A function [cmplo k]- should be read as [compare lo k].-- [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]- and [cmphi k == GT] for the key [k] of the root.- [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]- [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]-- [split k t] Returns two trees [l] and [r] where all keys- in [l] are <[k] and all keys in [r] are >[k].- [splitLookup k t] Just like [split] but also returns whether [k]- was found in the tree.---------------------------------------------------------------------}--{--------------------------------------------------------------------- [trim lo hi t] trims away all subtrees that surely contain no- values between the range [lo] to [hi]. The returned tree is either- empty or the key of the root is between @lo@ and @hi@.---------------------------------------------------------------------}-trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a-trim _ _ Tip = Tip-trim cmplo cmphi t@(Bin _ kx _ l r)- = case cmplo kx of- LT -> case cmphi kx of- GT -> t- _ -> trim cmplo cmphi l- _ -> trim cmplo cmphi r- -trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe (k,a), Map k a)-trimLookupLo _ _ Tip = (Nothing,Tip)-trimLookupLo lo cmphi t@(Bin _ kx x l r)- = case compare lo kx of- LT -> case cmphi kx of- GT -> (lookupAssoc lo t, t)- _ -> trimLookupLo lo cmphi l- GT -> trimLookupLo lo cmphi r- EQ -> (Just (kx,x),trim (compare lo) cmphi r)---{--------------------------------------------------------------------- [filterGt k t] filter all keys >[k] from tree [t]- [filterLt k t] filter all keys <[k] from tree [t]---------------------------------------------------------------------}-filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a-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 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---------------------------------------------------------------------}--- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where--- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.--- Any key equal to @k@ is found in neither @map1@ nor @map2@.------ > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])--- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")--- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")--- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)--- > 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 = 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@.------ > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])--- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")--- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")--- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)--- > 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 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 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)--{--------------------------------------------------------------------- Utility functions that maintain the balance properties of the tree.- All constructors assume that all values in [l] < [k] and all values- in [r] > [k], and that [l] and [r] are valid trees.- - In order of sophistication:- [Bin sz k x l r] The type constructor.- [bin k x l r] Maintains the correct size, assumes that both [l]- and [r] are balanced with respect to each other.- [balance k x l r] Restores the balance and size.- Assumes that the original tree was balanced and- that [l] or [r] has changed by at most one element.- [join k x l r] Restores balance and size. -- Furthermore, we can construct a new tree from two trees. Both operations- assume that all values in [l] < all values in [r] and that [l] and [r]- are valid:- [glue l r] Glues [l] and [r] together. Assumes that [l] and- [r] are already balanced with respect to each other.- [merge l r] Merges two trees and restores balance.-- Note: in contrast to Adam's paper, we use (<=) comparisons instead- of (<) comparisons in [join], [merge] and [balance]. - Quickcheck (on [difference]) showed that this was necessary in order - to maintain the invariants. It is quite unsatisfactory that I haven't - been able to find out why this is actually the case! Fortunately, it - doesn't hurt to be a bit more conservative.---------------------------------------------------------------------}--{--------------------------------------------------------------------- Join ---------------------------------------------------------------------}-join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a-join kx x Tip r = insertMin kx x r-join kx x l Tip = insertMax kx x l-join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)- | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz- | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)- | otherwise = bin kx x l r----- insertMin and insertMax don't perform potentially expensive comparisons.-insertMax,insertMin :: k -> a -> Map k a -> Map k a -insertMax kx x t- = case t of- Tip -> singleton kx x- Bin _ ky y l r- -> balance ky y l (insertMax kx x r)- -insertMin kx x t- = case t of- Tip -> singleton kx x- Bin _ ky y l r- -> balance ky y (insertMin kx x l) r- -{--------------------------------------------------------------------- [merge l r]: merges two trees.---------------------------------------------------------------------}-merge :: Map k a -> Map k a -> Map k a-merge Tip r = r-merge l Tip = l-merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)- | delta*sizeL <= sizeR = balance ky y (merge l ly) ry- | delta*sizeR <= sizeL = balance kx x lx (merge rx r)- | otherwise = glue l r--{--------------------------------------------------------------------- [glue l r]: glues two trees together.- Assumes that [l] and [r] are already balanced with respect to each other.---------------------------------------------------------------------}-glue :: Map k a -> Map k a -> Map k a-glue Tip r = r-glue l Tip = l-glue l r - | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r- | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'----- | /O(log n)/. Delete and find the minimal element.------ > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")]) --- > deleteFindMin Error: can not return the minimal element of an empty map--deleteFindMin :: Map k a -> ((k,a),Map k a)-deleteFindMin t - = case t of- Bin _ k x Tip r -> ((k,x),r)- Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)- Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)---- | /O(log n)/. Delete and find the maximal element.------ > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])--- > deleteFindMax empty Error: can not return the maximal element of an empty map--deleteFindMax :: Map k a -> ((k,a),Map k a)-deleteFindMax t- = case t of- Bin _ k x l Tip -> ((k,x),l)- Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')- Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)---{--------------------------------------------------------------------- [balance l x r] balances two trees with value x.- The sizes of the trees should balance after decreasing the- size of one of them. (a rotation).-- [delta] is the maximal relative difference between the sizes of- two trees, it corresponds with the [w] in Adams' paper.- [ratio] is the ratio between an outer and inner sibling of the- heavier subtree in an unbalanced setting. It determines- whether a double or single rotation should be performed- to restore balance. It is correspondes with the inverse- of $\alpha$ in Adam's article.-- Note that:- - [delta] should be larger than 4.646 with a [ratio] of 2.- - [delta] should be larger than 3.745 with a [ratio] of 1.534.- - - A lower [delta] leads to a more 'perfectly' balanced tree.- - A higher [delta] performs less rebalancing.-- - Balancing is automatic for random data and a balancing- scheme is only necessary to avoid pathological worst cases.- Almost any choice will do, and in practice, a rather large- [delta] may perform better than smaller one.-- Note: in contrast to Adam's paper, we use a ratio of (at least) [2]- to decide whether a single or double rotation is needed. Allthough- he actually proves that this ratio is needed to maintain the- invariants, his implementation uses an invalid ratio of [1].---------------------------------------------------------------------}-delta,ratio :: Int-delta = 4-ratio = 2--balance :: k -> a -> Map k a -> Map k a -> Map k a-balance k x l r- | sizeL + sizeR <= 1 = Bin sizeX k x l r- | sizeR >= delta*sizeL = rotateL k x l r- | sizeL >= delta*sizeR = rotateR k x l r- | otherwise = Bin sizeX k x l r- where- sizeL = size l- sizeR = size r- sizeX = sizeL + sizeR + 1---- rotate-rotateL :: a -> b -> Map a b -> Map a b -> Map a b-rotateL k x l r@(Bin _ _ _ ly ry)- | size ly < ratio*size ry = singleL k x l r- | otherwise = doubleL k x l r-rotateL _ _ _ Tip = error "rotateL Tip"--rotateR :: a -> b -> Map a b -> Map a b -> Map a b-rotateR k x l@(Bin _ _ _ ly ry) r- | size ry < ratio*size ly = singleR k x l r- | otherwise = doubleR k x l r-rotateR _ _ Tip _ = error "rotateR Tip"---- basic rotations-singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b-singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3-singleL _ _ _ Tip = error "singleL Tip"-singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)-singleR _ _ Tip _ = error "singleR Tip"--doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b-doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)-doubleL _ _ _ _ = error "doubleL"-doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)-doubleR _ _ _ _ = error "doubleR"---{--------------------------------------------------------------------- The bin constructor maintains the size of the tree---------------------------------------------------------------------}-bin :: k -> a -> Map k a -> Map k a -> Map k a-bin k x l r- = Bin (size l + size r + 1) k x l r---{--------------------------------------------------------------------- Eq converts the tree to a list. In a lazy setting, this - actually seems one of the faster methods to compare two trees - and it is certainly the simplest :-)---------------------------------------------------------------------}-instance (Eq k,Eq a) => Eq (Map k a) where- t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)--{--------------------------------------------------------------------- Ord ---------------------------------------------------------------------}--instance (Ord k, Ord v) => Ord (Map k v) where- compare m1 m2 = compare (toAscList m1) (toAscList m2)--{--------------------------------------------------------------------- Functor---------------------------------------------------------------------}-instance Functor (Map k) where- fmap f m = map f m--instance Traversable (Map k) where- traverse _ Tip = pure Tip- traverse f (Bin s k v l r)- = flip (Bin s k) <$> traverse f l <*> f v <*> traverse f r--instance Foldable (Map k) where- foldMap _f Tip = mempty- foldMap f (Bin _s _k v l r)- = foldMap f l `mappend` f v `mappend` foldMap f r--{--------------------------------------------------------------------- Read---------------------------------------------------------------------}-instance (Ord k, Read k, Read e) => Read (Map k e) where-#ifdef __GLASGOW_HASKELL__- readPrec = parens $ prec 10 $ do- Ident "fromList" <- lexP- xs <- readPrec- return (fromList xs)-- readListPrec = readListPrecDefault-#else- readsPrec p = readParen (p > 10) $ \ r -> do- ("fromList",s) <- lex r- (xs,t) <- reads s- return (fromList xs,t)-#endif--{--------------------------------------------------------------------- Show---------------------------------------------------------------------}-instance (Show k, Show a) => Show (Map k a) where- showsPrec d m = showParen (d > 10) $- showString "fromList " . shows (toList m)---- | /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-showTree m- = showTreeWith showElem True False m- where- showElem k x = show k ++ ":=" ++ show x---{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows- the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If- @wide@ is 'True', an extra wide version is shown.--> Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]-> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t-> (4,())-> +--(2,())-> | +--(1,())-> | +--(3,())-> +--(5,())->-> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t-> (4,())-> |-> +--(2,())-> | |-> | +--(1,())-> | |-> | +--(3,())-> |-> +--(5,())->-> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t-> +--(5,())-> |-> (4,())-> |-> | +--(3,())-> | |-> +--(2,())-> |-> +--(1,())---}-showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String-showTreeWith showelem hang wide t- | hang = (showsTreeHang showelem wide [] t) ""- | otherwise = (showsTree showelem wide [] [] t) ""--showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS-showsTree showelem wide lbars rbars t- = case t of- Tip -> showsBars lbars . showString "|\n"- Bin _ kx x Tip Tip- -> showsBars lbars . showString (showelem kx x) . showString "\n" - Bin _ kx x l r- -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .- showWide wide rbars .- showsBars lbars . showString (showelem kx x) . showString "\n" .- showWide wide lbars .- showsTree showelem wide (withEmpty lbars) (withBar lbars) l--showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS-showsTreeHang showelem wide bars t- = case t of- Tip -> showsBars bars . showString "|\n" - Bin _ kx x Tip Tip- -> showsBars bars . showString (showelem kx x) . showString "\n" - Bin _ kx x l r- -> showsBars bars . showString (showelem kx x) . showString "\n" . - showWide wide bars .- showsTreeHang showelem wide (withBar bars) l .- showWide wide bars .- showsTreeHang showelem wide (withEmpty bars) r--showWide :: Bool -> [String] -> String -> String-showWide wide bars - | wide = showString (concat (reverse bars)) . showString "|\n" - | otherwise = id--showsBars :: [String] -> ShowS-showsBars bars- = case bars of- [] -> id- _ -> showString (concat (reverse (tail bars))) . showString node--node :: String-node = "+--"--withBar, withEmpty :: [String] -> [String]-withBar bars = "| ":bars-withEmpty bars = " ":bars--{--------------------------------------------------------------------- Typeable---------------------------------------------------------------------}--#include "Typeable.h"-INSTANCE_TYPEABLE2(Map,mapTc,"Map")--{--------------------------------------------------------------------- Assertions---------------------------------------------------------------------}--- | /O(n)/. Test if the internal map structure is valid.------ > valid (fromAscList [(3,"b"), (5,"a")]) == True--- > valid (fromAscList [(5,"a"), (3,"b")]) == False--valid :: Ord k => Map k a -> Bool-valid t- = balanced t && ordered t && validsize t--ordered :: Ord a => Map a b -> Bool-ordered t- = bounded (const True) (const True) t- where- bounded lo hi t'- = case t' of- Tip -> True- Bin _ kx _ l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r---- | Exported only for "Debug.QuickCheck"-balanced :: Map k a -> Bool-balanced t- = case t of- Tip -> True- Bin _ _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&- balanced l && balanced r--validsize :: Map a b -> Bool-validsize t- = (realsize t == Just (size t))- where- realsize t'- = case t' of- Tip -> Just 0- Bin sz _ _ l r -> case (realsize l,realsize r) of- (Just n,Just m) | n+m+1 == sz -> Just sz- _ -> Nothing--{--------------------------------------------------------------------- Utilities---------------------------------------------------------------------}-foldlStrict :: (a -> b -> a) -> a -> [b] -> a-foldlStrict f = go- where- go z [] = z- go z (x:xs) = z `seq` go (f z x) xs--+{-# LANGUAGE CPP, NoBangPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Map+-- Copyright : (c) Daan Leijen 2002+-- (c) Andriy Palamarchuk 2008+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- An efficient implementation of maps from keys to values (dictionaries).+--+-- Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- > import Data.Map (Map)+-- > import qualified Data.Map as Map+--+-- The implementation of 'Map' is based on /size balanced/ binary trees (or+-- 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/>.+--+-- * J. Nievergelt and E.M. Reingold,+-- \"/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+-- 'union' or 'insert'.+--+-- Operation comments contain the operation time complexity in+-- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.+-----------------------------------------------------------------------------++-- It is crucial to the performance that the functions specialize on the Ord+-- type when possible. GHC 7.0 and higher does this by itself when it sees th+-- unfolding of a function -- that is why all public functions are marked+-- INLINABLE (that exposes the unfolding).+--+-- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.+-- We mark the functions that just navigate down the tree (lookup, insert,+-- delete and similar). That navigation code gets inlined and thus specialized+-- when possible. There is a price to pay -- code growth. The code INLINED is+-- therefore only the tree navigation, all the real work (rebalancing) is not+-- INLINED by using a NOINLINE.+--+-- All methods that can be INLINE are not recursive -- a 'go' function doing+-- the real work is provided.++module Data.Map (+ -- * Map type+#if !defined(TESTING)+ Map -- instance Eq,Show,Read+#else+ Map(..) -- instance Eq,Show,Read+#endif++ -- * Operators+ , (!), (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , lookup+ , findWithDefault++ -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith+ , insertWith'+ , insertWithKey+ , insertWithKey'+ , insertLookupWithKey+ , insertLookupWithKey'++ -- ** Delete\/Update+ , delete+ , adjust+ , adjustWithKey+ , update+ , updateWithKey+ , updateLookupWithKey+ , alter++ -- * Combine++ -- ** Union+ , union+ , unionWith+ , unionWithKey+ , unions+ , unionsWith++ -- ** Difference+ , difference+ , differenceWith+ , differenceWithKey++ -- ** Intersection+ , intersection+ , intersectionWith+ , intersectionWithKey++ -- * Traversal+ -- ** Map+ , map+ , mapWithKey+ , mapAccum+ , mapAccumWithKey+ , mapAccumRWithKey+ , mapKeys+ , mapKeysWith+ , mapKeysMonotonic++ -- ** Fold+ , fold+ , foldWithKey+ , foldrWithKey+ , foldrWithKey'+ , foldlWithKey+ , foldlWithKey'++ -- * Conversion+ , elems+ , keys+ , keysSet+ , assocs++ -- ** Lists+ , toList+ , fromList+ , fromListWith+ , fromListWithKey++ -- ** Ordered lists+ , toAscList+ , toDescList+ , fromAscList+ , fromAscListWith+ , fromAscListWithKey+ , fromDistinctAscList++ -- * Filter+ , filter+ , filterWithKey+ , partition+ , partitionWithKey++ , mapMaybe+ , mapMaybeWithKey+ , mapEither+ , mapEitherWithKey++ , split+ , splitLookup++ -- * Submap+ , isSubmapOf, isSubmapOfBy+ , isProperSubmapOf, isProperSubmapOfBy++ -- * Indexed+ , lookupIndex+ , findIndex+ , elemAt+ , updateAt+ , deleteAt++ -- * Min\/Max+ , findMin+ , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , updateMin+ , updateMax+ , updateMinWithKey+ , updateMaxWithKey+ , minView+ , maxView+ , minViewWithKey+ , maxViewWithKey++ -- * Debugging+ , showTree+ , showTreeWith+ , valid++#if defined(TESTING)+ -- * Internals+ , bin+ , balanced+ , join+ , merge+#endif++ ) where++import Prelude hiding (lookup,map,filter,null)+import qualified Data.Set as Set+import qualified Data.List as List+import Data.Monoid (Monoid(..))+import Control.Applicative (Applicative(..), (<$>))+import Data.Traversable (Traversable(traverse))+import Data.Foldable (Foldable(foldMap))+import Data.Typeable++#if __GLASGOW_HASKELL__+import Text.Read+import Data.Data+#endif++-- Use macros to define strictness of functions.+-- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.+-- We do not use BangPatterns, because they are not in any standard and we+-- want the compilers to be compiled by as many compilers as possible.+#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined+#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_2_OF_4(fn) fn _ arg _ _ | arg `seq` False = undefined++{--------------------------------------------------------------------+ Operators+--------------------------------------------------------------------}+infixl 9 !,\\ --++-- | /O(log n)/. Find the value at a key.+-- Calls 'error' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'++(!) :: Ord k => Map k a -> k -> a+m ! k = find k m+{-# INLINE (!) #-}++-- | Same as 'difference'.+(\\) :: Ord k => Map k a -> Map k b -> Map k a+m1 \\ m2 = difference m1 m2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE (\\) #-}+#endif++{--------------------------------------------------------------------+ Size balanced trees.+--------------------------------------------------------------------}+-- | A Map from keys @k@ to values @a@. +data Map k a = Tip + | Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a) ++type Size = Int++instance (Ord k) => Monoid (Map k v) where+ mempty = empty+ mappend = union+ mconcat = unions++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+ A Data instance +--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We omit reflection services for the sake of data abstraction.++instance (Data k, Data a, Ord k) => Data (Map k a) where+ gfoldl f z m = z fromList `f` toList m+ toConstr _ = error "toConstr"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = mkNoRepType "Data.Map.Map"+ dataCast2 f = gcast2 f++#endif++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the map empty?+--+-- > Data.Map.null (empty) == True+-- > Data.Map.null (singleton 1 'a') == False++null :: Map k a -> Bool+null Tip = True+null (Bin {}) = False+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE null #-}+#endif++-- | /O(1)/. The number of elements in the map.+--+-- > size empty == 0+-- > size (singleton 1 'a') == 1+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3++size :: Map k a -> Int+size Tip = 0+size (Bin sz _ _ _ _) = sz+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE size #-}+#endif+++-- | /O(log n)/. Lookup the value at a key in the map.+--+-- The function will return the corresponding value as @('Just' value)@,+-- or 'Nothing' if the key isn't in the map.+--+-- An example of using @lookup@:+--+-- > import Prelude hiding (lookup)+-- > import Data.Map+-- >+-- > employeeDept = fromList([("John","Sales"), ("Bob","IT")])+-- > deptCountry = fromList([("IT","USA"), ("Sales","France")])+-- > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])+-- >+-- > employeeCurrency :: String -> Maybe String+-- > employeeCurrency name = do+-- > dept <- lookup name employeeDept+-- > country <- lookup dept deptCountry+-- > lookup country countryCurrency+-- >+-- > main = do+-- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John"))+-- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete"))+--+-- The output of this program:+--+-- > John's currency: Just "Euro"+-- > Pete's currency: Nothing++lookup :: Ord k => k -> Map k a -> Maybe a+lookup = go+ where+ STRICT_1_OF_2(go)+ go _ Tip = Nothing+ go k (Bin _ kx x l r) =+ case compare k kx of+ LT -> go k l+ GT -> go k r+ EQ -> Just x+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookup #-}+#else+{-# INLINE lookup #-}+#endif++lookupAssoc :: Ord k => k -> Map k a -> Maybe (k,a)+lookupAssoc = go+ where+ STRICT_1_OF_2(go)+ go _ Tip = Nothing+ go k (Bin _ kx x l r) =+ case compare k kx of+ LT -> go k l+ GT -> go k r+ EQ -> Just (kx,x)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINEABLE lookupAssoc #-}+#else+{-# INLINE lookupAssoc #-}+#endif++-- | /O(log n)/. Is the key a member of the map? See also 'notMember'.+--+-- > member 5 (fromList [(5,'a'), (3,'b')]) == True+-- > 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+#if __GLASGOW_HASKELL__ >= 700+{-# INLINEABLE member #-}+#else+{-# INLINE member #-}+#endif++-- | /O(log n)/. Is the key not a member of the map? See also 'member'.+--+-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False+-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True++notMember :: Ord k => k -> Map k a -> Bool+notMember k m = not $ member k m+{-# INLINE notMember #-}++-- | /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+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE find #-}+#else+{-# INLINE find #-}+#endif++-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns+-- the value at key @k@ or returns default value @def@+-- when the key is not in the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > 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+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE findWithDefault #-}+#else+{-# INLINE findWithDefault #-}+#endif++{--------------------------------------------------------------------+ Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty map.+--+-- > empty == fromList []+-- > size empty == 0++empty :: Map k a+empty = Tip++-- | /O(1)/. A map with a single element.+--+-- > singleton 1 'a' == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: k -> a -> Map k a+singleton k x = Bin 1 k x Tip Tip++{--------------------------------------------------------------------+ Insertion+--------------------------------------------------------------------}+-- | /O(log n)/. Insert a new key and value in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]+-- > insert 5 'x' empty == singleton 5 'x'++insert :: Ord k => k -> a -> Map k a -> Map k a+insert = go+ where+ STRICT_1_OF_3(go)+ go kx x Tip = singleton kx x+ go kx x (Bin sz ky y l r) =+ case compare kx ky of+ LT -> balanceL ky y (go kx x l) r+ GT -> balanceR ky y l (go kx x r)+ EQ -> Bin sz kx x l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINEABLE insert #-}+#else+{-# INLINE insert #-}+#endif++-- | /O(log n)/. Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f new_value old_value)@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"++insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWith f = insertWithKey (\_ x' y' -> f x' y')+{-# INLINE insertWith #-}++-- | 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 = insertWithKey' (\_ x' y' -> f x' y')+{-# INLINE insertWith' #-}++-- | /O(log n)/. Insert with a function, combining key, new value and old value.+-- @'insertWithKey' f key value mp@ +-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key,f key new_value old_value)@.+-- Note that the key passed to f is the same key passed to 'insertWithKey'.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"++insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKey = go+ where+ STRICT_2_OF_4(go)+ go _ kx x Tip = singleton kx x+ go f kx x (Bin sy ky y l r) =+ case compare kx ky of+ LT -> balanceL ky y (go f kx x l) r+ GT -> balanceR ky y l (go f kx x r)+ EQ -> Bin sy kx (f kx x y) l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINEABLE insertWithKey #-}+#else+{-# INLINE insertWithKey #-}+#endif++-- | 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' = go+ where+ STRICT_2_OF_4(go)+ go _ kx x Tip = x `seq` singleton kx x+ go f kx x (Bin sy ky y l r) =+ case compare kx ky of+ LT -> balanceL ky y (go f kx x l) r+ GT -> balanceR ky y l (go f kx x r)+ EQ -> let x' = f kx x y in x' `seq` (Bin sy kx x' l r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINEABLE insertWithKey' #-}+#else+{-# INLINE insertWithKey' #-}+#endif++-- | /O(log n)/. Combines insert operation with old value retrieval.+-- 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@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > 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 = go+ where+ STRICT_2_OF_4(go)+ 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, balanceL ky y l' r)+ GT -> let (found, r') = go f kx x r+ in (found, balanceR ky y l r')+ EQ -> (Just y, Bin sy kx (f kx x y) l r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINEABLE insertLookupWithKey #-}+#else+{-# INLINE insertLookupWithKey #-}+#endif++-- | /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' = go+ where+ STRICT_2_OF_4(go)+ go _ kx x Tip = x `seq` (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, 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, Bin sy kx x' l r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINEABLE insertLookupWithKey' #-}+#else+{-# INLINE insertLookupWithKey' #-}+#endif++{--------------------------------------------------------------------+ Deletion+ [delete] is the inlined version of [deleteWith (\k x -> Nothing)]+--------------------------------------------------------------------}+-- | /O(log n)/. Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+--+-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > delete 5 empty == empty++delete :: Ord k => k -> Map k a -> Map k a+delete = go+ where+ STRICT_1_OF_2(go)+ go _ Tip = Tip+ go k (Bin _ kx x l r) =+ case compare k kx of+ LT -> balanceR kx x (go k l) r+ GT -> balanceL kx x l (go k r)+ EQ -> glue l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINEABLE delete #-}+#else+{-# INLINE delete #-}+#endif++-- | /O(log n)/. Update a value at a specific key with the result of the provided function.+-- When the key is not+-- a member of the map, the original map is returned.+--+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjust ("new " ++) 7 empty == empty++adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a+adjust f = adjustWithKey (\_ x -> f x)+{-# INLINE adjust #-}++-- | /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.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjustWithKey f 7 empty == empty++adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a+adjustWithKey f = updateWithKey (\k' x' -> Just (f k' x'))+{-# INLINE adjustWithKey #-}++-- | /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+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > 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 = updateWithKey (\_ x -> f x)+{-# INLINE update #-}++-- | /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',+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound+-- to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > 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 = go+ where+ STRICT_2_OF_3(go)+ go _ _ Tip = Tip+ go f k(Bin sx kx x l r) =+ case compare k kx of+ LT -> balanceR kx x (go f k l) r+ GT -> balanceL kx x l (go f k r)+ EQ -> case f kx x of+ Just x' -> Bin sx kx x' l r+ Nothing -> glue l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINEABLE updateWithKey #-}+#else+{-# INLINE updateWithKey #-}+#endif++-- | /O(log n)/. Lookup and update. See also 'updateWithKey'.+-- The function returns changed value, if it is updated.+-- Returns the original key value if the map entry is deleted. +--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])+-- > 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 = go+ where+ STRICT_2_OF_3(go)+ 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,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' -> (Just x',Bin sx kx x' l r)+ Nothing -> (Just x,glue l r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINEABLE updateLookupWithKey #-}+#else+{-# INLINE updateLookupWithKey #-}+#endif++-- | /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 a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+--+-- > let f _ = Nothing+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- >+-- > let f _ = Just "c"+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]+-- > 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 = go+ where+ STRICT_2_OF_3(go)+ go f k Tip = case f Nothing of+ Nothing -> Tip+ Just x -> singleton k x++ go f k (Bin sx kx x l r) = case compare k kx of+ LT -> balance kx x (go f k l) r+ GT -> balance kx x l (go f k r)+ EQ -> case f (Just x) of+ Just x' -> Bin sx kx x' l r+ Nothing -> glue l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINEABLE alter #-}+#else+{-# INLINE alter #-}+#endif++{--------------------------------------------------------------------+ Indexing+--------------------------------------------------------------------}+-- | /O(log n)/. Return the /index/ of a key. The index is a number from+-- /0/ up to, but not including, the 'size' of the map. Calls 'error' when+-- the key is not a 'member' of the map.+--+-- > findIndex 2 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map+-- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0+-- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1+-- > findIndex 6 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map++findIndex :: Ord k => k -> Map k a -> Int+findIndex k t+ = case lookupIndex k t of+ Nothing -> error "Map.findIndex: element is not in the map"+ Just idx -> idx+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE findIndex #-}+#endif++-- | /O(log n)/. Lookup the /index/ of a key. The index is a number from+-- /0/ up to, but not including, the 'size' of the map.+--+-- > isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")])) == False+-- > fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) == 0+-- > fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) == 1+-- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")])) == False++lookupIndex :: Ord k => k -> Map k a -> Maybe Int+lookupIndex k = lkp k 0+ where+ STRICT_1_OF_3(lkp)+ STRICT_2_OF_3(lkp)+ lkp _ _ Tip = Nothing+ lkp key idx (Bin _ kx _ l r)+ = case compare key kx of+ LT -> lkp key idx l+ GT -> lkp key (idx + size l + 1) r+ EQ -> let idx' = idx + size l in idx' `seq` Just idx'+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE lookupIndex #-}+#endif++-- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an+-- invalid index is used.+--+-- > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b")+-- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a")+-- > elemAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range++elemAt :: Int -> Map k a -> (k,a)+STRICT_1_OF_2(elemAt)+elemAt _ Tip = error "Map.elemAt: index out of range"+elemAt i (Bin _ kx x l r)+ = case compare i sizeL of+ LT -> elemAt i l+ GT -> elemAt (i-sizeL-1) r+ EQ -> (kx,x)+ where+ sizeL = size l+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE elemAt #-}+#endif++-- | /O(log n)/. Update the element at /index/. Calls 'error' when an+-- invalid index is used.+--+-- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]+-- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]+-- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+-- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > 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 f i t = i `seq`+ case t of+ Tip -> error "Map.updateAt: index out of range"+ Bin sx kx x l r -> case compare i sizeL of+ LT -> balanceR kx x (updateAt f i l) r+ GT -> balanceL kx x l (updateAt f (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+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE updateAt #-}+#endif++-- | /O(log n)/. Delete the element at /index/.+-- Defined as (@'deleteAt' i map = 'updateAt' (\k x -> 'Nothing') i map@).+--+-- > deleteAt 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+-- > deleteAt 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > deleteAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > deleteAt (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range++deleteAt :: Int -> Map k a -> Map k a+deleteAt i m+ = updateAt (\_ _ -> Nothing) i m+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE deleteAt #-}+#endif+++{--------------------------------------------------------------------+ Minimal, Maximal+--------------------------------------------------------------------}+-- | /O(log n)/. The minimal key of the map. Calls 'error' if the map is empty.+--+-- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")+-- > findMin empty Error: empty map has no minimal element++findMin :: Map k a -> (k,a)+findMin (Bin _ kx x Tip _) = (kx,x)+findMin (Bin _ _ _ l _) = findMin l+findMin Tip = error "Map.findMin: empty map has no minimal element"+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE findMin #-}+#endif++-- | /O(log n)/. The maximal key of the map. Calls 'error' if the map is empty.+--+-- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")+-- > findMax empty Error: empty map has no maximal element++findMax :: Map k a -> (k,a)+findMax (Bin _ kx x _ Tip) = (kx,x)+findMax (Bin _ _ _ _ r) = findMax r+findMax Tip = error "Map.findMax: empty map has no maximal element"+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE findMax #-}+#endif++-- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty.+--+-- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]+-- > deleteMin empty == empty++deleteMin :: Map k a -> Map k a+deleteMin (Bin _ _ _ Tip r) = r+deleteMin (Bin _ kx x l r) = balanceR kx x (deleteMin l) r+deleteMin Tip = Tip+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE deleteMin #-}+#endif++-- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty.+--+-- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]+-- > deleteMax empty == empty++deleteMax :: Map k a -> Map k a+deleteMax (Bin _ _ _ l Tip) = l+deleteMax (Bin _ kx x l r) = balanceL kx x l (deleteMax r)+deleteMax Tip = Tip+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE deleteMax #-}+#endif++-- | /O(log n)/. Update the value at the minimal key.+--+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]+-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMin :: (a -> Maybe a) -> Map k a -> Map k a+updateMin f m+ = updateMinWithKey (\_ x -> f x) m+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE updateMin #-}+#endif++-- | /O(log n)/. Update the value at the maximal key.+--+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]+-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMax :: (a -> Maybe a) -> Map k a -> Map k a+updateMax f m+ = updateMaxWithKey (\_ x -> f x) m+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE updateMax #-}+#endif+++-- | /O(log n)/. Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMinWithKey _ Tip = Tip+updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of+ Nothing -> r+ Just x' -> Bin sx kx x' Tip r+updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE updateMinWithKey #-}+#endif++-- | /O(log n)/. Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMaxWithKey _ Tip = Tip+updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of+ Nothing -> l+ Just x' -> Bin sx kx x' l Tip+updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE updateMaxWithKey #-}+#endif++-- | /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.+--+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")+-- > minViewWithKey empty == Nothing++minViewWithKey :: Map k a -> Maybe ((k,a), Map k a)+minViewWithKey Tip = Nothing+minViewWithKey x = Just (deleteFindMin x)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE minViewWithKey #-}+#endif++-- | /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.+--+-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")+-- > maxViewWithKey empty == Nothing++maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a)+maxViewWithKey Tip = Nothing+maxViewWithKey x = Just (deleteFindMax x)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE maxViewWithKey #-}+#endif++-- | /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+-- empty map.+--+-- > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")+-- > minView empty == Nothing++minView :: Map k a -> Maybe (a, Map k a)+minView Tip = Nothing+minView x = Just (first snd $ deleteFindMin x)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE minView #-}+#endif++-- | /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+--+-- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")+-- > maxView empty == Nothing++maxView :: Map k a -> Maybe (a, Map k a)+maxView Tip = Nothing+maxView x = Just (first snd $ deleteFindMax x)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE maxView #-}+#endif++-- Update the 1st component of a tuple (special case of Control.Arrow.first)+first :: (a -> b) -> (a,c) -> (b,c)+first f (x,y) = (f x, y)++{--------------------------------------------------------------------+ Union. +--------------------------------------------------------------------}+-- | The union of a list of maps:+-- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).+--+-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- > == fromList [(3, "b"), (5, "a"), (7, "C")]+-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]+-- > == fromList [(3, "B3"), (5, "A3"), (7, "C")]++unions :: Ord k => [Map k a] -> Map k a+unions ts+ = foldlStrict union empty ts+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE unions #-}+#endif++-- | The union of a list of maps, with a combining operation:+-- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a+unionsWith f ts+ = foldlStrict (unionWith f) empty ts+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE unionsWith #-}+#endif++-- | /O(n+m)/.+-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. +-- It prefers @t1@ when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+-- The implementation uses the efficient /hedge-union/ algorithm.+-- Hedge-union is more efficient on (bigset \``union`\` smallset).+--+-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]++union :: Ord k => Map k a -> Map k a -> Map k a+union Tip t2 = t2+union t1 Tip = t1+union (Bin _ k x Tip Tip) t = insert k x t+union t (Bin _ k x Tip Tip) = insertWith (\_ y->y) k x t+union t1 t2 = hedgeUnionL NothingS NothingS t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE union #-}+#endif++-- left-biased hedge union+hedgeUnionL :: Ord a+ => MaybeS a -> MaybeS a -> Map a b -> Map a b+ -> Map a b+hedgeUnionL _ _ t1 Tip+ = t1+hedgeUnionL blo bhi Tip (Bin _ kx x l r)+ = join kx x (filterGt blo l) (filterLt bhi r)+hedgeUnionL blo bhi (Bin _ kx x l r) t2+ = join kx x (hedgeUnionL blo bmi l (trim blo bmi t2))+ (hedgeUnionL bmi bhi r (trim bmi bhi t2))+ where+ bmi = JustS kx+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE hedgeUnionL #-}+#endif++{--------------------------------------------------------------------+ Union with a combining function+--------------------------------------------------------------------}+-- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]++unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWith f m1 m2+ = unionWithKey (\_ x y -> f x y) m1 m2+{-# INLINE unionWith #-}++-- | /O(n+m)/.+-- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.+-- Hedge-union is more efficient on (bigset \``union`\` smallset).+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]++unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWithKey _ Tip t2 = t2+unionWithKey _ t1 Tip = t1+unionWithKey f t1 t2 = hedgeUnionWithKey f NothingS NothingS t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE unionWithKey #-}+#endif++hedgeUnionWithKey :: Ord a+ => (a -> b -> b -> b)+ -> MaybeS a -> MaybeS a+ -> Map a b -> Map a b+ -> Map a b+hedgeUnionWithKey _ _ _ t1 Tip+ = t1+hedgeUnionWithKey _ blo bhi Tip (Bin _ kx x l r)+ = join kx x (filterGt blo l) (filterLt bhi r)+hedgeUnionWithKey f blo bhi (Bin _ kx x l r) t2+ = join kx newx (hedgeUnionWithKey f blo bmi l lt)+ (hedgeUnionWithKey f bmi bhi r gt)+ where+ bmi = JustS kx+ lt = trim blo bmi t2+ (found,gt) = trimLookupLo kx bhi t2+ newx = case found of+ Nothing -> x+ Just (_,y) -> f kx x y+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE hedgeUnionWithKey #-}+#endif++{--------------------------------------------------------------------+ Difference+--------------------------------------------------------------------}+-- | /O(n+m)/. Difference of two maps. +-- Return elements of the first map not existing in the second map.+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+--+-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"++difference :: Ord k => Map k a -> Map k b -> Map k a+difference Tip _ = Tip+difference t1 Tip = t1+difference t1 t2 = hedgeDiff NothingS NothingS t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE difference #-}+#endif++hedgeDiff :: Ord a+ => MaybeS a -> MaybeS a -> Map a b -> Map a c+ -> Map a b+hedgeDiff _ _ Tip _+ = Tip+hedgeDiff blo bhi (Bin _ kx x l r) Tip+ = join kx x (filterGt blo l) (filterLt bhi r)+hedgeDiff blo bhi t (Bin _ kx _ l r)+ = merge (hedgeDiff blo bmi (trim blo bmi t) l)+ (hedgeDiff bmi bhi (trim bmi bhi t) r)+ where+ bmi = JustS kx+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE hedgeDiff #-}+#endif++-- | /O(n+m)/. Difference with a combining function. +-- When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- > == singleton 3 "b:B"++differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWith f m1 m2+ = differenceWithKey (\_ x y -> f x y) m1 m2+{-# INLINE differenceWith #-}++-- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- > == singleton 3 "3:b|B"++differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWithKey _ Tip _ = Tip+differenceWithKey _ t1 Tip = t1+differenceWithKey f t1 t2 = hedgeDiffWithKey f NothingS NothingS t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE differenceWithKey #-}+#endif++hedgeDiffWithKey :: Ord a+ => (a -> b -> c -> Maybe b)+ -> MaybeS a -> MaybeS a+ -> Map a b -> Map a c+ -> Map a b+hedgeDiffWithKey _ _ _ Tip _+ = Tip+hedgeDiffWithKey _ blo bhi (Bin _ kx x l r) Tip+ = join kx x (filterGt blo l) (filterLt bhi r)+hedgeDiffWithKey f blo bhi t (Bin _ kx x l r) + = case found of+ Nothing -> merge tl tr+ Just (ky,y) -> + case f ky y x of+ Nothing -> merge tl tr+ Just z -> join ky z tl tr+ where+ bmi = JustS kx+ lt = trim blo bmi t+ (found,gt) = trimLookupLo kx bhi t+ tl = hedgeDiffWithKey f blo bmi lt l+ tr = hedgeDiffWithKey f bmi bhi gt r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE hedgeDiffWithKey #-}+#endif++++{--------------------------------------------------------------------+ Intersection+--------------------------------------------------------------------}+-- | /O(n+m)/. Intersection of two maps.+-- Return data in the first map for the keys existing in both maps.+-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).+--+-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"++intersection :: Ord k => Map k a -> Map k b -> Map k a+intersection m1 m2+ = intersectionWithKey (\_ x _ -> x) m1 m2+{-# INLINE intersection #-}++-- | /O(n+m)/. Intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWith f m1 m2+ = intersectionWithKey (\_ x y -> f x y) m1 m2+{-# INLINE intersectionWith #-}++-- | /O(n+m)/. Intersection with a combining function.+-- Intersection is more efficient on (bigset \``intersection`\` smallset).+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"+++intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWithKey _ Tip _ = Tip+intersectionWithKey _ _ Tip = Tip+intersectionWithKey f t1@(Bin s1 k1 x1 l1 r1) t2@(Bin s2 k2 x2 l2 r2) =+ if s1 >= s2 then+ let (lt,found,gt) = splitLookupWithKey k2 t1+ tl = intersectionWithKey f lt l2+ tr = intersectionWithKey f gt r2+ in case found of+ Just (k,x) -> join k (f k x x2) tl tr+ Nothing -> merge tl tr+ else let (lt,found,gt) = splitLookup k1 t2+ tl = intersectionWithKey f l1 lt+ tr = intersectionWithKey f r1 gt+ in case found of+ Just x -> join k1 (f k1 x1 x) tl tr+ Nothing -> merge tl tr+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE intersectionWithKey #-}+#endif++++{--------------------------------------------------------------------+ Submap+--------------------------------------------------------------------}+-- | /O(n+m)/.+-- 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+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE isSubmapOf #-}+#endif++{- | /O(n+m)/.+ The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if+ all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following + expressions are all 'True':+ + > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])++ But the following are all 'False':+ + > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])+ ++-}+isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool+isSubmapOfBy f t1 t2+ = (size t1 <= size t2) && (submap' f t1 t2)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE isSubmapOfBy #-}+#endif++submap' :: Ord a => (b -> c -> Bool) -> Map a b -> Map a c -> Bool+submap' _ Tip _ = True+submap' _ _ Tip = False+submap' f (Bin _ kx x l r) t+ = case found of+ Nothing -> False+ Just y -> f x y && submap' f l lt && submap' f r gt+ where+ (lt,found,gt) = splitLookup kx t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE submap' #-}+#endif++-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal). +-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool+isProperSubmapOf m1 m2+ = isProperSubmapOfBy (==) m1 m2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE isProperSubmapOf #-}+#endif++{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+ @m1@ and @m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following + expressions are all 'True':+ + > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':+ + > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+ > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ + +-}+isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool+isProperSubmapOfBy f t1 t2+ = (size t1 < size t2) && (submap' f t1 t2)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE isProperSubmapOfBy #-}+#endif++{--------------------------------------------------------------------+ Filter and partition+--------------------------------------------------------------------}+-- | /O(n)/. Filter all values that satisfy the predicate.+--+-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty+-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty++filter :: Ord k => (a -> Bool) -> Map k a -> Map k a+filter p m+ = filterWithKey (\_ x -> p x) m+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE filter #-}+#endif++-- | /O(n)/. Filter all keys\/values that satisfy the predicate.+--+-- > 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)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE filterWithKey #-}+#endif++-- | /O(n)/. Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)+partition p m+ = partitionWithKey (\_ x -> p x) m+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE partition #-}+#endif++-- | /O(n)/. Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")+-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partitionWithKey :: Ord k => (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)+ where+ (l1,l2) = partitionWithKey p l+ (r1,r2) = partitionWithKey p r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE partitionWithKey #-}+#endif++-- | /O(n)/. Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > 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 = mapMaybeWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapMaybe #-}+#endif++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > 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)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapMaybeWithKey #-}+#endif++-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: Ord k => (a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEither f m+ = mapEitherWithKey (\_ x -> f x) m+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapEither #-}+#endif++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: Ord k =>+ (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEitherWithKey _ Tip = (Tip, Tip)+mapEitherWithKey f (Bin _ kx x l r) = case f kx x of+ Left y -> (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+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapEitherWithKey #-}+#endif++{--------------------------------------------------------------------+ Mapping+--------------------------------------------------------------------}+-- | /O(n)/. Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> Map k a -> Map k b+map f = mapWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE map #-}+#endif++-- | /O(n)/. Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > 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)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapWithKey #-}+#endif++-- | /O(n)/. The function 'mapAccum' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccum f a m+ = mapAccumWithKey (\a' _ x' -> f a' x') a m+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapAccum #-}+#endif++-- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumWithKey f a t+ = mapAccumL f a t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapAccumWithKey #-}+#endif++-- | /O(n)/. The function 'mapAccumL' threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumL _ a Tip = (a,Tip)+mapAccumL f a (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')+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapAccumL #-}+#endif++-- | /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 _ a Tip = (a,Tip)+mapAccumRWithKey f a (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')+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapAccumRWithKey #-}+#endif++-- | /O(n*log n)/.+-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+-- +-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case the value at the smallest of+-- these keys is retained.+--+-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")]+-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"+-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"++mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a+mapKeys = mapKeysWith (\x _ -> x)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapKeys #-}+#endif++-- | /O(n*log n)/.+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+-- +-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case the associated values will be+-- combined using @c@.+--+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"++mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a+mapKeysWith c f = fromListWith c . List.map fFirst . toList+ where fFirst (x,y) = (f x, y)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapKeysWith #-}+#endif+++-- | /O(n)/.+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+-- /The precondition is not checked./+-- Semi-formally, we have:+-- +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- > ==> mapKeysMonotonic f s == mapKeys f s+-- > where ls = keys s+--+-- This means that @f@ maps distinct original keys to distinct resulting keys.+-- This function has better performance than 'mapKeys'.+--+-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]+-- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True+-- > valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) == False++mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a+mapKeysMonotonic _ Tip = Tip+mapKeysMonotonic f (Bin sz k x l r) =+ Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapKeysMonotonic #-}+#endif++{--------------------------------------------------------------------+ Folds +--------------------------------------------------------------------}++-- | /O(n)/. Fold the values in the map, such that+-- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.+-- For example,+--+-- > elems map = fold (:) [] map+--+-- > 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 = foldWithKey (\_ x' z' -> f x' z')+{-# INLINE fold #-}++-- | /O(n)/. Fold the keys and values in the map, such that+-- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+-- For example,+--+-- > keys map = foldWithKey (\k x ks -> k:ks) [] map+--+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"+--+-- 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 = foldrWithKey+{-# DEPRECATED foldWithKey "Use foldrWithKey instead" #-}+{-# INLINE foldWithKey #-}++-- | /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 f = go+ where+ go z Tip = z+ go z (Bin _ kx x l r) = go (f kx x (go z r)) l+{-# INLINE foldrWithKey #-}++-- | /O(n)/. A strict version of 'foldrWithKey'.+foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b+foldrWithKey' f = go+ where+ go z Tip = z+ go z (Bin _ kx x l r) = let z' = go z r+ in z `seq` z' `seq` go (f kx x z') l+{-# INLINE foldrWithKey' #-}++-- | /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 f = go+ where+ go z Tip = z+ go z (Bin _ kx x l r) = go (f (go z l) kx x) r+{-# INLINE foldlWithKey #-}++-- | /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) = let z' = go z l+ in z `seq` z' `seq` go (f z' kx x) r+{-# INLINE foldlWithKey' #-}++{--------------------------------------------------------------------+ List variations +--------------------------------------------------------------------}+-- | /O(n)/.+-- Return all elements of the map in the ascending order of their keys.+--+-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]+-- > elems empty == []++elems :: Map k a -> [a]+elems m+ = [x | (_,x) <- assocs m]+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE elems #-}+#endif++-- | /O(n)/. Return all keys of the map in ascending order.+--+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]+-- > keys empty == []++keys :: Map k a -> [k]+keys m+ = [k | (k,_) <- assocs m]+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE keys #-}+#endif++-- | /O(n)/. The set of all keys of the map.+--+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5]+-- > keysSet empty == Data.Set.empty++keysSet :: Map k a -> Set.Set k+keysSet m = Set.fromDistinctAscList (keys m)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE keysSet #-}+#endif++-- | /O(n)/. Return all key\/value pairs in the map in ascending key order.+--+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > assocs empty == []++assocs :: Map k a -> [(k,a)]+assocs m+ = toList m+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE assocs #-}+#endif++{--------------------------------------------------------------------+ Lists + use [foldlStrict] to reduce demand on the control-stack+--------------------------------------------------------------------}+-- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+--+-- > 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")]++fromList :: Ord k => [(k,a)] -> Map k a +fromList xs + = foldlStrict ins empty xs+ where+ ins t (k,x) = insert k x t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromList #-}+#endif++-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]+-- > fromListWith (++) [] == empty++fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a +fromListWith f xs+ = fromListWithKey (\_ x y -> f x y) xs+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromListWith #-}+#endif++-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.+--+-- > let f k a1 a2 = (show k) ++ a1 ++ a2+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]+-- > fromListWithKey f [] == empty++fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a +fromListWithKey f xs + = foldlStrict ins empty xs+ where+ ins t (k,x) = insertWithKey f k x t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromListWithKey #-}+#endif++-- | /O(n)/. Convert to a list of key\/value pairs.+--+-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > toList empty == []++toList :: Map k a -> [(k,a)]+toList t = toAscList t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE toList #-}+#endif++-- | /O(n)/. Convert to an ascending list.+--+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]++toAscList :: Map k a -> [(k,a)]+toAscList t = foldrWithKey (\k x xs -> (k,x):xs) [] t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE toAscList #-}+#endif++-- | /O(n)/. Convert to a descending list.+toDescList :: Map k a -> [(k,a)]+toDescList t = foldlWithKey (\xs k x -> (k,x):xs) [] t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE toDescList #-}+#endif++{--------------------------------------------------------------------+ Building trees from ascending/descending lists can be done in linear time.+ + Note that if [xs] is ascending that: + fromAscList xs == fromList xs+ fromAscListWith f xs == fromListWith f xs+--------------------------------------------------------------------}+-- | /O(n)/. Build a map from an ascending list in linear time.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]+-- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True+-- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False++fromAscList :: Eq k => [(k,a)] -> Map k a +fromAscList xs+ = fromAscListWithKey (\_ x _ -> x) xs+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromAscList #-}+#endif++-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]+-- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True+-- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False++fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a +fromAscListWith f xs+ = fromAscListWithKey (\_ x y -> f x y) xs+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromAscListWith #-}+#endif++-- | /O(n)/. Build a map from an ascending list in linear time with a+-- combining function for equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]+-- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True+-- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False++fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a +fromAscListWithKey f xs+ = fromDistinctAscList (combineEq f xs)+ where+ -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]+ combineEq _ xs'+ = case xs' of+ [] -> []+ [x] -> [x]+ (x:xx) -> combineEq' x xx++ combineEq' z [] = [z]+ combineEq' z@(kz,zz) (x@(kx,xx):xs')+ | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs'+ | otherwise = z:combineEq' x xs'+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromAscListWithKey #-}+#endif+++-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.+-- /The precondition is not checked./+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]+-- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True+-- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False++fromDistinctAscList :: [(k,a)] -> Map k a +fromDistinctAscList xs+ = build const (length xs) xs+ where+ -- 1) use continuations so that we use heap space instead of stack space.+ -- 2) special case for n==5 to build bushier trees. + build c 0 xs' = c Tip xs'+ build 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 build"+ build c n xs' = seq nr $ build (buildR nr c) nl xs'+ where+ nl = n `div` 2+ nr = n - nl - 1++ buildR n c l ((k,x):ys) = build (buildB l k x c) n ys+ buildR _ _ _ [] = error "fromDistinctAscList buildR []"+ buildB l k x c r zs = c (bin k x l r) zs+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromDistinctAscList #-}+#endif+++{--------------------------------------------------------------------+ Utility functions that return sub-ranges of the original+ tree. Some functions take a `Maybe value` as an argument to+ allow comparisons against infinite values. These are called `blow`+ (Nothing is -\infty) and `bhigh` (here Nothing is +\infty).+ We use MaybeS value, which is a Maybe strict in the Just case.++ [trim blow bhigh t] A tree that is either empty or where [x > blow]+ and [x < bhigh] for the value [x] of the root.+ [filterGt blow t] A tree where for all values [k]. [k > blow]+ [filterLt bhigh t] A tree where for all values [k]. [k < bhigh]++ [split k t] Returns two trees [l] and [r] where all keys+ in [l] are <[k] and all keys in [r] are >[k].+ [splitLookup k t] Just like [split] but also returns whether [k]+ was found in the tree.+--------------------------------------------------------------------}++data MaybeS a = NothingS | JustS !a++{--------------------------------------------------------------------+ [trim blo bhi t] trims away all subtrees that surely contain no+ values between the range [blo] to [bhi]. The returned tree is either+ empty or the key of the root is between @blo@ and @bhi@.+--------------------------------------------------------------------}+trim :: Ord k => MaybeS k -> MaybeS k -> Map k a -> Map k a+trim NothingS NothingS t = t+trim (JustS lk) NothingS t = greater lk t where greater lo (Bin _ k _ _ r) | k <= lo = greater lo r+ greater _ t' = t'+trim NothingS (JustS hk) t = lesser hk t where lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l+ lesser _ t' = t'+trim (JustS lk) (JustS hk) t = middle lk hk t where middle lo hi (Bin _ k _ _ r) | k <= lo = middle lo hi r+ middle lo hi (Bin _ k _ l _) | k >= hi = middle lo hi l+ middle _ _ t' = t'+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE trim #-}+#endif++trimLookupLo :: Ord k => k -> MaybeS k -> Map k a -> (Maybe (k,a), Map k a)+trimLookupLo _ _ Tip = (Nothing, Tip)+trimLookupLo lo hi t@(Bin _ kx x l r)+ = case compare lo kx of+ LT -> case compare' kx hi of+ LT -> (lookupAssoc lo t, t)+ _ -> trimLookupLo lo hi l+ GT -> trimLookupLo lo hi r+ EQ -> (Just (kx,x),trim (JustS lo) hi r)+ where compare' _ NothingS = LT+ compare' kx' (JustS hi') = compare kx' hi'+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE trimLookupLo #-}+#endif+++{--------------------------------------------------------------------+ [filterGt b t] filter all keys >[b] from tree [t]+ [filterLt b t] filter all keys <[b] from tree [t]+--------------------------------------------------------------------}+filterGt :: Ord k => MaybeS k -> Map k v -> Map k v+filterGt NothingS t = t+filterGt (JustS b) t = filter' b t+ where filter' _ Tip = Tip+ filter' b' (Bin _ kx x l r) =+ case compare b' kx of LT -> join kx x (filter' b' l) r+ EQ -> r+ GT -> filter' b' r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE filterGt #-}+#endif++filterLt :: Ord k => MaybeS k -> Map k v -> Map k v+filterLt NothingS t = t+filterLt (JustS b) t = filter' b t+ where filter' _ Tip = Tip+ filter' b' (Bin _ kx x l r) =+ case compare kx b' of LT -> join kx x l (filter' b' r)+ EQ -> l+ GT -> filter' b' l+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE filterLt #-}+#endif++{--------------------------------------------------------------------+ Split+--------------------------------------------------------------------}+-- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where+-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.+-- Any key equal to @k@ is found in neither @map1@ nor @map2@.+--+-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])+-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")+-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)+-- > 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)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE split #-}+#endif++-- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just+-- like 'split' but also returns @'lookup' k map@.+--+-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])+-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")+-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")+-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)+-- > 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 k t = k `seq`+ 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)+ EQ -> (l,Just x,r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE splitLookup #-}+#endif++-- | /O(log n)/.+splitLookupWithKey :: Ord k => k -> Map k a -> (Map k a,Maybe (k,a),Map k a)+splitLookupWithKey k t = k `seq`+ case t of+ Tip -> (Tip,Nothing,Tip)+ 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)+ EQ -> (l,Just (kx, x),r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE splitLookupWithKey #-}+#endif++{--------------------------------------------------------------------+ Utility functions that maintain the balance properties of the tree.+ All constructors assume that all values in [l] < [k] and all values+ in [r] > [k], and that [l] and [r] are valid trees.+ + In order of sophistication:+ [Bin sz k x l r] The type constructor.+ [bin k x l r] Maintains the correct size, assumes that both [l]+ and [r] are balanced with respect to each other.+ [balance k x l r] Restores the balance and size.+ Assumes that the original tree was balanced and+ that [l] or [r] has changed by at most one element.+ [join k x l r] Restores balance and size. ++ Furthermore, we can construct a new tree from two trees. Both operations+ assume that all values in [l] < all values in [r] and that [l] and [r]+ are valid:+ [glue l r] Glues [l] and [r] together. Assumes that [l] and+ [r] are already balanced with respect to each other.+ [merge l r] Merges two trees and restores balance.++ Note: in contrast to Adam's paper, we use (<=) comparisons instead+ of (<) comparisons in [join], [merge] and [balance]. + Quickcheck (on [difference]) showed that this was necessary in order + to maintain the invariants. It is quite unsatisfactory that I haven't + been able to find out why this is actually the case! Fortunately, it + doesn't hurt to be a bit more conservative.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+ Join +--------------------------------------------------------------------}+join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a+join kx x Tip r = insertMin kx x r+join kx x l Tip = insertMax kx x l+join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)+ | delta*sizeL < sizeR = balanceL kz z (join kx x l lz) rz+ | delta*sizeR < sizeL = balanceR ky y ly (join kx x ry r)+ | otherwise = bin kx x l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE join #-}+#endif+++-- insertMin and insertMax don't perform potentially expensive comparisons.+insertMax,insertMin :: k -> a -> Map k a -> Map k a +insertMax kx x t+ = case t of+ Tip -> singleton kx x+ Bin _ ky y l r+ -> balanceR ky y l (insertMax kx x r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertMax #-}+#endif++insertMin kx x t+ = case t of+ Tip -> singleton kx x+ Bin _ ky y l r+ -> balanceL ky y (insertMin kx x l) r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertMin #-}+#endif++{--------------------------------------------------------------------+ [merge l r]: merges two trees.+--------------------------------------------------------------------}+merge :: Map k a -> Map k a -> Map k a+merge Tip r = r+merge l Tip = l+merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)+ | delta*sizeL < sizeR = balanceL ky y (merge l ly) ry+ | delta*sizeR < sizeL = balanceR kx x lx (merge rx r)+ | otherwise = glue l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE merge #-}+#endif++{--------------------------------------------------------------------+ [glue l r]: glues two trees together.+ Assumes that [l] and [r] are already balanced with respect to each other.+--------------------------------------------------------------------}+glue :: Map k a -> Map k a -> Map k a+glue Tip r = r+glue l Tip = l+glue l r + | size l > size r = let ((km,m),l') = deleteFindMax l in balanceR km m l' r+ | otherwise = let ((km,m),r') = deleteFindMin r in balanceL km m l r'+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE glue #-}+#endif+++-- | /O(log n)/. Delete and find the minimal element.+--+-- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")]) +-- > deleteFindMin Error: can not return the minimal element of an empty map++deleteFindMin :: Map k a -> ((k,a),Map k a)+deleteFindMin t + = case t of+ Bin _ k x Tip r -> ((k,x),r)+ Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balanceR k x l' r)+ Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE deleteFindMin #-}+#endif++-- | /O(log n)/. Delete and find the maximal element.+--+-- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])+-- > deleteFindMax empty Error: can not return the maximal element of an empty map++deleteFindMax :: Map k a -> ((k,a),Map k a)+deleteFindMax t+ = case t of+ Bin _ k x l Tip -> ((k,x),l)+ Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balanceL k x l r')+ Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE deleteFindMax #-}+#endif+++{--------------------------------------------------------------------+ [balance l x r] balances two trees with value x.+ The sizes of the trees should balance after decreasing the+ size of one of them. (a rotation).++ [delta] is the maximal relative difference between the sizes of+ two trees, it corresponds with the [w] in Adams' paper.+ [ratio] is the ratio between an outer and inner sibling of the+ heavier subtree in an unbalanced setting. It determines+ whether a double or single rotation should be performed+ to restore balance. It is corresponds with the inverse+ of $\alpha$ in Adam's article.++ Note that according to the Adam's paper:+ - [delta] should be larger than 4.646 with a [ratio] of 2.+ - [delta] should be larger than 3.745 with a [ratio] of 1.534.++ But the Adam's paper is erroneous:+ - It can be proved that for delta=2 and delta>=5 there does+ not exist any ratio that would work.+ - Delta=4.5 and ratio=2 does not work.++ That leaves two reasonable variants, delta=3 and delta=4,+ both with ratio=2.++ - A lower [delta] leads to a more 'perfectly' balanced tree.+ - A higher [delta] performs less rebalancing.++ In the benchmarks, delta=3 is faster on insert operations,+ and delta=4 has slightly better deletes. As the insert speedup+ is larger, we currently use delta=3.++--------------------------------------------------------------------}+delta,ratio :: Int+delta = 3+ratio = 2++-- The balance function is equivalent to the following:+--+-- balance :: k -> a -> Map k a -> Map k a -> Map k a+-- balance k x l r+-- | sizeL + sizeR <= 1 = Bin sizeX k x l r+-- | sizeR > delta*sizeL = rotateL k x l r+-- | sizeL > delta*sizeR = rotateR k x l r+-- | otherwise = Bin sizeX k x l r+-- where+-- sizeL = size l+-- sizeR = size r+-- sizeX = sizeL + sizeR + 1+--+-- rotateL :: a -> b -> Map a b -> Map a b -> Map a b+-- rotateL k x l r@(Bin _ _ _ ly ry) | size ly < ratio*size ry = singleL k x l r+-- | otherwise = doubleL k x l r+--+-- rotateR :: a -> b -> Map a b -> Map a b -> Map a b+-- rotateR k x l@(Bin _ _ _ ly ry) r | size ry < ratio*size ly = singleR k x l r+-- | otherwise = doubleR k x l r+--+-- singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b+-- singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3+-- singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)+--+-- doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b+-- doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)+-- doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)+--+-- It is only written in such a way that every node is pattern-matched only once.++balance :: k -> a -> Map k a -> Map k a -> Map k a+balance k x l r = case l of+ Tip -> case r of+ Tip -> Bin 1 k x Tip Tip+ (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r+ (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr+ (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)+ (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))+ | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr+ | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)++ (Bin ls lk lx ll lr) -> case r of+ Tip -> case (ll, lr) of+ (Tip, Tip) -> Bin 2 k x l Tip+ (Tip, (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)+ ((Bin _ _ _ _ _), Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)+ ((Bin lls _ _ _ _), (Bin lrs lrk lrx lrl lrr))+ | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)+ | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)+ (Bin rs rk rx rl rr)+ | rs > delta*ls -> case (rl, rr) of+ (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)+ | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr+ | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)+ (_, _) -> error "Failure in Data.Map.balance"+ | ls > delta*rs -> case (ll, lr) of+ (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)+ | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)+ | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)+ (_, _) -> error "Failure in Data.Map.balance"+ | otherwise -> Bin (1+ls+rs) k x l r+{-# NOINLINE balance #-}++-- Functions balanceL and balanceR are specialised versions of balance.+-- balanceL only checks whether the left subtree is too big,+-- balanceR only checks whether the right subtree is too big.++-- balanceL is called when left subtree might have been inserted to or when+-- right subtree might have been deleted from.+balanceL :: k -> a -> Map k a -> Map k a -> Map k a+balanceL k x l r = case r of+ Tip -> case l of+ Tip -> Bin 1 k x Tip Tip+ (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip+ (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)+ (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)+ (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))+ | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)+ | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)++ (Bin rs _ _ _ _) -> case l of+ Tip -> Bin (1+rs) k x Tip r++ (Bin ls lk lx ll lr)+ | ls > delta*rs -> case (ll, lr) of+ (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)+ | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)+ | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)+ (_, _) -> error "Failure in Data.Map.balanceL"+ | otherwise -> Bin (1+ls+rs) k x l r+{-# NOINLINE balanceL #-}++-- balanceR is called when right subtree might have been inserted to or when+-- left subtree might have been deleted from.+balanceR :: k -> a -> Map k a -> Map k a -> Map k a+balanceR k x l r = case l of+ Tip -> case r of+ Tip -> Bin 1 k x Tip Tip+ (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r+ (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr+ (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)+ (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))+ | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr+ | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)++ (Bin ls _ _ _ _) -> case r of+ Tip -> Bin (1+ls) k x l Tip++ (Bin rs rk rx rl rr)+ | rs > delta*ls -> case (rl, rr) of+ (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)+ | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr+ | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)+ (_, _) -> error "Failure in Data.Map.balanceR"+ | otherwise -> Bin (1+ls+rs) k x l r+{-# NOINLINE balanceR #-}+++{--------------------------------------------------------------------+ The bin constructor maintains the size of the tree+--------------------------------------------------------------------}+bin :: k -> a -> Map k a -> Map k a -> Map k a+bin k x l r+ = Bin (size l + size r + 1) k x l r+{-# INLINE bin #-}+++{--------------------------------------------------------------------+ Eq converts the tree to a list. In a lazy setting, this + actually seems one of the faster methods to compare two trees + and it is certainly the simplest :-)+--------------------------------------------------------------------}+instance (Eq k,Eq a) => Eq (Map k a) where+ t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)++{--------------------------------------------------------------------+ Ord +--------------------------------------------------------------------}++instance (Ord k, Ord v) => Ord (Map k v) where+ compare m1 m2 = compare (toAscList m1) (toAscList m2)++{--------------------------------------------------------------------+ Functor+--------------------------------------------------------------------}+instance Functor (Map k) where+ fmap f m = map f m++instance Traversable (Map k) where+ traverse _ Tip = pure Tip+ traverse f (Bin s k v l r)+ = flip (Bin s k) <$> traverse f l <*> f v <*> traverse f r++instance Foldable (Map k) where+ foldMap _f Tip = mempty+ foldMap f (Bin _s _k v l r)+ = foldMap f l `mappend` f v `mappend` foldMap f r++{--------------------------------------------------------------------+ Read+--------------------------------------------------------------------}+instance (Ord k, Read k, Read e) => Read (Map k e) where+#ifdef __GLASGOW_HASKELL__+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif++{--------------------------------------------------------------------+ Show+--------------------------------------------------------------------}+instance (Show k, Show a) => Show (Map k a) where+ showsPrec d m = showParen (d > 10) $+ showString "fromList " . shows (toList m)++-- | /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+showTree m+ = showTreeWith showElem True False m+ where+ showElem k x = show k ++ ":=" ++ show x+++{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows+ the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.++> Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t+> (4,())+> +--(2,())+> | +--(1,())+> | +--(3,())+> +--(5,())+>+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t+> (4,())+> |+> +--(2,())+> | |+> | +--(1,())+> | |+> | +--(3,())+> |+> +--(5,())+>+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t+> +--(5,())+> |+> (4,())+> |+> | +--(3,())+> | |+> +--(2,())+> |+> +--(1,())++-}+showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String+showTreeWith showelem hang wide t+ | hang = (showsTreeHang showelem wide [] t) ""+ | otherwise = (showsTree showelem wide [] [] t) ""++showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS+showsTree showelem wide lbars rbars t+ = case t of+ Tip -> showsBars lbars . showString "|\n"+ Bin _ kx x Tip Tip+ -> showsBars lbars . showString (showelem kx x) . showString "\n" + Bin _ kx x l r+ -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .+ showWide wide rbars .+ showsBars lbars . showString (showelem kx x) . showString "\n" .+ showWide wide lbars .+ showsTree showelem wide (withEmpty lbars) (withBar lbars) l++showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS+showsTreeHang showelem wide bars t+ = case t of+ Tip -> showsBars bars . showString "|\n" + Bin _ kx x Tip Tip+ -> showsBars bars . showString (showelem kx x) . showString "\n" + Bin _ kx x l r+ -> showsBars bars . showString (showelem kx x) . showString "\n" . + showWide wide bars .+ showsTreeHang showelem wide (withBar bars) l .+ showWide wide bars .+ showsTreeHang showelem wide (withEmpty bars) r++showWide :: Bool -> [String] -> String -> String+showWide wide bars + | wide = showString (concat (reverse bars)) . showString "|\n" + | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+ = case bars of+ [] -> id+ _ -> showString (concat (reverse (tail bars))) . showString node++node :: String+node = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars = "| ":bars+withEmpty bars = " ":bars++{--------------------------------------------------------------------+ Typeable+--------------------------------------------------------------------}++#include "Typeable.h"+INSTANCE_TYPEABLE2(Map,mapTc,"Map")++{--------------------------------------------------------------------+ Assertions+--------------------------------------------------------------------}+-- | /O(n)/. Test if the internal map structure is valid.+--+-- > valid (fromAscList [(3,"b"), (5,"a")]) == True+-- > valid (fromAscList [(5,"a"), (3,"b")]) == False++valid :: Ord k => Map k a -> Bool+valid t+ = balanced t && ordered t && validsize t++ordered :: Ord a => Map a b -> Bool+ordered t+ = bounded (const True) (const True) t+ where+ bounded lo hi t'+ = case t' of+ Tip -> True+ Bin _ kx _ l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r++-- | Exported only for "Debug.QuickCheck"+balanced :: Map k a -> Bool+balanced t+ = case t of+ Tip -> True+ Bin _ _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&+ balanced l && balanced r++validsize :: Map a b -> Bool+validsize t+ = (realsize t == Just (size t))+ where+ realsize t'+ = case t' of+ Tip -> Just 0+ Bin sz _ _ l r -> case (realsize l,realsize r) of+ (Just n,Just m) | n+m+1 == sz -> Just sz+ _ -> Nothing++{--------------------------------------------------------------------+ Utilities+--------------------------------------------------------------------}+foldlStrict :: (a -> b -> a) -> a -> [b] -> a+foldlStrict f = go+ where+ go z [] = z+ go z (x:xs) = let z' = f z x in z' `seq` go z' xs+{-# INLINE foldlStrict #-}
Data/Sequence.hs view
@@ -1,1845 +1,1853 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS -cpp #-}--------------------------------------------------------------------------------- |--- Module : Data.Sequence--- Copyright : (c) Ross Paterson 2005--- (c) Louis Wasserman 2009--- License : BSD-style--- Maintainer : libraries@haskell.org--- Stability : experimental--- Portability : portable------ General purpose finite sequences.--- Apart from being finite and having strict operations, sequences--- also differ from lists in supporting a wider variety of operations--- efficiently.------ An amortized running time is given for each operation, with /n/ referring--- to the length of the sequence and /i/ being the integral index used by--- some operations. These bounds hold even in a persistent (shared) setting.------ The implementation uses 2-3 finger trees annotated with sizes,--- as described in section 4.2 of------ * Ralf Hinze and Ross Paterson,--- \"Finger trees: a simple general-purpose data structure\",--- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.--- <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>------ /Note/: Many of these operations have the same names as similar--- operations on lists in the "Prelude". The ambiguity may be resolved--- using either qualification or the @hiding@ clause.-----------------------------------------------------------------------------------module Data.Sequence (- Seq,- -- * Construction- empty, -- :: Seq a- singleton, -- :: a -> Seq a- (<|), -- :: a -> Seq a -> Seq a- (|>), -- :: Seq a -> a -> Seq a- (><), -- :: Seq a -> Seq a -> Seq a- fromList, -- :: [a] -> Seq a- -- ** Repetition- replicate, -- :: Int -> a -> Seq a- replicateA, -- :: Applicative f => Int -> f a -> f (Seq a)- replicateM, -- :: Monad m => Int -> m a -> m (Seq a)- -- ** Iterative construction- iterateN, -- :: Int -> (a -> a) -> a -> Seq a- unfoldr, -- :: (b -> Maybe (a, b)) -> b -> Seq a- unfoldl, -- :: (b -> Maybe (b, a)) -> b -> Seq a- -- * Deconstruction- -- | Additional functions for deconstructing sequences are available- -- via the 'Foldable' instance of 'Seq'.-- -- ** Queries- null, -- :: Seq a -> Bool- length, -- :: Seq a -> Int- -- ** Views- ViewL(..),- viewl, -- :: Seq a -> ViewL a- ViewR(..),- viewr, -- :: Seq a -> ViewR a- -- * Scans- scanl, -- :: (a -> b -> a) -> a -> Seq b -> Seq a- scanl1, -- :: (a -> a -> a) -> Seq a -> Seq a- scanr, -- :: (a -> b -> b) -> b -> Seq a -> Seq b- scanr1, -- :: (a -> a -> a) -> Seq a -> Seq a- -- * Sublists- tails, -- :: Seq a -> Seq (Seq a)- inits, -- :: Seq a -> Seq (Seq a)- -- ** Sequential searches- takeWhileL, -- :: (a -> Bool) -> Seq a -> Seq a- takeWhileR, -- :: (a -> Bool) -> Seq a -> Seq a- dropWhileL, -- :: (a -> Bool) -> Seq a -> Seq a- dropWhileR, -- :: (a -> Bool) -> Seq a -> Seq a- spanl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)- spanr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)- breakl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)- breakr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)- partition, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)- filter, -- :: (a -> Bool) -> Seq a -> Seq a- -- * Sorting- sort, -- :: Ord a => Seq a -> Seq a- sortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a- unstableSort, -- :: Ord a => Seq a -> Seq a- unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a- -- * Indexing- index, -- :: Seq a -> Int -> a- adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a- update, -- :: Int -> a -> Seq a -> Seq a- take, -- :: Int -> Seq a -> Seq a- drop, -- :: Int -> Seq a -> Seq a- splitAt, -- :: Int -> Seq a -> (Seq a, Seq a)- -- ** Indexing with predicates- -- | These functions perform sequential searches from the left- -- or right ends of the sequence, returning indices of matching- -- elements.- elemIndexL, -- :: Eq a => a -> Seq a -> Maybe Int- elemIndicesL, -- :: Eq a => a -> Seq a -> [Int]- elemIndexR, -- :: Eq a => a -> Seq a -> Maybe Int- elemIndicesR, -- :: Eq a => a -> Seq a -> [Int]- findIndexL, -- :: (a -> Bool) -> Seq a -> Maybe Int- findIndicesL, -- :: (a -> Bool) -> Seq a -> [Int]- findIndexR, -- :: (a -> Bool) -> Seq a -> Maybe Int- findIndicesR, -- :: (a -> Bool) -> Seq a -> [Int]- -- * Folds- -- | General folds are available via the 'Foldable' instance of 'Seq'.- foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b- foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b- -- * Transformations- mapWithIndex, -- :: (Int -> a -> b) -> Seq a -> Seq b- reverse, -- :: Seq a -> Seq a- -- ** Zips- zip, -- :: Seq a -> Seq b -> Seq (a, b)- zipWith, -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c- zip3, -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)- zipWith3, -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d- zip4, -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)- zipWith4, -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e-#if TESTING- valid,-#endif- ) where--import Prelude hiding (- Functor(..),- null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,- scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,- takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)-import qualified Data.List (foldl', sortBy)-import Control.Applicative (Applicative(..), (<$>), WrappedMonad(..), liftA, liftA2, liftA3)-import Control.Monad (MonadPlus(..), ap)-import Data.Monoid (Monoid(..))-import Data.Functor (Functor(..))-import Data.Foldable-import Data.Traversable-#ifndef __GLASGOW_HASKELL__-import Data.Typeable (Typeable, typeOf, typeOfDefault)-#endif-import Data.Typeable (TyCon, Typeable1(..), mkTyCon, mkTyConApp )--#ifdef __GLASGOW_HASKELL__-import GHC.Exts (build)-import Text.Read (Lexeme(Ident), lexP, parens, prec,- readPrec, readListPrec, readListPrecDefault)-import Data.Data (Data(..), DataType, Constr, Fixity(..),- mkConstr, mkDataType, constrIndex, gcast1)-#endif--#if TESTING-import Control.Monad (liftM, liftM2, liftM3, liftM4)-import qualified Data.List (zipWith)-import Test.QuickCheck hiding ((><))-#endif--infixr 5 `consTree`-infixl 5 `snocTree`--infixr 5 ><-infixr 5 <|, :<-infixl 5 |>, :>--class Sized a where- size :: a -> Int---- | General-purpose finite sequences.-newtype Seq a = Seq (FingerTree (Elem a))--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- foldl f z (Seq xs) = foldl (foldl f) z xs-- foldr1 f (Seq xs) = getElem (foldr1 f' xs)- where f' (Elem x) (Elem y) = Elem (f x y)-- foldl1 f (Seq xs) = getElem (foldl1 f' xs)- where f' (Elem x) (Elem y) = Elem (f x y)--instance Traversable Seq where- traverse f (Seq xs) = Seq <$> traverse (traverse f) xs--instance Monad Seq where- return = singleton- xs >>= f = foldl' add empty xs- where add ys x = ys >< f x--instance MonadPlus Seq where- mzero = empty- mplus = (><)--instance Eq a => Eq (Seq a) where- xs == ys = length xs == length ys && toList xs == toList ys--instance Ord a => Ord (Seq a) where- compare xs ys = compare (toList xs) (toList ys)--#if TESTING-instance Show a => Show (Seq a) where- showsPrec p (Seq x) = showsPrec p x-#else-instance Show a => Show (Seq a) where- showsPrec p xs = showParen (p > 10) $- showString "fromList " . shows (toList xs)-#endif--instance Read a => Read (Seq a) where-#ifdef __GLASGOW_HASKELL__- readPrec = parens $ prec 10 $ do- Ident "fromList" <- lexP- xs <- readPrec- return (fromList xs)-- readListPrec = readListPrecDefault-#else- readsPrec p = readParen (p > 10) $ \ r -> do- ("fromList",s) <- lex r- (xs,t) <- reads s- return (fromList xs,t)-#endif--instance Monoid (Seq a) where- mempty = empty- mappend = (><)--#include "Typeable.h"-INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")--#if __GLASGOW_HASKELL__-instance Data a => Data (Seq a) where- gfoldl f z s = case viewl s of- EmptyL -> z empty- x :< xs -> z (<|) `f` x `f` xs-- gunfold k z c = case constrIndex c of- 1 -> z empty- 2 -> k (k (z (<|)))- _ -> error "gunfold"-- toConstr xs- | null xs = emptyConstr- | otherwise = consConstr-- dataTypeOf _ = seqDataType-- dataCast1 f = gcast1 f--emptyConstr, consConstr :: Constr-emptyConstr = mkConstr seqDataType "empty" [] Prefix-consConstr = mkConstr seqDataType "<|" [] Infix--seqDataType :: DataType-seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]-#endif---- Finger trees--data FingerTree a- = Empty- | Single a- | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)-#if TESTING- deriving Show-#endif--instance Sized a => Sized (FingerTree a) where- {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}- {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}- size Empty = 0- size (Single x) = size x- size (Deep v _ _ _) = v--instance Foldable FingerTree where- foldr _ z Empty = z- foldr f z (Single x) = x `f` z- foldr f z (Deep _ pr m sf) =- foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr-- foldl _ z Empty = z- foldl f z (Single x) = z `f` x- foldl f z (Deep _ pr m sf) =- foldl f (foldl (foldl f) (foldl f z pr) m) sf-- foldr1 _ Empty = error "foldr1: empty sequence"- foldr1 _ (Single x) = x- foldr1 f (Deep _ pr m sf) =- foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr-- foldl1 _ Empty = error "foldl1: empty sequence"- foldl1 _ (Single x) = x- foldl1 f (Deep _ pr m sf) =- foldl f (foldl (foldl f) (foldl1 f pr) m) sf--instance Functor FingerTree where- fmap _ Empty = Empty- fmap f (Single x) = Single (f x)- fmap f (Deep v pr m sf) =- Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)--instance Traversable FingerTree where- traverse _ Empty = pure Empty- traverse f (Single x) = Single <$> f x- traverse f (Deep v pr m sf) =- Deep v <$> traverse f pr <*> traverse (traverse f) m <*>- traverse f sf--{-# INLINE deep #-}-{-# SPECIALIZE INLINE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}-{-# SPECIALIZE INLINE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}-deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a-deep pr m sf = Deep (size pr + size m + size sf) pr m sf--{-# INLINE pullL #-}-pullL :: Sized a => Int -> FingerTree (Node a) -> Digit a -> FingerTree a-pullL s m sf = case viewLTree m of- Nothing2 -> digitToTree' s sf- Just2 pr m' -> Deep s (nodeToDigit pr) m' sf--{-# INLINE pullR #-}-pullR :: Sized a => Int -> Digit a -> FingerTree (Node a) -> FingerTree a-pullR s pr m = case viewRTree m of- Nothing2 -> digitToTree' s pr- Just2 m' sf -> Deep s pr m' (nodeToDigit sf)--{-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}-{-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}-deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a-deepL Nothing m sf = pullL (size m + size sf) m sf-deepL (Just pr) m sf = deep pr m sf--{-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}-{-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}-deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a-deepR pr m Nothing = pullR (size m + size pr) pr m-deepR pr m (Just sf) = deep pr m sf---- Digits--data Digit a- = One a- | Two a a- | Three a a a- | Four a a a a-#if TESTING- deriving Show-#endif--instance Foldable Digit where- foldr f z (One a) = a `f` z- foldr f z (Two a b) = a `f` (b `f` z)- foldr f z (Three a b c) = a `f` (b `f` (c `f` z))- foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))-- foldl f z (One a) = z `f` a- foldl f z (Two a b) = (z `f` a) `f` b- foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c- foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d-- foldr1 _ (One a) = a- foldr1 f (Two a b) = a `f` b- foldr1 f (Three a b c) = a `f` (b `f` c)- foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))-- foldl1 _ (One a) = a- foldl1 f (Two a b) = a `f` b- foldl1 f (Three a b c) = (a `f` b) `f` c- foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d--instance Functor Digit where- fmap = fmapDefault--instance Traversable Digit where- {-# INLINE traverse #-}- traverse f (One a) = One <$> f a- traverse f (Two a b) = Two <$> f a <*> f b- traverse f (Three a b c) = Three <$> f a <*> f b <*> f c- traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d--instance Sized a => Sized (Digit a) where- {-# INLINE size #-}- size = foldl1 (+) . fmap size--{-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}-{-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}-digitToTree :: Sized a => Digit a -> FingerTree a-digitToTree (One a) = Single a-digitToTree (Two a b) = deep (One a) Empty (One b)-digitToTree (Three a b c) = deep (Two a b) Empty (One c)-digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)---- | Given the size of a digit and the digit itself, efficiently converts--- it to a FingerTree.-digitToTree' :: Int -> Digit a -> FingerTree a-digitToTree' n (Four a b c d) = Deep n (Two a b) Empty (Two c d)-digitToTree' n (Three a b c) = Deep n (Two a b) Empty (One c)-digitToTree' n (Two a b) = Deep n (One a) Empty (One b)-digitToTree' n (One a) = n `seq` Single a---- Nodes--data Node a- = Node2 {-# UNPACK #-} !Int a a- | Node3 {-# UNPACK #-} !Int a a a-#if TESTING- deriving Show-#endif--instance Foldable Node where- foldr f z (Node2 _ a b) = a `f` (b `f` z)- foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))-- foldl f z (Node2 _ a b) = (z `f` a) `f` b- foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c--instance Functor Node where- {-# INLINE fmap #-}- fmap = fmapDefault--instance Traversable Node where- {-# INLINE traverse #-}- traverse f (Node2 v a b) = Node2 v <$> f a <*> f b- traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c--instance Sized (Node a) where- size (Node2 v _ _) = v- size (Node3 v _ _ _) = v--{-# INLINE node2 #-}-{-# SPECIALIZE node2 :: Elem a -> Elem a -> Node (Elem a) #-}-{-# SPECIALIZE node2 :: Node a -> Node a -> Node (Node a) #-}-node2 :: Sized a => a -> a -> Node a-node2 a b = Node2 (size a + size b) a b--{-# INLINE node3 #-}-{-# SPECIALIZE node3 :: Elem a -> Elem a -> Elem a -> Node (Elem a) #-}-{-# SPECIALIZE node3 :: Node a -> Node a -> Node a -> Node (Node a) #-}-node3 :: Sized a => a -> a -> a -> Node a-node3 a b c = Node3 (size a + size b + size c) a b c--nodeToDigit :: Node a -> Digit a-nodeToDigit (Node2 _ a b) = Two a b-nodeToDigit (Node3 _ a b c) = Three a b c---- Elements--newtype Elem a = Elem { getElem :: a }--instance Sized (Elem a) where- size _ = 1--instance Functor Elem where- fmap f (Elem x) = Elem (f x)--instance Foldable Elem where- foldr f z (Elem x) = f x z- foldl f z (Elem x) = f z x--instance Traversable Elem where- traverse f (Elem x) = Elem <$> f x--#ifdef TESTING-instance (Show a) => Show (Elem a) where- showsPrec p (Elem x) = showsPrec p x-#endif------------------------------------------------------------ Applicative construction----------------------------------------------------------newtype Id a = Id {runId :: a}--instance Functor Id where- fmap f (Id x) = Id (f x)--instance Monad Id where- return = Id- m >>= k = k (runId m)--instance Applicative Id where- pure = return- (<*>) = ap---- | This is essentially a clone of Control.Monad.State.Strict.-newtype State s a = State {runState :: s -> (s, a)}--instance Functor (State s) where- fmap = liftA--instance Monad (State s) where- {-# INLINE return #-}- {-# INLINE (>>=) #-}- return x = State $ \ s -> (s, x)- m >>= k = State $ \ s -> case runState m s of- (s', x) -> runState (k x) s'--instance Applicative (State s) where- pure = return- (<*>) = ap--execState :: State s a -> s -> a-execState m x = snd (runState m x)---- | A helper method: a strict version of mapAccumL.-mapAccumL' :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)-mapAccumL' f s t = runState (traverse (State . flip f) t) s---- | 'applicativeTree' takes an Applicative-wrapped construction of a--- piece of a FingerTree, assumed to always have the same size (which--- is put in the second argument), and replicates it as many times as--- specified. This is a generalization of 'replicateA', which itself--- is a generalization of many Data.Sequence methods.-{-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}-{-# 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 :: 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- 2 -> deepA one emptyTree one- 3 -> deepA two emptyTree one- 4 -> deepA two emptyTree two- 5 -> deepA three emptyTree two- 6 -> deepA three emptyTree three- 7 -> deepA four emptyTree three- 8 -> deepA four emptyTree four- _ -> let (q, r) = n `quotRem` 3 in q `seq` case r of- 0 -> deepA three (applicativeTree (q - 2) mSize' n3) three- 1 -> deepA four (applicativeTree (q - 2) mSize' n3) three- _ -> deepA four (applicativeTree (q - 2) mSize' n3) four- where- one = liftA One m- two = liftA2 Two m m- three = liftA3 Three m m m- four = liftA3 Four m m m <*> m- deepA = liftA3 (Deep (n * mSize))- mSize' = 3 * mSize- n3 = liftA3 (Node3 mSize') m m m-- emptyTree :: forall b. f (FingerTree b)- emptyTree = pure Empty----------------------------------------------------------------------------- Construction----------------------------------------------------------------------------- | /O(1)/. The empty sequence.-empty :: Seq a-empty = Seq Empty---- | /O(1)/. A singleton sequence.-singleton :: a -> Seq a-singleton x = Seq (Single (Elem x))---- | /O(log n)/. @replicate n x@ is a sequence consisting of @n@ copies of @x@.-replicate :: Int -> a -> Seq a-replicate n x- | n >= 0 = runId (replicateA n (Id x))- | otherwise = error "replicate takes a nonnegative integer argument"---- | 'replicateA' is an 'Applicative' version of 'replicate', and makes--- /O(log n)/ calls to '<*>' and 'pure'.------ > replicateA n x = sequenceA (replicate n x)-replicateA :: Applicative f => Int -> f a -> f (Seq a)-replicateA n x- | n >= 0 = Seq <$> applicativeTree n 1 (Elem <$> x)- | otherwise = error "replicateA takes a nonnegative integer argument"---- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'.------ > replicateM n x = sequence (replicate n x)-replicateM :: Monad m => Int -> m a -> m (Seq a)-replicateM n x- | n >= 0 = unwrapMonad (replicateA n (WrapMonad x))- | otherwise = error "replicateM takes a nonnegative integer argument"---- | /O(1)/. Add an element to the left end of a sequence.--- Mnemonic: a triangle with the single element at the pointy end.-(<|) :: a -> Seq a -> Seq a-x <| Seq xs = Seq (Elem x `consTree` xs)--{-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}-{-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}-consTree :: Sized a => a -> FingerTree a -> FingerTree a-consTree a Empty = Single a-consTree a (Single b) = deep (One a) Empty (One b)-consTree a (Deep s (Four b c d e) m sf) = m `seq`- Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf-consTree a (Deep s (Three b c d) m sf) =- Deep (size a + s) (Four a b c d) m sf-consTree a (Deep s (Two b c) m sf) =- Deep (size a + s) (Three a b c) m sf-consTree a (Deep s (One b) m sf) =- Deep (size a + s) (Two a b) m sf---- | /O(1)/. Add an element to the right end of a sequence.--- Mnemonic: a triangle with the single element at the pointy end.-(|>) :: Seq a -> a -> Seq a-Seq xs |> x = Seq (xs `snocTree` Elem x)--{-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}-{-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}-snocTree :: Sized a => FingerTree a -> a -> FingerTree a-snocTree Empty a = Single a-snocTree (Single a) b = deep (One a) Empty (One b)-snocTree (Deep s pr m (Four a b c d)) e = m `seq`- Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)-snocTree (Deep s pr m (Three a b c)) d =- Deep (s + size d) pr m (Four a b c d)-snocTree (Deep s pr m (Two a b)) c =- Deep (s + size c) pr m (Three a b c)-snocTree (Deep s pr m (One a)) b =- Deep (s + size b) pr m (Two a b)---- | /O(log(min(n1,n2)))/. Concatenate two sequences.-(><) :: Seq a -> Seq a -> Seq a-Seq xs >< Seq ys = Seq (appendTree0 xs ys)---- The appendTree/addDigits gunk below is machine generated--appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)-appendTree0 Empty xs =- xs-appendTree0 xs Empty =- xs-appendTree0 (Single x) xs =- x `consTree` xs-appendTree0 xs (Single x) =- xs `snocTree` x-appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =- Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2--addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))-addDigits0 m1 (One a) (One b) m2 =- appendTree1 m1 (node2 a b) m2-addDigits0 m1 (One a) (Two b c) m2 =- appendTree1 m1 (node3 a b c) m2-addDigits0 m1 (One a) (Three b c d) m2 =- appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits0 m1 (One a) (Four b c d e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Two a b) (One c) m2 =- appendTree1 m1 (node3 a b c) m2-addDigits0 m1 (Two a b) (Two c d) m2 =- appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits0 m1 (Two a b) (Three c d e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Two a b) (Four c d e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits0 m1 (Three a b c) (One d) m2 =- appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits0 m1 (Three a b c) (Two d e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Three a b c) (Three d e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits0 m1 (Three a b c) (Four d e f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits0 m1 (Four a b c d) (One e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Four a b c d) (Two e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits0 m1 (Four a b c d) (Three e f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits0 m1 (Four a b c d) (Four e f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2--appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)-appendTree1 Empty a xs =- a `consTree` xs-appendTree1 xs a Empty =- xs `snocTree` a-appendTree1 (Single x) a xs =- x `consTree` a `consTree` xs-appendTree1 xs a (Single x) =- xs `snocTree` a `snocTree` x-appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =- Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2--addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))-addDigits1 m1 (One a) b (One c) m2 =- appendTree1 m1 (node3 a b c) m2-addDigits1 m1 (One a) b (Two c d) m2 =- appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits1 m1 (One a) b (Three c d e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits1 m1 (One a) b (Four c d e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Two a b) c (One d) m2 =- appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits1 m1 (Two a b) c (Two d e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits1 m1 (Two a b) c (Three d e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Two a b) c (Four d e f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits1 m1 (Three a b c) d (One e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits1 m1 (Three a b c) d (Two e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Three a b c) d (Three e f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits1 m1 (Three a b c) d (Four e f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits1 m1 (Four a b c d) e (One f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Four a b c d) e (Two f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits1 m1 (Four a b c d) e (Three f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2--appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)-appendTree2 Empty a b xs =- a `consTree` b `consTree` xs-appendTree2 xs a b Empty =- xs `snocTree` a `snocTree` b-appendTree2 (Single x) a b xs =- x `consTree` a `consTree` b `consTree` xs-appendTree2 xs a b (Single x) =- xs `snocTree` a `snocTree` b `snocTree` x-appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =- Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2--addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))-addDigits2 m1 (One a) b c (One d) m2 =- appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits2 m1 (One a) b c (Two d e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits2 m1 (One a) b c (Three d e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits2 m1 (One a) b c (Four d e f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Two a b) c d (One e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits2 m1 (Two a b) c d (Two e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits2 m1 (Two a b) c d (Three e f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Two a b) c d (Four e f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits2 m1 (Three a b c) d e (One f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits2 m1 (Three a b c) d e (Two f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Three a b c) d e (Three f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits2 m1 (Four a b c d) e f (One g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Four a b c d) e f (Two g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2--appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)-appendTree3 Empty a b c xs =- a `consTree` b `consTree` c `consTree` xs-appendTree3 xs a b c Empty =- xs `snocTree` a `snocTree` b `snocTree` c-appendTree3 (Single x) a b c xs =- x `consTree` a `consTree` b `consTree` c `consTree` xs-appendTree3 xs a b c (Single x) =- xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x-appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =- Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2--addDigits3 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))-addDigits3 m1 (One a) b c d (One e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits3 m1 (One a) b c d (Two e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits3 m1 (One a) b c d (Three e f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits3 m1 (One a) b c d (Four e f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Two a b) c d e (One f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits3 m1 (Two a b) c d e (Two f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits3 m1 (Two a b) c d e (Three f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits3 m1 (Three a b c) d e f (One g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits3 m1 (Three a b c) d e f (Two g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits3 m1 (Four a b c d) e f g (One h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2--appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)-appendTree4 Empty a b c d xs =- a `consTree` b `consTree` c `consTree` d `consTree` xs-appendTree4 xs a b c d Empty =- xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d-appendTree4 (Single x) a b c d xs =- x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs-appendTree4 xs a b c d (Single x) =- xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x-appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =- Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2--addDigits4 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))-addDigits4 m1 (One a) b c d e (One f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits4 m1 (One a) b c d e (Two f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits4 m1 (One a) b c d e (Three f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits4 m1 (One a) b c d e (Four f g h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Two a b) c d e f (One g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits4 m1 (Two a b) c d e f (Two g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits4 m1 (Three a b c) d e f g (One h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2-addDigits4 m1 (Four a b c d) e f g h (One i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2-addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2---- | Builds a sequence from a seed value. Takes time linear in the--- number of generated elements. /WARNING:/ If the number of generated--- elements is infinite, this method will not terminate.-unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a-unfoldr f = unfoldr' empty- -- uses tail recursion rather than, for instance, the List implementation.- where unfoldr' as b = maybe as (\ (a, b') -> unfoldr' (as |> a) b') (f b)---- | @'unfoldl' f x@ is equivalent to @'reverse' ('unfoldr' (swap . f) x)@.-unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a-unfoldl f = unfoldl' empty- where unfoldl' as b = maybe as (\ (b', a) -> unfoldl' (a <| as) b') (f b)---- | /O(n)/. Constructs a sequence by repeated application of a function--- to a seed value.------ > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))-iterateN :: Int -> (a -> a) -> a -> Seq a-iterateN n f x- | n >= 0 = replicateA n (State (\ y -> (f y, y))) `execState` x- | otherwise = error "iterateN takes a nonnegative integer argument"----------------------------------------------------------------------------- Deconstruction----------------------------------------------------------------------------- | /O(1)/. Is this the empty sequence?-null :: Seq a -> Bool-null (Seq Empty) = True-null _ = False---- | /O(1)/. The number of elements in the sequence.-length :: Seq a -> Int-length (Seq xs) = size xs---- Views--data Maybe2 a b = Nothing2 | Just2 a b---- | View of the left end of a sequence.-data ViewL a- = EmptyL -- ^ empty sequence- | a :< Seq a -- ^ leftmost element and the rest of the sequence-#ifndef __HADDOCK__-# if __GLASGOW_HASKELL__- deriving (Eq, Ord, Show, Read, Data)-# else- deriving (Eq, Ord, Show, Read)-# endif-#else-instance Eq a => Eq (ViewL a)-instance Ord a => Ord (ViewL a)-instance Show a => Show (ViewL a)-instance Read a => Read (ViewL a)-instance Data a => Data (ViewL a)-#endif--INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")--instance Functor ViewL where- fmap = fmapDefault--instance Foldable ViewL where- foldr _ z EmptyL = z- foldr f z (x :< xs) = f x (foldr f z xs)-- foldl _ z EmptyL = z- foldl f z (x :< xs) = foldl f (f z x) xs-- foldl1 _ EmptyL = error "foldl1: empty view"- foldl1 f (x :< xs) = foldl f x xs--instance Traversable ViewL where- traverse _ EmptyL = pure EmptyL- traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs---- | /O(1)/. Analyse the left end of a sequence.-viewl :: Seq a -> ViewL a-viewl (Seq xs) = case viewLTree xs of- Nothing2 -> EmptyL- Just2 (Elem x) xs' -> x :< Seq xs'--{-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-}-{-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-}-viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)-viewLTree Empty = Nothing2-viewLTree (Single a) = Just2 a Empty-viewLTree (Deep s (One a) m sf) = Just2 a (pullL (s - size a) m sf)-viewLTree (Deep s (Two a b) m sf) =- Just2 a (Deep (s - size a) (One b) m sf)-viewLTree (Deep s (Three a b c) m sf) =- Just2 a (Deep (s - size a) (Two b c) m sf)-viewLTree (Deep s (Four a b c d) m sf) =- Just2 a (Deep (s - size a) (Three b c d) m sf)---- | View of the right end of a sequence.-data ViewR a- = EmptyR -- ^ empty sequence- | Seq a :> a -- ^ the sequence minus the rightmost element,- -- and the rightmost element-#ifndef __HADDOCK__-# if __GLASGOW_HASKELL__- deriving (Eq, Ord, Show, Read, Data)-# else- deriving (Eq, Ord, Show, Read)-# endif-#else-instance Eq a => Eq (ViewR a)-instance Ord a => Ord (ViewR a)-instance Show a => Show (ViewR a)-instance Read a => Read (ViewR a)-instance Data a => Data (ViewR a)-#endif--INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")--instance Functor ViewR where- fmap = fmapDefault--instance Foldable ViewR where- foldr _ z EmptyR = z- foldr f z (xs :> x) = foldr f (f x z) xs-- foldl _ z EmptyR = z- foldl f z (xs :> x) = foldl f z xs `f` x-- foldr1 _ EmptyR = error "foldr1: empty view"- foldr1 f (xs :> x) = foldr f x xs--instance Traversable ViewR where- traverse _ EmptyR = pure EmptyR- traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x---- | /O(1)/. Analyse the right end of a sequence.-viewr :: Seq a -> ViewR a-viewr (Seq xs) = case viewRTree xs of- Nothing2 -> EmptyR- Just2 xs' (Elem x) -> Seq xs' :> x--{-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-}-{-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-}-viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a-viewRTree Empty = Nothing2-viewRTree (Single z) = Just2 Empty z-viewRTree (Deep s pr m (One z)) = Just2 (pullR (s - size z) pr m) z-viewRTree (Deep s pr m (Two y z)) =- Just2 (Deep (s - size z) pr m (One y)) z-viewRTree (Deep s pr m (Three x y z)) =- Just2 (Deep (s - size z) pr m (Two x y)) z-viewRTree (Deep s pr m (Four w x y z)) =- Just2 (Deep (s - size z) pr m (Three w x y)) z----------------------------------------------------------------------------- Scans------ These are not particularly complex applications of the Traversable--- functor, though making the correspondence with Data.List exact--- requires the use of (<|) and (|>).------ Note that save for the single (<|) or (|>), we maintain the original--- structure of the Seq, not having to do any restructuring of our own.------ wasserman.louis@gmail.com, 5/23/09----------------------------------------------------------------------------- | 'scanl' is similar to 'foldl', but returns a sequence of reduced--- values from the left:------ > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]-scanl :: (a -> b -> a) -> a -> Seq b -> Seq a-scanl f z0 xs = z0 <| snd (mapAccumL (\ x z -> let x' = f x z in (x', x')) z0 xs)---- | 'scanl1' is a variant of 'scanl' that has no starting value argument:------ > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]-scanl1 :: (a -> a -> a) -> Seq a -> Seq a-scanl1 f xs = case viewl xs of- EmptyL -> error "scanl1 takes a nonempty sequence as an argument"- x :< xs' -> scanl f x xs'---- | 'scanr' is the right-to-left dual of 'scanl'.-scanr :: (a -> b -> b) -> b -> Seq a -> Seq b-scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0---- | 'scanr1' is a variant of 'scanr' that has no starting value argument.-scanr1 :: (a -> a -> a) -> Seq a -> Seq a-scanr1 f xs = case viewr xs of- EmptyR -> error "scanr1 takes a nonempty sequence as an argument"- xs' :> x -> scanr f x xs'---- Indexing---- | /O(log(min(i,n-i)))/. The element at the specified position,--- counting from 0. The argument should thus be a non-negative--- integer less than the size of the sequence.--- If the position is out of range, 'index' fails with an error.-index :: Seq a -> Int -> a-index (Seq xs) i- | 0 <= i && i < size xs = case lookupTree i xs of- Place _ (Elem x) -> x- | otherwise = error "index out of bounds"--data Place a = Place {-# UNPACK #-} !Int a-#if TESTING- deriving Show-#endif--{-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}-{-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}-lookupTree :: Sized a => Int -> FingerTree a -> Place a-lookupTree _ Empty = error "lookupTree of empty tree"-lookupTree i (Single x) = Place i x-lookupTree i (Deep _ pr m sf)- | i < spr = lookupDigit i pr- | i < spm = case lookupTree (i - spr) m of- Place i' xs -> lookupNode i' xs- | otherwise = lookupDigit (i - spm) sf- where spr = size pr- spm = spr + size m--{-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}-{-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}-lookupNode :: Sized a => Int -> Node a -> Place a-lookupNode i (Node2 _ a b)- | i < sa = Place i a- | otherwise = Place (i - sa) b- where sa = size a-lookupNode i (Node3 _ a b c)- | i < sa = Place i a- | i < sab = Place (i - sa) b- | otherwise = Place (i - sab) c- where sa = size a- sab = sa + size b--{-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}-{-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}-lookupDigit :: Sized a => Int -> Digit a -> Place a-lookupDigit i (One a) = Place i a-lookupDigit i (Two a b)- | i < sa = Place i a- | otherwise = Place (i - sa) b- where sa = size a-lookupDigit i (Three a b c)- | i < sa = Place i a- | i < sab = Place (i - sa) b- | otherwise = Place (i - sab) c- where sa = size a- sab = sa + size b-lookupDigit i (Four a b c d)- | i < sa = Place i a- | i < sab = Place (i - sa) b- | i < sabc = Place (i - sab) c- | otherwise = Place (i - sabc) d- where sa = size a- sab = sa + size b- sabc = sab + size c---- | /O(log(min(i,n-i)))/. Replace the element at the specified position.--- If the position is out of range, the original sequence is returned.-update :: Int -> a -> Seq a -> Seq a-update i x = adjust (const x) i---- | /O(log(min(i,n-i)))/. Update the element at the specified position.--- If the position is out of range, the original sequence is returned.-adjust :: (a -> a) -> Int -> Seq a -> Seq a-adjust f i (Seq xs)- | 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) i xs)- | otherwise = Seq xs--{-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}-{-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}-adjustTree :: Sized a => (Int -> a -> a) ->- Int -> FingerTree a -> FingerTree a-adjustTree _ _ Empty = error "adjustTree of empty tree"-adjustTree f i (Single x) = Single (f i x)-adjustTree f i (Deep s pr m sf)- | i < spr = Deep s (adjustDigit f i pr) m sf- | i < spm = Deep s pr (adjustTree (adjustNode f) (i - spr) m) sf- | otherwise = Deep s pr m (adjustDigit f (i - spm) sf)- where spr = size pr- spm = spr + size m--{-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}-{-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}-adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a-adjustNode f i (Node2 s a b)- | i < sa = Node2 s (f i a) b- | otherwise = Node2 s a (f (i - sa) b)- where sa = size a-adjustNode f i (Node3 s a b c)- | i < sa = Node3 s (f i a) b c- | i < sab = Node3 s a (f (i - sa) b) c- | otherwise = Node3 s a b (f (i - sab) c)- where sa = size a- sab = sa + size b--{-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}-{-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}-adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a-adjustDigit f i (One a) = One (f i a)-adjustDigit f i (Two a b)- | i < sa = Two (f i a) b- | otherwise = Two a (f (i - sa) b)- where sa = size a-adjustDigit f i (Three a b c)- | i < sa = Three (f i a) b c- | i < sab = Three a (f (i - sa) b) c- | otherwise = Three a b (f (i - sab) c)- where sa = size a- sab = sa + size b-adjustDigit f i (Four a b c d)- | i < sa = Four (f i a) b c d- | i < sab = Four a (f (i - sa) b) c d- | i < sabc = Four a b (f (i - sab) c) d- | otherwise = Four a b c (f (i- sabc) d)- where sa = size a- sab = sa + size b- sabc = sab + size c---- | A generalization of 'fmap', 'mapWithIndex' takes a mapping function--- that also depends on the element's index, and applies it to every--- element in the sequence.-mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b-mapWithIndex f xs = snd (mapAccumL' (\ i x -> (i + 1, f i x)) 0 xs)---- Splitting---- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.--- If @i@ is negative, @'take' i s@ yields the empty sequence.--- If the sequence contains fewer than @i@ elements, the whole sequence--- is returned.-take :: Int -> Seq a -> Seq a-take i = fst . splitAt i---- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.--- If @i@ is negative, @'drop' i s@ yields the whole sequence.--- If the sequence contains fewer than @i@ elements, the empty sequence--- is returned.-drop :: Int -> Seq a -> Seq a-drop i = snd . splitAt i---- | /O(log(min(i,n-i)))/. Split a sequence at a given position.--- @'splitAt' i s = ('take' i s, 'drop' i s)@.-splitAt :: Int -> Seq a -> (Seq a, Seq a)-splitAt i (Seq xs) = (Seq l, Seq r)- where (l, r) = split i xs--split :: Int -> FingerTree (Elem a) ->- (FingerTree (Elem a), FingerTree (Elem a))-split i Empty = i `seq` (Empty, Empty)-split i xs- | size xs > i = (l, consTree x r)- | otherwise = (xs, Empty)- where Split l x r = splitTree i xs--data Split t a = Split t a t-#if TESTING- deriving Show-#endif--{-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-}-{-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-}-splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a-splitTree _ Empty = error "splitTree of empty tree"-splitTree i (Single x) = i `seq` Split Empty x Empty-splitTree i (Deep _ pr m sf)- | i < spr = case splitDigit i pr of- Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)- | i < spm = case splitTree im m of- Split ml xs mr -> case splitNode (im - size ml) xs of- Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)- | otherwise = case splitDigit (i - spm) sf of- Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)- where spr = size pr- spm = spr + size m- im = i - spr--{-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}-{-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}-splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a-splitNode i (Node2 _ a b)- | i < sa = Split Nothing a (Just (One b))- | otherwise = Split (Just (One a)) b Nothing- where sa = size a-splitNode i (Node3 _ a b c)- | i < sa = Split Nothing a (Just (Two b c))- | i < sab = Split (Just (One a)) b (Just (One c))- | otherwise = Split (Just (Two a b)) c Nothing- where sa = size a- sab = sa + size b--{-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}-{-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}-splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a-splitDigit i (One a) = i `seq` Split Nothing a Nothing-splitDigit i (Two a b)- | i < sa = Split Nothing a (Just (One b))- | otherwise = Split (Just (One a)) b Nothing- where sa = size a-splitDigit i (Three a b c)- | i < sa = Split Nothing a (Just (Two b c))- | i < sab = Split (Just (One a)) b (Just (One c))- | otherwise = Split (Just (Two a b)) c Nothing- where sa = size a- sab = sa + size b-splitDigit i (Four a b c d)- | i < sa = Split Nothing a (Just (Three b c d))- | i < sab = Split (Just (One a)) b (Just (Two c d))- | i < sabc = Split (Just (Two a b)) c (Just (One d))- | otherwise = Split (Just (Three a b c)) d Nothing- where sa = size a- sab = sa + size b- sabc = sab + size c---- | /O(n)/. Returns a sequence of all suffixes of this sequence,--- longest first. For example,------ > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]------ Evaluating the /i/th suffix takes /O(log(min(i, n-i)))/, but evaluating--- every suffix in the sequence takes /O(n)/ due to sharing.-tails :: Seq a -> Seq (Seq a)-tails (Seq xs) = Seq (tailsTree (Elem . Seq) xs) |> empty---- | /O(n)/. Returns a sequence of all prefixes of this sequence,--- shortest first. For example,------ > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]------ Evaluating the /i/th prefix takes /O(log(min(i, n-i)))/, but evaluating--- every prefix in the sequence takes /O(n)/ due to sharing.-inits :: Seq a -> Seq (Seq a)-inits (Seq xs) = empty <| Seq (initsTree (Elem . Seq) xs)---- This implementation of tails (and, analogously, inits) has the--- following algorithmic advantages:--- Evaluating each tail in the sequence takes linear total time,--- which is better than we could say for--- @fromList [drop n xs | n <- [0..length xs]]@.--- Evaluating any individual tail takes logarithmic time, which is--- better than we can say for either--- @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@.------ Moreover, if we actually look at every tail in the sequence, the--- following benchmarks demonstrate that this implementation is modestly--- faster than any of the above:------ Times (ms)--- min mean +/-sd median max--- Seq.tails: 21.986 24.961 10.169 22.417 86.485--- scanr: 85.392 87.942 2.488 87.425 100.217--- iterateN: 29.952 31.245 1.574 30.412 37.268------ The algorithm for tails (and, analogously, inits) is as follows:------ A Node in the FingerTree of tails is constructed by evaluating the--- corresponding tail of the FingerTree of Nodes, considering the first--- Node in this tail, and constructing a Node in which each tail of this--- Node is made to be the prefix of the remaining tree. This ends up--- working quite elegantly, as the remainder of the tail of the FingerTree--- of Nodes becomes the middle of a new tail, the suffix of the Node is--- the prefix, and the suffix of the original tree is retained.------ In particular, evaluating the /i/th tail involves making as--- many partial evaluations as the Node depth of the /i/th element.--- In addition, when we evaluate the /i/th tail, and we also evaluate--- the /j/th tail, and /m/ Nodes are on the path to both /i/ and /j/,--- each of those /m/ evaluations are shared between the computation of--- the /i/th and /j/th tails.------ wasserman.louis@gmail.com, 7/16/09--tailsDigit :: Digit a -> Digit (Digit a)-tailsDigit (One a) = One (One a)-tailsDigit (Two a b) = Two (Two a b) (One b)-tailsDigit (Three a b c) = Three (Three a b c) (Two b c) (One c)-tailsDigit (Four a b c d) = Four (Four a b c d) (Three b c d) (Two c d) (One d)--initsDigit :: Digit a -> Digit (Digit a)-initsDigit (One a) = One (One a)-initsDigit (Two a b) = Two (One a) (Two a b)-initsDigit (Three a b c) = Three (One a) (Two a b) (Three a b c)-initsDigit (Four a b c d) = Four (One a) (Two a b) (Three a b c) (Four a b c d)--tailsNode :: Node a -> Node (Digit a)-tailsNode (Node2 s a b) = Node2 s (Two a b) (One b)-tailsNode (Node3 s a b c) = Node3 s (Three a b c) (Two b c) (One c)--initsNode :: Node a -> Node (Digit a)-initsNode (Node2 s a b) = Node2 s (One a) (Two a b)-initsNode (Node3 s a b c) = Node3 s (One a) (Two a b) (Three a b c)--{-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}-{-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}--- | Given a function to apply to tails of a tree, applies that function--- to every tail of the specified tree.-tailsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b-tailsTree _ Empty = Empty-tailsTree f (Single x) = Single (f (Single x))-tailsTree f (Deep n pr m sf) =- Deep n (fmap (\ pr' -> f (deep pr' m sf)) (tailsDigit pr))- (tailsTree f' m)- (fmap (f . digitToTree) (tailsDigit sf))- where f' ms = let Just2 node m' = viewLTree ms in- fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)--{-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}-{-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}--- | Given a function to apply to inits of a tree, applies that function--- to every init of the specified tree.-initsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b-initsTree _ Empty = Empty-initsTree f (Single x) = Single (f (Single x))-initsTree f (Deep n pr m sf) =- Deep n (fmap (f . digitToTree) (initsDigit pr))- (initsTree f' m)- (fmap (f . deep pr m) (initsDigit sf))- where f' ms = let Just2 m' node = viewRTree ms in- fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)--{-# INLINE foldlWithIndex #-}--- | 'foldlWithIndex' is a version of 'foldl' that also provides access--- to the index of each element.-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldlWithIndex f z xs = foldl (\ g x i -> i `seq` f (g (i - 1)) i x) (const z) xs (length xs - 1)--{-# INLINE foldrWithIndex #-}--- | 'foldrWithIndex' is a version of 'foldr' that also provides access--- to the index of each element.-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldrWithIndex f z xs = foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0--{-# INLINE listToMaybe' #-}--- 'listToMaybe\'' is a good consumer version of 'listToMaybe'.-listToMaybe' :: [a] -> Maybe a-listToMaybe' = foldr (\ x _ -> Just x) Nothing---- | /O(i)/ where /i/ is the prefix length. 'takeWhileL', applied--- to a predicate @p@ and a sequence @xs@, returns the longest prefix--- (possibly empty) of @xs@ of elements that satisfy @p@.-takeWhileL :: (a -> Bool) -> Seq a -> Seq a-takeWhileL p = fst . spanl p---- | /O(i)/ where /i/ is the suffix length. 'takeWhileR', applied--- to a predicate @p@ and a sequence @xs@, returns the longest suffix--- (possibly empty) of @xs@ of elements that satisfy @p@.------ @'takeWhileR' p xs@ is equivalent to @'reverse' ('takeWhileL' p ('reverse' xs))@.-takeWhileR :: (a -> Bool) -> Seq a -> Seq a-takeWhileR p = fst . spanr p---- | /O(i)/ where /i/ is the prefix length. @'dropWhileL' p xs@ returns--- the suffix remaining after @'takeWhileL' p xs@.-dropWhileL :: (a -> Bool) -> Seq a -> Seq a-dropWhileL p = snd . spanl p---- | /O(i)/ where /i/ is the suffix length. @'dropWhileR' p xs@ returns--- the prefix remaining after @'takeWhileR' p xs@.------ @'dropWhileR' p xs@ is equivalent to @'reverse' ('dropWhileL' p ('reverse' xs))@.-dropWhileR :: (a -> Bool) -> Seq a -> Seq a-dropWhileR p = snd . spanr p---- | /O(i)/ where /i/ is the prefix length. 'spanl', applied to--- a predicate @p@ and a sequence @xs@, returns a pair whose first--- element is the longest prefix (possibly empty) of @xs@ of elements that--- satisfy @p@ and the second element is the remainder of the sequence.-spanl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-spanl p = breakl (not . p)---- | /O(i)/ where /i/ is the suffix length. 'spanr', applied to a--- predicate @p@ and a sequence @xs@, returns a pair whose /first/ element--- is the longest /suffix/ (possibly empty) of @xs@ of elements that--- satisfy @p@ and the second element is the remainder of the sequence.-spanr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-spanr p = breakr (not . p)--{-# INLINE breakl #-}--- | /O(i)/ where /i/ is the breakpoint index. 'breakl', applied to a--- predicate @p@ and a sequence @xs@, returns a pair whose first element--- is the longest prefix (possibly empty) of @xs@ of elements that--- /do not satisfy/ @p@ and the second element is the remainder of--- the sequence.------ @'breakl' p@ is equivalent to @'spanl' (not . p)@.-breakl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-breakl p xs = foldr (\ i _ -> splitAt i xs) (xs, empty) (findIndicesL p xs)--{-# 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 + 1) xs)) (xs, empty) (findIndicesR p xs)- where flipPair (x, y) = (y, x)---- | /O(n)/. The 'partition' function takes a predicate @p@ and a--- sequence @xs@ and returns sequences of those elements which do and--- do not satisfy the predicate.-partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-partition p = foldl part (empty, empty)- where part (xs, ys) x- | p x = (xs |> x, ys)- | otherwise = (xs, ys |> x)---- | /O(n)/. The 'filter' function takes a predicate @p@ and a sequence--- @xs@ and returns a sequence of those elements which satisfy the--- predicate.-filter :: (a -> Bool) -> Seq a -> Seq a-filter p = foldl (\ xs x -> if p x then xs |> x else xs) empty---- Indexing sequences---- | 'elemIndexL' finds the leftmost index of the specified element,--- if it is present, and otherwise 'Nothing'.-elemIndexL :: Eq a => a -> Seq a -> Maybe Int-elemIndexL x = findIndexL (x ==)---- | 'elemIndexR' finds the rightmost index of the specified element,--- if it is present, and otherwise 'Nothing'.-elemIndexR :: Eq a => a -> Seq a -> Maybe Int-elemIndexR x = findIndexR (x ==)---- | 'elemIndicesL' finds the indices of the specified element, from--- left to right (i.e. in ascending order).-elemIndicesL :: Eq a => a -> Seq a -> [Int]-elemIndicesL x = findIndicesL (x ==)---- | 'elemIndicesR' finds the indices of the specified element, from--- right to left (i.e. in descending order).-elemIndicesR :: Eq a => a -> Seq a -> [Int]-elemIndicesR x = findIndicesR (x ==)---- | @'findIndexL' p xs@ finds the index of the leftmost element that--- satisfies @p@, if any exist.-findIndexL :: (a -> Bool) -> Seq a -> Maybe Int-findIndexL p = listToMaybe' . findIndicesL p---- | @'findIndexR' p xs@ finds the index of the rightmost element that--- satisfies @p@, if any exist.-findIndexR :: (a -> Bool) -> Seq a -> Maybe Int-findIndexR p = listToMaybe' . findIndicesR p--{-# INLINE findIndicesL #-}--- | @'findIndicesL' p@ finds all indices of elements that satisfy @p@,--- in ascending order.-findIndicesL :: (a -> Bool) -> Seq a -> [Int]-#if __GLASGOW_HASKELL__-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-#endif--{-# INLINE findIndicesR #-}--- | @'findIndicesR' p@ finds all indices of elements that satisfy @p@,--- in descending order.-findIndicesR :: (a -> Bool) -> Seq a -> [Int]-#if __GLASGOW_HASKELL__-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-#endif----------------------------------------------------------------------------- Lists----------------------------------------------------------------------------- | /O(n)/. Create a sequence from a finite list of elements.--- There is a function 'toList' in the opposite direction for all--- instances of the 'Foldable' class, including 'Seq'.-fromList :: [a] -> Seq a-fromList = Data.List.foldl' (|>) empty----------------------------------------------------------------------------- Reverse----------------------------------------------------------------------------- | /O(n)/. The reverse of a sequence.-reverse :: Seq a -> Seq a-reverse (Seq xs) = Seq (reverseTree id xs)--reverseTree :: (a -> a) -> FingerTree a -> FingerTree a-reverseTree _ Empty = Empty-reverseTree f (Single x) = Single (f x)-reverseTree f (Deep s pr m sf) =- Deep s (reverseDigit f sf)- (reverseTree (reverseNode f) m)- (reverseDigit f pr)--{-# INLINE reverseDigit #-}-reverseDigit :: (a -> a) -> Digit a -> Digit a-reverseDigit f (One a) = One (f a)-reverseDigit f (Two a b) = Two (f b) (f a)-reverseDigit f (Three a b c) = Three (f c) (f b) (f a)-reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)--reverseNode :: (a -> a) -> Node a -> Node a-reverseNode f (Node2 s a b) = Node2 s (f b) (f a)-reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)----------------------------------------------------------------------------- Zipping----------------------------------------------------------------------------- | /O(min(n1,n2))/. 'zip' takes two sequences and returns a sequence--- of corresponding pairs. If one input is short, excess elements are--- discarded from the right end of the longer sequence.-zip :: Seq a -> Seq b -> Seq (a, b)-zip = zipWith (,)---- | /O(min(n1,n2))/. 'zipWith' generalizes 'zip' by zipping with the--- function given as the first argument, instead of a tupling function.--- For example, @zipWith (+)@ is applied to two sequences to take the--- sequence of corresponding sums.-zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith f xs ys- | length xs <= length ys = zipWith' f xs ys- | otherwise = zipWith' (flip f) ys xs---- like 'zipWith', but assumes length xs <= length ys-zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-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'.-zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zip3 = zipWith3 (,,)---- | /O(min(n1,n2,n3))/. 'zipWith3' takes a function which combines--- three elements, as well as three sequences and returns a sequence of--- their point-wise combinations, analogous to 'zipWith'.-zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-zipWith3 f s1 s2 s3 = zipWith ($) (zipWith f s1 s2) s3---- | /O(min(n1,n2,n3,n4))/. 'zip4' takes four sequences and returns a--- sequence of quadruples, analogous to 'zip'.-zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)-zip4 = zipWith4 (,,,)---- | /O(min(n1,n2,n3,n4))/. 'zipWith4' takes a function which combines--- four elements, as well as four sequences and returns a sequence of--- their point-wise combinations, analogous to 'zipWith'.-zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e-zipWith4 f s1 s2 s3 s4 = zipWith ($) (zipWith ($) (zipWith f s1 s2) s3) s4----------------------------------------------------------------------------- Sorting------ sort and sortBy are implemented by simple deforestations of--- \ xs -> fromList2 (length xs) . Data.List.sortBy cmp . toList--- which does not get deforested automatically, it would appear.------ Unstable sorting is performed by a heap sort implementation based on--- pairing heaps. Because the internal structure of sequences is quite--- varied, it is difficult to get blocks of elements of roughly the same--- length, which would improve merge sort performance. Pairing heaps,--- on the other hand, are relatively resistant to the effects of merging--- heaps of wildly different sizes, as guaranteed by its amortized--- constant-time merge operation. Moreover, extensive use of SpecConstr--- transformations can be done on pairing heaps, especially when we're--- only constructing them to immediately be unrolled.------ On purely random sequences of length 50000, with no RTS options,--- I get the following statistics, in which heapsort is about 42.5%--- faster: (all comparisons done with -O2)------ Times (ms) min mean +/-sd median max--- to/from list: 103.802 108.572 7.487 106.436 143.339--- unstable heapsort: 60.686 62.968 4.275 61.187 79.151------ Heapsort, it would seem, is less of a memory hog than Data.List.sortBy.--- The gap is narrowed when more memory is available, but heapsort still--- wins, 15% faster, with +RTS -H128m:------ Times (ms) min mean +/-sd median max--- to/from list: 42.692 45.074 2.596 44.600 56.601--- unstable heapsort: 37.100 38.344 3.043 37.715 55.526------ In addition, on strictly increasing sequences the gap is even wider--- than normal; heapsort is 68.5% faster with no RTS options:--- Times (ms) min mean +/-sd median max--- to/from list: 52.236 53.574 1.987 53.034 62.098--- unstable heapsort: 16.433 16.919 0.931 16.681 21.622------ This may be attributed to the elegant nature of the pairing heap.------ wasserman.louis@gmail.com, 7/20/09----------------------------------------------------------------------------- | /O(n log n)/. 'sort' sorts the specified 'Seq' by the natural--- ordering of its elements. The sort is stable.--- If stability is not required, 'unstableSort' can be considerably--- faster, and in particular uses less memory.-sort :: Ord a => Seq a -> Seq a-sort = sortBy compare---- | /O(n log n)/. 'sortBy' sorts the specified 'Seq' according to the--- specified comparator. The sort is stable.--- If stability is not required, 'unstableSortBy' can be considerably--- faster, and in particular uses less memory.-sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a-sortBy cmp xs = fromList2 (length xs) (Data.List.sortBy cmp (toList xs))---- | /O(n log n)/. 'unstableSort' sorts the specified 'Seq' by--- the natural ordering of its elements, but the sort is not stable.--- This algorithm is frequently faster and uses less memory than 'sort',--- and performs extremely well -- frequently twice as fast as 'sort' ----- when the sequence is already nearly sorted.-unstableSort :: Ord a => Seq a -> Seq a-unstableSort = unstableSortBy compare---- | /O(n log n)/. A generalization of 'unstableSort', 'unstableSortBy'--- takes an arbitrary comparator and sorts the specified sequence.--- The sort is not stable. This algorithm is frequently faster and--- uses less memory than 'sortBy', and performs extremely well ----- frequently twice as fast as 'sortBy' -- when the sequence is already--- nearly sorted.-unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a-unstableSortBy cmp (Seq xs) =- fromList2 (size xs) $ maybe [] (unrollPQ cmp) $- toPQ cmp (\ (Elem x) -> PQueue x Nil) xs---- | fromList2, given a list and its length, constructs a completely--- balanced Seq whose elements are that list using the applicativeTree--- generalization.-fromList2 :: Int -> [a] -> Seq a-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)-data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e--infixr 8 :&--#if TESTING--instance Functor PQueue where- fmap f (PQueue x ts) = PQueue (f x) (fmap f ts)--instance Functor PQL where- fmap f (q :& qs) = fmap f q :& fmap f qs- fmap _ Nil = Nil--instance Show e => Show (PQueue e) where- show = unlines . draw . fmap show---- borrowed wholesale from Data.Tree, as Data.Tree actually depends--- on Data.Sequence-draw :: PQueue String -> [String]-draw (PQueue x ts0) = x : drawSubTrees ts0- where drawSubTrees Nil = []- drawSubTrees (t :& Nil) =- "|" : shift "`- " " " (draw t)- drawSubTrees (t :& ts) =- "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts-- shift first other = Data.List.zipWith (++) (first : repeat other)-#endif---- | 'unrollPQ', given a comparator function, unrolls a 'PQueue' into--- a sorted list.-unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e]-unrollPQ cmp = unrollPQ'- where- {-# INLINE unrollPQ' #-}- unrollPQ' (PQueue x ts) = x:mergePQs0 ts- (<>) = mergePQ cmp- mergePQs0 Nil = []- mergePQs0 (t :& Nil) = unrollPQ' t- mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <> t2) ts- mergePQs t ts = t `seq` case ts of- Nil -> unrollPQ' t- t1 :& Nil -> unrollPQ' (t <> t1)- t1 :& t2 :& ts' -> mergePQs (t <> (t1 <> t2)) ts'---- | 'toPQ', given an ordering function and a mechanism for queueifying--- elements, converts a 'FingerTree' to a 'PQueue'.-toPQ :: (e -> e -> Ordering) -> (a -> PQueue e) -> FingerTree a -> Maybe (PQueue e)-toPQ _ _ Empty = Nothing-toPQ _ f (Single x) = Just (f x)-toPQ cmp f (Deep _ pr m sf) = Just (maybe (pr' <> sf') ((pr' <> sf') <>) (toPQ cmp fNode m))- where- fDigit digit = case fmap f digit of- One a -> a- Two a b -> a <> b- Three a b c -> a <> b <> c- Four a b c d -> (a <> b) <> (c <> d)- (<>) = mergePQ cmp- fNode = fDigit . nodeToDigit- pr' = fDigit pr- sf' = fDigit sf---- | 'mergePQ' merges two 'PQueue's.-mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a-mergePQ cmp q1@(PQueue x1 ts1) q2@(PQueue x2 ts2)- | cmp x1 x2 == GT = PQueue x2 (q1 :& ts2)- | otherwise = PQueue x1 (q2 :& ts1)--#if TESTING----------------------------------------------------------------------------- QuickCheck---------------------------------------------------------------------------instance Arbitrary a => Arbitrary (Seq a) where- arbitrary = liftM Seq arbitrary- shrink (Seq x) = map Seq (shrink x)--instance Arbitrary a => Arbitrary (Elem a) where- arbitrary = liftM Elem arbitrary--instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where- arbitrary = sized arb- where arb :: (Arbitrary a, Sized a) => Int -> Gen (FingerTree a)- arb 0 = return Empty- arb 1 = liftM Single arbitrary- arb n = liftM3 deep arbitrary (arb (n `div` 2)) arbitrary-- shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b]- shrink (Deep _ pr m sf) =- [deep pr' m sf | pr' <- shrink pr] ++- [deep pr m' sf | m' <- shrink m] ++- [deep pr m sf' | sf' <- shrink sf]- shrink (Single x) = map Single (shrink x)- shrink Empty = []--instance (Arbitrary a, Sized a) => Arbitrary (Node a) where- arbitrary = oneof [- liftM2 node2 arbitrary arbitrary,- liftM3 node3 arbitrary arbitrary arbitrary]-- shrink (Node2 _ a b) =- [node2 a' b | a' <- shrink a] ++- [node2 a b' | b' <- shrink b]- shrink (Node3 _ a b c) =- [node2 a b, node2 a c, node2 b c] ++- [node3 a' b c | a' <- shrink a] ++- [node3 a b' c | b' <- shrink b] ++- [node3 a b c' | c' <- shrink c]--instance Arbitrary a => Arbitrary (Digit a) where- arbitrary = oneof [- liftM One arbitrary,- liftM2 Two arbitrary arbitrary,- liftM3 Three arbitrary arbitrary arbitrary,- liftM4 Four arbitrary arbitrary arbitrary arbitrary]-- shrink (One a) = map One (shrink a)- shrink (Two a b) = [One a, One b]- shrink (Three a b c) = [Two a b, Two a c, Two b c]- shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]----------------------------------------------------------------------------- Valid trees---------------------------------------------------------------------------class Valid a where- valid :: a -> Bool--instance Valid (Elem a) where- valid _ = True--instance Valid (Seq a) where- valid (Seq xs) = valid xs--instance (Sized a, Valid a) => Valid (FingerTree a) where- valid Empty = True- valid (Single x) = valid x- valid (Deep s pr m sf) =- s == size pr + size m + size sf && valid pr && valid m && valid sf--instance (Sized a, Valid a) => Valid (Node a) where- valid node = size node == sum (fmap size node) && all valid node--instance Valid a => Valid (Digit a) where- valid = all valid+{-# LANGUAGE CPP, DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Sequence+-- Copyright : (c) Ross Paterson 2005+-- (c) Louis Wasserman 2009+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : portable+--+-- General purpose finite sequences.+-- Apart from being finite and having strict operations, sequences+-- also differ from lists in supporting a wider variety of operations+-- efficiently.+--+-- An amortized running time is given for each operation, with /n/ referring+-- to the length of the sequence and /i/ being the integral index used by+-- some operations. These bounds hold even in a persistent (shared) setting.+--+-- The implementation uses 2-3 finger trees annotated with sizes,+-- as described in section 4.2 of+--+-- * Ralf Hinze and Ross Paterson,+-- \"Finger trees: a simple general-purpose data structure\",+-- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.+-- <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>+--+-- /Note/: Many of these operations have the same names as similar+-- operations on lists in the "Prelude". The ambiguity may be resolved+-- using either qualification or the @hiding@ clause.+--+-----------------------------------------------------------------------------++module Data.Sequence (+ Seq,+ -- * Construction+ empty, -- :: Seq a+ singleton, -- :: a -> Seq a+ (<|), -- :: a -> Seq a -> Seq a+ (|>), -- :: Seq a -> a -> Seq a+ (><), -- :: Seq a -> Seq a -> Seq a+ fromList, -- :: [a] -> Seq a+ -- ** Repetition+ replicate, -- :: Int -> a -> Seq a+ replicateA, -- :: Applicative f => Int -> f a -> f (Seq a)+ replicateM, -- :: Monad m => Int -> m a -> m (Seq a)+ -- ** Iterative construction+ iterateN, -- :: Int -> (a -> a) -> a -> Seq a+ unfoldr, -- :: (b -> Maybe (a, b)) -> b -> Seq a+ unfoldl, -- :: (b -> Maybe (b, a)) -> b -> Seq a+ -- * Deconstruction+ -- | Additional functions for deconstructing sequences are available+ -- via the 'Foldable' instance of 'Seq'.++ -- ** Queries+ null, -- :: Seq a -> Bool+ length, -- :: Seq a -> Int+ -- ** Views+ ViewL(..),+ viewl, -- :: Seq a -> ViewL a+ ViewR(..),+ viewr, -- :: Seq a -> ViewR a+ -- * Scans+ scanl, -- :: (a -> b -> a) -> a -> Seq b -> Seq a+ scanl1, -- :: (a -> a -> a) -> Seq a -> Seq a+ scanr, -- :: (a -> b -> b) -> b -> Seq a -> Seq b+ scanr1, -- :: (a -> a -> a) -> Seq a -> Seq a+ -- * Sublists+ tails, -- :: Seq a -> Seq (Seq a)+ inits, -- :: Seq a -> Seq (Seq a)+ -- ** Sequential searches+ takeWhileL, -- :: (a -> Bool) -> Seq a -> Seq a+ takeWhileR, -- :: (a -> Bool) -> Seq a -> Seq a+ dropWhileL, -- :: (a -> Bool) -> Seq a -> Seq a+ dropWhileR, -- :: (a -> Bool) -> Seq a -> Seq a+ spanl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+ spanr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+ breakl, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+ breakr, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+ partition, -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+ filter, -- :: (a -> Bool) -> Seq a -> Seq a+ -- * Sorting+ sort, -- :: Ord a => Seq a -> Seq a+ sortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a+ unstableSort, -- :: Ord a => Seq a -> Seq a+ unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a+ -- * Indexing+ index, -- :: Seq a -> Int -> a+ adjust, -- :: (a -> a) -> Int -> Seq a -> Seq a+ update, -- :: Int -> a -> Seq a -> Seq a+ take, -- :: Int -> Seq a -> Seq a+ drop, -- :: Int -> Seq a -> Seq a+ splitAt, -- :: Int -> Seq a -> (Seq a, Seq a)+ -- ** Indexing with predicates+ -- | These functions perform sequential searches from the left+ -- or right ends of the sequence, returning indices of matching+ -- elements.+ elemIndexL, -- :: Eq a => a -> Seq a -> Maybe Int+ elemIndicesL, -- :: Eq a => a -> Seq a -> [Int]+ elemIndexR, -- :: Eq a => a -> Seq a -> Maybe Int+ elemIndicesR, -- :: Eq a => a -> Seq a -> [Int]+ findIndexL, -- :: (a -> Bool) -> Seq a -> Maybe Int+ findIndicesL, -- :: (a -> Bool) -> Seq a -> [Int]+ findIndexR, -- :: (a -> Bool) -> Seq a -> Maybe Int+ findIndicesR, -- :: (a -> Bool) -> Seq a -> [Int]+ -- * Folds+ -- | General folds are available via the 'Foldable' instance of 'Seq'.+ foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b+ foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b+ -- * Transformations+ mapWithIndex, -- :: (Int -> a -> b) -> Seq a -> Seq b+ reverse, -- :: Seq a -> Seq a+ -- ** Zips+ zip, -- :: Seq a -> Seq b -> Seq (a, b)+ zipWith, -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+ zip3, -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)+ zipWith3, -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+ zip4, -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)+ zipWith4, -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e+#if TESTING+ valid,+#endif+ ) where++import Prelude hiding (+ Functor(..),+ null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,+ scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,+ takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)+import qualified Data.List (foldl', sortBy)+import Control.Applicative (Applicative(..), (<$>), WrappedMonad(..), liftA, liftA2, liftA3)+import Control.Monad (MonadPlus(..), ap)+import Data.Monoid (Monoid(..))+import Data.Functor (Functor(..))+import Data.Foldable+import Data.Traversable+import Data.Typeable++#ifdef __GLASGOW_HASKELL__+import GHC.Exts (build)+import Text.Read (Lexeme(Ident), lexP, parens, prec,+ readPrec, readListPrec, readListPrecDefault)+import Data.Data+#endif++#if TESTING+import qualified Data.List (zipWith)+import Test.QuickCheck hiding ((><))+#endif++infixr 5 `consTree`+infixl 5 `snocTree`++infixr 5 ><+infixr 5 <|, :<+infixl 5 |>, :>++class Sized a where+ size :: a -> Int++-- | General-purpose finite sequences.+newtype Seq a = Seq (FingerTree (Elem a))++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+ foldl f z (Seq xs) = foldl (foldl f) z xs++ foldr1 f (Seq xs) = getElem (foldr1 f' xs)+ where f' (Elem x) (Elem y) = Elem (f x y)++ foldl1 f (Seq xs) = getElem (foldl1 f' xs)+ where f' (Elem x) (Elem y) = Elem (f x y)++instance Traversable Seq where+ traverse f (Seq xs) = Seq <$> traverse (traverse f) xs++instance Monad Seq where+ return = singleton+ xs >>= f = foldl' add empty xs+ where add ys x = ys >< f x++instance MonadPlus Seq where+ mzero = empty+ mplus = (><)++instance Eq a => Eq (Seq a) where+ xs == ys = length xs == length ys && toList xs == toList ys++instance Ord a => Ord (Seq a) where+ compare xs ys = compare (toList xs) (toList ys)++#if TESTING+instance Show a => Show (Seq a) where+ showsPrec p (Seq x) = showsPrec p x+#else+instance Show a => Show (Seq a) where+ showsPrec p xs = showParen (p > 10) $+ showString "fromList " . shows (toList xs)+#endif++instance Read a => Read (Seq a) where+#ifdef __GLASGOW_HASKELL__+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif++instance Monoid (Seq a) where+ mempty = empty+ mappend = (><)++#include "Typeable.h"+INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")++#if __GLASGOW_HASKELL__+instance Data a => Data (Seq a) where+ gfoldl f z s = case viewl s of+ EmptyL -> z empty+ x :< xs -> z (<|) `f` x `f` xs++ gunfold k z c = case constrIndex c of+ 1 -> z empty+ 2 -> k (k (z (<|)))+ _ -> error "gunfold"++ toConstr xs+ | null xs = emptyConstr+ | otherwise = consConstr++ dataTypeOf _ = seqDataType++ dataCast1 f = gcast1 f++emptyConstr, consConstr :: Constr+emptyConstr = mkConstr seqDataType "empty" [] Prefix+consConstr = mkConstr seqDataType "<|" [] Infix++seqDataType :: DataType+seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]+#endif++-- Finger trees++data FingerTree a+ = Empty+ | Single a+ | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)+#if TESTING+ deriving Show+#endif++instance Sized a => Sized (FingerTree a) where+ {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}+ {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}+ size Empty = 0+ size (Single x) = size x+ size (Deep v _ _ _) = v++instance Foldable FingerTree where+ foldr _ z Empty = z+ foldr f z (Single x) = x `f` z+ foldr f z (Deep _ pr m sf) =+ foldr f (foldr (flip (foldr f)) (foldr f z sf) m) pr++ foldl _ z Empty = z+ foldl f z (Single x) = z `f` x+ foldl f z (Deep _ pr m sf) =+ foldl f (foldl (foldl f) (foldl f z pr) m) sf++ foldr1 _ Empty = error "foldr1: empty sequence"+ foldr1 _ (Single x) = x+ foldr1 f (Deep _ pr m sf) =+ foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr++ foldl1 _ Empty = error "foldl1: empty sequence"+ foldl1 _ (Single x) = x+ foldl1 f (Deep _ pr m sf) =+ foldl f (foldl (foldl f) (foldl1 f pr) m) sf++instance Functor FingerTree where+ fmap _ Empty = Empty+ fmap f (Single x) = Single (f x)+ fmap f (Deep v pr m sf) =+ Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)++instance Traversable FingerTree where+ traverse _ Empty = pure Empty+ traverse f (Single x) = Single <$> f x+ traverse f (Deep v pr m sf) =+ Deep v <$> traverse f pr <*> traverse (traverse f) m <*>+ traverse f sf++{-# INLINE deep #-}+{-# SPECIALIZE INLINE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE INLINE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}+deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a+deep pr m sf = Deep (size pr + size m + size sf) pr m sf++{-# INLINE pullL #-}+pullL :: Sized a => Int -> FingerTree (Node a) -> Digit a -> FingerTree a+pullL s m sf = case viewLTree m of+ Nothing2 -> digitToTree' s sf+ Just2 pr m' -> Deep s (nodeToDigit pr) m' sf++{-# INLINE pullR #-}+pullR :: Sized a => Int -> Digit a -> FingerTree (Node a) -> FingerTree a+pullR s pr m = case viewRTree m of+ Nothing2 -> digitToTree' s pr+ Just2 m' sf -> Deep s pr m' (nodeToDigit sf)++{-# SPECIALIZE deepL :: Maybe (Digit (Elem a)) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE deepL :: Maybe (Digit (Node a)) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}+deepL :: Sized a => Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a+deepL Nothing m sf = pullL (size m + size sf) m sf+deepL (Just pr) m sf = deep pr m sf++{-# SPECIALIZE deepR :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Maybe (Digit (Elem a)) -> FingerTree (Elem a) #-}+{-# SPECIALIZE deepR :: Digit (Node a) -> FingerTree (Node (Node a)) -> Maybe (Digit (Node a)) -> FingerTree (Node a) #-}+deepR :: Sized a => Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a+deepR pr m Nothing = pullR (size m + size pr) pr m+deepR pr m (Just sf) = deep pr m sf++-- Digits++data Digit a+ = One a+ | Two a a+ | Three a a a+ | Four a a a a+#if TESTING+ deriving Show+#endif++instance Foldable Digit where+ foldr f z (One a) = a `f` z+ foldr f z (Two a b) = a `f` (b `f` z)+ foldr f z (Three a b c) = a `f` (b `f` (c `f` z))+ foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))++ foldl f z (One a) = z `f` a+ foldl f z (Two a b) = (z `f` a) `f` b+ foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c+ foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d++ foldr1 _ (One a) = a+ foldr1 f (Two a b) = a `f` b+ foldr1 f (Three a b c) = a `f` (b `f` c)+ foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))++ foldl1 _ (One a) = a+ foldl1 f (Two a b) = a `f` b+ foldl1 f (Three a b c) = (a `f` b) `f` c+ foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d++instance Functor Digit where+ {-# INLINE fmap #-}+ fmap f (One a) = One (f a)+ fmap f (Two a b) = Two (f a) (f b)+ fmap f (Three a b c) = Three (f a) (f b) (f c)+ fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)++instance Traversable Digit where+ {-# INLINE traverse #-}+ traverse f (One a) = One <$> f a+ traverse f (Two a b) = Two <$> f a <*> f b+ traverse f (Three a b c) = Three <$> f a <*> f b <*> f c+ traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d++instance Sized a => Sized (Digit a) where+ {-# INLINE size #-}+ size = foldl1 (+) . fmap size++{-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}+digitToTree :: Sized a => Digit a -> FingerTree a+digitToTree (One a) = Single a+digitToTree (Two a b) = deep (One a) Empty (One b)+digitToTree (Three a b c) = deep (Two a b) Empty (One c)+digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)++-- | Given the size of a digit and the digit itself, efficiently converts+-- it to a FingerTree.+digitToTree' :: Int -> Digit a -> FingerTree a+digitToTree' n (Four a b c d) = Deep n (Two a b) Empty (Two c d)+digitToTree' n (Three a b c) = Deep n (Two a b) Empty (One c)+digitToTree' n (Two a b) = Deep n (One a) Empty (One b)+digitToTree' n (One a) = n `seq` Single a++-- Nodes++data Node a+ = Node2 {-# UNPACK #-} !Int a a+ | Node3 {-# UNPACK #-} !Int a a a+#if TESTING+ deriving Show+#endif++instance Foldable Node where+ foldr f z (Node2 _ a b) = a `f` (b `f` z)+ foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))++ foldl f z (Node2 _ a b) = (z `f` a) `f` b+ foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c++instance Functor Node where+ {-# INLINE fmap #-}+ fmap f (Node2 v a b) = Node2 v (f a) (f b)+ fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)++instance Traversable Node where+ {-# INLINE traverse #-}+ traverse f (Node2 v a b) = Node2 v <$> f a <*> f b+ traverse f (Node3 v a b c) = Node3 v <$> f a <*> f b <*> f c++instance Sized (Node a) where+ size (Node2 v _ _) = v+ size (Node3 v _ _ _) = v++{-# INLINE node2 #-}+{-# SPECIALIZE node2 :: Elem a -> Elem a -> Node (Elem a) #-}+{-# SPECIALIZE node2 :: Node a -> Node a -> Node (Node a) #-}+node2 :: Sized a => a -> a -> Node a+node2 a b = Node2 (size a + size b) a b++{-# INLINE node3 #-}+{-# SPECIALIZE node3 :: Elem a -> Elem a -> Elem a -> Node (Elem a) #-}+{-# SPECIALIZE node3 :: Node a -> Node a -> Node a -> Node (Node a) #-}+node3 :: Sized a => a -> a -> a -> Node a+node3 a b c = Node3 (size a + size b + size c) a b c++nodeToDigit :: Node a -> Digit a+nodeToDigit (Node2 _ a b) = Two a b+nodeToDigit (Node3 _ a b c) = Three a b c++-- Elements++newtype Elem a = Elem { getElem :: a }++instance Sized (Elem a) where+ size _ = 1++instance Functor Elem where+ fmap f (Elem x) = Elem (f x)++instance Foldable Elem where+ foldr f z (Elem x) = f x z+ foldl f z (Elem x) = f z x++instance Traversable Elem where+ traverse f (Elem x) = Elem <$> f x++#ifdef TESTING+instance (Show a) => Show (Elem a) where+ showsPrec p (Elem x) = showsPrec p x+#endif++-------------------------------------------------------+-- Applicative construction+-------------------------------------------------------++newtype Id a = Id {runId :: a}++instance Functor Id where+ fmap f (Id x) = Id (f x)++instance Monad Id where+ return = Id+ m >>= k = k (runId m)++instance Applicative Id where+ pure = return+ (<*>) = ap++-- | This is essentially a clone of Control.Monad.State.Strict.+newtype State s a = State {runState :: s -> (s, a)}++instance Functor (State s) where+ fmap = liftA++instance Monad (State s) where+ {-# INLINE return #-}+ {-# INLINE (>>=) #-}+ return x = State $ \ s -> (s, x)+ m >>= k = State $ \ s -> case runState m s of+ (s', x) -> runState (k x) s'++instance Applicative (State s) where+ pure = return+ (<*>) = ap++execState :: State s a -> s -> a+execState m x = snd (runState m x)++-- | A helper method: a strict version of mapAccumL.+mapAccumL' :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)+mapAccumL' f s t = runState (traverse (State . flip f) t) s++-- | 'applicativeTree' takes an Applicative-wrapped construction of a+-- piece of a FingerTree, assumed to always have the same size (which+-- is put in the second argument), and replicates it as many times as+-- specified. This is a generalization of 'replicateA', which itself+-- is a generalization of many Data.Sequence methods.+{-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}+{-# 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 n mSize m = mSize `seq` case n of+ 0 -> pure Empty+ 1 -> liftA Single m+ 2 -> deepA one emptyTree one+ 3 -> deepA two emptyTree one+ 4 -> deepA two emptyTree two+ 5 -> deepA three emptyTree two+ 6 -> deepA three emptyTree three+ 7 -> deepA four emptyTree three+ 8 -> deepA four emptyTree four+ _ -> let (q, r) = n `quotRem` 3 in q `seq` case r of+ 0 -> deepA three (applicativeTree (q - 2) mSize' n3) three+ 1 -> deepA four (applicativeTree (q - 2) mSize' n3) three+ _ -> deepA four (applicativeTree (q - 2) mSize' n3) four+ where+ one = liftA One m+ two = liftA2 Two m m+ three = liftA3 Three m m m+ four = liftA3 Four m m m <*> m+ deepA = liftA3 (Deep (n * mSize))+ mSize' = 3 * mSize+ n3 = liftA3 (Node3 mSize') m m m+ emptyTree = pure Empty++------------------------------------------------------------------------+-- Construction+------------------------------------------------------------------------++-- | /O(1)/. The empty sequence.+empty :: Seq a+empty = Seq Empty++-- | /O(1)/. A singleton sequence.+singleton :: a -> Seq a+singleton x = Seq (Single (Elem x))++-- | /O(log n)/. @replicate n x@ is a sequence consisting of @n@ copies of @x@.+replicate :: Int -> a -> Seq a+replicate n x+ | n >= 0 = runId (replicateA n (Id x))+ | otherwise = error "replicate takes a nonnegative integer argument"++-- | 'replicateA' is an 'Applicative' version of 'replicate', and makes+-- /O(log n)/ calls to '<*>' and 'pure'.+--+-- > replicateA n x = sequenceA (replicate n x)+replicateA :: Applicative f => Int -> f a -> f (Seq a)+replicateA n x+ | n >= 0 = Seq <$> applicativeTree n 1 (Elem <$> x)+ | otherwise = error "replicateA takes a nonnegative integer argument"++-- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'.+--+-- > replicateM n x = sequence (replicate n x)+replicateM :: Monad m => Int -> m a -> m (Seq a)+replicateM n x+ | n >= 0 = unwrapMonad (replicateA n (WrapMonad x))+ | otherwise = error "replicateM takes a nonnegative integer argument"++-- | /O(1)/. Add an element to the left end of a sequence.+-- Mnemonic: a triangle with the single element at the pointy end.+(<|) :: a -> Seq a -> Seq a+x <| Seq xs = Seq (Elem x `consTree` xs)++{-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}+consTree :: Sized a => a -> FingerTree a -> FingerTree a+consTree a Empty = Single a+consTree a (Single b) = deep (One a) Empty (One b)+consTree a (Deep s (Four b c d e) m sf) = m `seq`+ Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf+consTree a (Deep s (Three b c d) m sf) =+ Deep (size a + s) (Four a b c d) m sf+consTree a (Deep s (Two b c) m sf) =+ Deep (size a + s) (Three a b c) m sf+consTree a (Deep s (One b) m sf) =+ Deep (size a + s) (Two a b) m sf++-- | /O(1)/. Add an element to the right end of a sequence.+-- Mnemonic: a triangle with the single element at the pointy end.+(|>) :: Seq a -> a -> Seq a+Seq xs |> x = Seq (xs `snocTree` Elem x)++{-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}+{-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}+snocTree :: Sized a => FingerTree a -> a -> FingerTree a+snocTree Empty a = Single a+snocTree (Single a) b = deep (One a) Empty (One b)+snocTree (Deep s pr m (Four a b c d)) e = m `seq`+ Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)+snocTree (Deep s pr m (Three a b c)) d =+ Deep (s + size d) pr m (Four a b c d)+snocTree (Deep s pr m (Two a b)) c =+ Deep (s + size c) pr m (Three a b c)+snocTree (Deep s pr m (One a)) b =+ Deep (s + size b) pr m (Two a b)++-- | /O(log(min(n1,n2)))/. Concatenate two sequences.+(><) :: Seq a -> Seq a -> Seq a+Seq xs >< Seq ys = Seq (appendTree0 xs ys)++-- The appendTree/addDigits gunk below is machine generated++appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)+appendTree0 Empty xs =+ xs+appendTree0 xs Empty =+ xs+appendTree0 (Single x) xs =+ x `consTree` xs+appendTree0 xs (Single x) =+ xs `snocTree` x+appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =+ Deep (s1 + s2) pr1 (addDigits0 m1 sf1 pr2 m2) sf2++addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))+addDigits0 m1 (One a) (One b) m2 =+ appendTree1 m1 (node2 a b) m2+addDigits0 m1 (One a) (Two b c) m2 =+ appendTree1 m1 (node3 a b c) m2+addDigits0 m1 (One a) (Three b c d) m2 =+ appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (One a) (Four b c d e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Two a b) (One c) m2 =+ appendTree1 m1 (node3 a b c) m2+addDigits0 m1 (Two a b) (Two c d) m2 =+ appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (Two a b) (Three c d e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Two a b) (Four c d e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Three a b c) (One d) m2 =+ appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (Three a b c) (Two d e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Three a b c) (Three d e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Three a b c) (Four d e f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits0 m1 (Four a b c d) (One e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Four a b c d) (Two e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Four a b c d) (Three e f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits0 m1 (Four a b c d) (Four e f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2++appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree1 Empty a xs =+ a `consTree` xs+appendTree1 xs a Empty =+ xs `snocTree` a+appendTree1 (Single x) a xs =+ x `consTree` a `consTree` xs+appendTree1 xs a (Single x) =+ xs `snocTree` a `snocTree` x+appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =+ Deep (s1 + size a + s2) pr1 (addDigits1 m1 sf1 a pr2 m2) sf2++addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits1 m1 (One a) b (One c) m2 =+ appendTree1 m1 (node3 a b c) m2+addDigits1 m1 (One a) b (Two c d) m2 =+ appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits1 m1 (One a) b (Three c d e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (One a) b (Four c d e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Two a b) c (One d) m2 =+ appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits1 m1 (Two a b) c (Two d e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (Two a b) c (Three d e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Two a b) c (Four d e f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Three a b c) d (One e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (Three a b c) d (Two e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Three a b c) d (Three e f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Three a b c) d (Four e f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits1 m1 (Four a b c d) e (One f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Four a b c d) e (Two f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Four a b c d) e (Three f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2++appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree2 Empty a b xs =+ a `consTree` b `consTree` xs+appendTree2 xs a b Empty =+ xs `snocTree` a `snocTree` b+appendTree2 (Single x) a b xs =+ x `consTree` a `consTree` b `consTree` xs+appendTree2 xs a b (Single x) =+ xs `snocTree` a `snocTree` b `snocTree` x+appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =+ Deep (s1 + size a + size b + s2) pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2++addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits2 m1 (One a) b c (One d) m2 =+ appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits2 m1 (One a) b c (Two d e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits2 m1 (One a) b c (Three d e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (One a) b c (Four d e f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Two a b) c d (One e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits2 m1 (Two a b) c d (Two e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (Two a b) c d (Three e f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Two a b) c d (Four e f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Three a b c) d e (One f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (Three a b c) d e (Two f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Three a b c) d e (Three f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits2 m1 (Four a b c d) e f (One g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Four a b c d) e f (Two g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2++appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree3 Empty a b c xs =+ a `consTree` b `consTree` c `consTree` xs+appendTree3 xs a b c Empty =+ xs `snocTree` a `snocTree` b `snocTree` c+appendTree3 (Single x) a b c xs =+ x `consTree` a `consTree` b `consTree` c `consTree` xs+appendTree3 xs a b c (Single x) =+ xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x+appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =+ Deep (s1 + size a + size b + size c + s2) pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2++addDigits3 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits3 m1 (One a) b c d (One e) m2 =+ appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits3 m1 (One a) b c d (Two e f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits3 m1 (One a) b c d (Three e f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (One a) b c d (Four e f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Two a b) c d e (One f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits3 m1 (Two a b) c d e (Two f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (Two a b) c d e (Three f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Three a b c) d e f (One g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (Three a b c) d e f (Two g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits3 m1 (Four a b c d) e f g (One h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2++appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree4 Empty a b c d xs =+ a `consTree` b `consTree` c `consTree` d `consTree` xs+appendTree4 xs a b c d Empty =+ xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d+appendTree4 (Single x) a b c d xs =+ x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs+appendTree4 xs a b c d (Single x) =+ xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x+appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =+ Deep (s1 + size a + size b + size c + size d + s2) pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2++addDigits4 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits4 m1 (One a) b c d e (One f) m2 =+ appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits4 m1 (One a) b c d e (Two f g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits4 m1 (One a) b c d e (Three f g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (One a) b c d e (Four f g h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Two a b) c d e f (One g) m2 =+ appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits4 m1 (Two a b) c d e f (Two g h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Three a b c) d e f g (One h) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2+addDigits4 m1 (Four a b c d) e f g h (One i) m2 =+ appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2+addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =+ appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2++-- | Builds a sequence from a seed value. Takes time linear in the+-- number of generated elements. /WARNING:/ If the number of generated+-- elements is infinite, this method will not terminate.+unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a+unfoldr f = unfoldr' empty+ -- uses tail recursion rather than, for instance, the List implementation.+ where unfoldr' as b = maybe as (\ (a, b') -> unfoldr' (as |> a) b') (f b)++-- | @'unfoldl' f x@ is equivalent to @'reverse' ('unfoldr' ('fmap' swap . f) x)@.+unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a+unfoldl f = unfoldl' empty+ where unfoldl' as b = maybe as (\ (b', a) -> unfoldl' (a <| as) b') (f b)++-- | /O(n)/. Constructs a sequence by repeated application of a function+-- to a seed value.+--+-- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))+iterateN :: Int -> (a -> a) -> a -> Seq a+iterateN n f x+ | n >= 0 = replicateA n (State (\ y -> (f y, y))) `execState` x+ | otherwise = error "iterateN takes a nonnegative integer argument"++------------------------------------------------------------------------+-- Deconstruction+------------------------------------------------------------------------++-- | /O(1)/. Is this the empty sequence?+null :: Seq a -> Bool+null (Seq Empty) = True+null _ = False++-- | /O(1)/. The number of elements in the sequence.+length :: Seq a -> Int+length (Seq xs) = size xs++-- Views++data Maybe2 a b = Nothing2 | Just2 a b++-- | View of the left end of a sequence.+data ViewL a+ = EmptyL -- ^ empty sequence+ | a :< Seq a -- ^ leftmost element and the rest of the sequence+#if __GLASGOW_HASKELL__+ deriving (Eq, Ord, Show, Read, Data)+#else+ deriving (Eq, Ord, Show, Read)+#endif++INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")++instance Functor ViewL where+ {-# INLINE fmap #-}+ fmap _ EmptyL = EmptyL+ fmap f (x :< xs) = f x :< fmap f xs++instance Foldable ViewL where+ foldr _ z EmptyL = z+ foldr f z (x :< xs) = f x (foldr f z xs)++ foldl _ z EmptyL = z+ foldl f z (x :< xs) = foldl f (f z x) xs++ foldl1 _ EmptyL = error "foldl1: empty view"+ foldl1 f (x :< xs) = foldl f x xs++instance Traversable ViewL where+ traverse _ EmptyL = pure EmptyL+ traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs++-- | /O(1)/. Analyse the left end of a sequence.+viewl :: Seq a -> ViewL a+viewl (Seq xs) = case viewLTree xs of+ Nothing2 -> EmptyL+ Just2 (Elem x) xs' -> x :< Seq xs'++{-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> Maybe2 (Elem a) (FingerTree (Elem a)) #-}+{-# SPECIALIZE viewLTree :: FingerTree (Node a) -> Maybe2 (Node a) (FingerTree (Node a)) #-}+viewLTree :: Sized a => FingerTree a -> Maybe2 a (FingerTree a)+viewLTree Empty = Nothing2+viewLTree (Single a) = Just2 a Empty+viewLTree (Deep s (One a) m sf) = Just2 a (pullL (s - size a) m sf)+viewLTree (Deep s (Two a b) m sf) =+ Just2 a (Deep (s - size a) (One b) m sf)+viewLTree (Deep s (Three a b c) m sf) =+ Just2 a (Deep (s - size a) (Two b c) m sf)+viewLTree (Deep s (Four a b c d) m sf) =+ Just2 a (Deep (s - size a) (Three b c d) m sf)++-- | View of the right end of a sequence.+data ViewR a+ = EmptyR -- ^ empty sequence+ | Seq a :> a -- ^ the sequence minus the rightmost element,+ -- and the rightmost element+#if __GLASGOW_HASKELL__+ deriving (Eq, Ord, Show, Read, Data)+#else+ deriving (Eq, Ord, Show, Read)+#endif++INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")++instance Functor ViewR where+ {-# INLINE fmap #-}+ fmap _ EmptyR = EmptyR+ fmap f (xs :> x) = fmap f xs :> f x++instance Foldable ViewR where+ foldr _ z EmptyR = z+ foldr f z (xs :> x) = foldr f (f x z) xs++ foldl _ z EmptyR = z+ foldl f z (xs :> x) = foldl f z xs `f` x++ foldr1 _ EmptyR = error "foldr1: empty view"+ foldr1 f (xs :> x) = foldr f x xs++instance Traversable ViewR where+ traverse _ EmptyR = pure EmptyR+ traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x++-- | /O(1)/. Analyse the right end of a sequence.+viewr :: Seq a -> ViewR a+viewr (Seq xs) = case viewRTree xs of+ Nothing2 -> EmptyR+ Just2 xs' (Elem x) -> Seq xs' :> x++{-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> Maybe2 (FingerTree (Elem a)) (Elem a) #-}+{-# SPECIALIZE viewRTree :: FingerTree (Node a) -> Maybe2 (FingerTree (Node a)) (Node a) #-}+viewRTree :: Sized a => FingerTree a -> Maybe2 (FingerTree a) a+viewRTree Empty = Nothing2+viewRTree (Single z) = Just2 Empty z+viewRTree (Deep s pr m (One z)) = Just2 (pullR (s - size z) pr m) z+viewRTree (Deep s pr m (Two y z)) =+ Just2 (Deep (s - size z) pr m (One y)) z+viewRTree (Deep s pr m (Three x y z)) =+ Just2 (Deep (s - size z) pr m (Two x y)) z+viewRTree (Deep s pr m (Four w x y z)) =+ Just2 (Deep (s - size z) pr m (Three w x y)) z++------------------------------------------------------------------------+-- Scans+--+-- These are not particularly complex applications of the Traversable+-- functor, though making the correspondence with Data.List exact+-- requires the use of (<|) and (|>).+--+-- Note that save for the single (<|) or (|>), we maintain the original+-- structure of the Seq, not having to do any restructuring of our own.+--+-- wasserman.louis@gmail.com, 5/23/09+------------------------------------------------------------------------++-- | 'scanl' is similar to 'foldl', but returns a sequence of reduced+-- values from the left:+--+-- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]+scanl :: (a -> b -> a) -> a -> Seq b -> Seq a+scanl f z0 xs = z0 <| snd (mapAccumL (\ x z -> let x' = f x z in (x', x')) z0 xs)++-- | 'scanl1' is a variant of 'scanl' that has no starting value argument:+--+-- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]+scanl1 :: (a -> a -> a) -> Seq a -> Seq a+scanl1 f xs = case viewl xs of+ EmptyL -> error "scanl1 takes a nonempty sequence as an argument"+ x :< xs' -> scanl f x xs'++-- | 'scanr' is the right-to-left dual of 'scanl'.+scanr :: (a -> b -> b) -> b -> Seq a -> Seq b+scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0++-- | 'scanr1' is a variant of 'scanr' that has no starting value argument.+scanr1 :: (a -> a -> a) -> Seq a -> Seq a+scanr1 f xs = case viewr xs of+ EmptyR -> error "scanr1 takes a nonempty sequence as an argument"+ xs' :> x -> scanr f x xs'++-- Indexing++-- | /O(log(min(i,n-i)))/. The element at the specified position,+-- counting from 0. The argument should thus be a non-negative+-- integer less than the size of the sequence.+-- If the position is out of range, 'index' fails with an error.+index :: Seq a -> Int -> a+index (Seq xs) i+ | 0 <= i && i < size xs = case lookupTree i xs of+ Place _ (Elem x) -> x+ | otherwise = error "index out of bounds"++data Place a = Place {-# UNPACK #-} !Int a+#if TESTING+ deriving Show+#endif++{-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}+{-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}+lookupTree :: Sized a => Int -> FingerTree a -> Place a+lookupTree _ Empty = error "lookupTree of empty tree"+lookupTree i (Single x) = Place i x+lookupTree i (Deep _ pr m sf)+ | i < spr = lookupDigit i pr+ | i < spm = case lookupTree (i - spr) m of+ Place i' xs -> lookupNode i' xs+ | otherwise = lookupDigit (i - spm) sf+ where+ spr = size pr+ spm = spr + size m++{-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}+{-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}+lookupNode :: Sized a => Int -> Node a -> Place a+lookupNode i (Node2 _ a b)+ | i < sa = Place i a+ | otherwise = Place (i - sa) b+ where+ sa = size a+lookupNode i (Node3 _ a b c)+ | i < sa = Place i a+ | i < sab = Place (i - sa) b+ | otherwise = Place (i - sab) c+ where+ sa = size a+ sab = sa + size b++{-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}+{-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}+lookupDigit :: Sized a => Int -> Digit a -> Place a+lookupDigit i (One a) = Place i a+lookupDigit i (Two a b)+ | i < sa = Place i a+ | otherwise = Place (i - sa) b+ where+ sa = size a+lookupDigit i (Three a b c)+ | i < sa = Place i a+ | i < sab = Place (i - sa) b+ | otherwise = Place (i - sab) c+ where+ sa = size a+ sab = sa + size b+lookupDigit i (Four a b c d)+ | i < sa = Place i a+ | i < sab = Place (i - sa) b+ | i < sabc = Place (i - sab) c+ | otherwise = Place (i - sabc) d+ where+ sa = size a+ sab = sa + size b+ sabc = sab + size c++-- | /O(log(min(i,n-i)))/. Replace the element at the specified position.+-- If the position is out of range, the original sequence is returned.+update :: Int -> a -> Seq a -> Seq a+update i x = adjust (const x) i++-- | /O(log(min(i,n-i)))/. Update the element at the specified position.+-- If the position is out of range, the original sequence is returned.+adjust :: (a -> a) -> Int -> Seq a -> Seq a+adjust f i (Seq xs)+ | 0 <= i && i < size xs = Seq (adjustTree (const (fmap f)) i xs)+ | otherwise = Seq xs++{-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}+adjustTree :: Sized a => (Int -> a -> a) ->+ Int -> FingerTree a -> FingerTree a+adjustTree _ _ Empty = error "adjustTree of empty tree"+adjustTree f i (Single x) = Single (f i x)+adjustTree f i (Deep s pr m sf)+ | i < spr = Deep s (adjustDigit f i pr) m sf+ | i < spm = Deep s pr (adjustTree (adjustNode f) (i - spr) m) sf+ | otherwise = Deep s pr m (adjustDigit f (i - spm) sf)+ where+ spr = size pr+ spm = spr + size m++{-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}+{-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}+adjustNode :: Sized a => (Int -> a -> a) -> Int -> Node a -> Node a+adjustNode f i (Node2 s a b)+ | i < sa = Node2 s (f i a) b+ | otherwise = Node2 s a (f (i - sa) b)+ where+ sa = size a+adjustNode f i (Node3 s a b c)+ | i < sa = Node3 s (f i a) b c+ | i < sab = Node3 s a (f (i - sa) b) c+ | otherwise = Node3 s a b (f (i - sab) c)+ where+ sa = size a+ sab = sa + size b++{-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}+{-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}+adjustDigit :: Sized a => (Int -> a -> a) -> Int -> Digit a -> Digit a+adjustDigit f i (One a) = One (f i a)+adjustDigit f i (Two a b)+ | i < sa = Two (f i a) b+ | otherwise = Two a (f (i - sa) b)+ where+ sa = size a+adjustDigit f i (Three a b c)+ | i < sa = Three (f i a) b c+ | i < sab = Three a (f (i - sa) b) c+ | otherwise = Three a b (f (i - sab) c)+ where+ sa = size a+ sab = sa + size b+adjustDigit f i (Four a b c d)+ | i < sa = Four (f i a) b c d+ | i < sab = Four a (f (i - sa) b) c d+ | i < sabc = Four a b (f (i - sab) c) d+ | otherwise = Four a b c (f (i- sabc) d)+ where+ sa = size a+ sab = sa + size b+ sabc = sab + size c++-- | A generalization of 'fmap', 'mapWithIndex' takes a mapping function+-- that also depends on the element's index, and applies it to every+-- element in the sequence.+mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b+mapWithIndex f xs = snd (mapAccumL' (\ i x -> (i + 1, f i x)) 0 xs)++-- Splitting++-- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.+-- If @i@ is negative, @'take' i s@ yields the empty sequence.+-- If the sequence contains fewer than @i@ elements, the whole sequence+-- is returned.+take :: Int -> Seq a -> Seq a+take i = fst . splitAt i++-- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.+-- If @i@ is negative, @'drop' i s@ yields the whole sequence.+-- If the sequence contains fewer than @i@ elements, the empty sequence+-- is returned.+drop :: Int -> Seq a -> Seq a+drop i = snd . splitAt i++-- | /O(log(min(i,n-i)))/. Split a sequence at a given position.+-- @'splitAt' i s = ('take' i s, 'drop' i s)@.+splitAt :: Int -> Seq a -> (Seq a, Seq a)+splitAt i (Seq xs) = (Seq l, Seq r)+ where (l, r) = split i xs++split :: Int -> FingerTree (Elem a) ->+ (FingerTree (Elem a), FingerTree (Elem a))+split i Empty = i `seq` (Empty, Empty)+split i xs+ | size xs > i = (l, consTree x r)+ | otherwise = (xs, Empty)+ where Split l x r = splitTree i xs++data Split t a = Split t a t+#if TESTING+ deriving Show+#endif++{-# SPECIALIZE splitTree :: Int -> FingerTree (Elem a) -> Split (FingerTree (Elem a)) (Elem a) #-}+{-# SPECIALIZE splitTree :: Int -> FingerTree (Node a) -> Split (FingerTree (Node a)) (Node a) #-}+splitTree :: Sized a => Int -> FingerTree a -> Split (FingerTree a) a+splitTree _ Empty = error "splitTree of empty tree"+splitTree i (Single x) = i `seq` Split Empty x Empty+splitTree i (Deep _ pr m sf)+ | i < spr = case splitDigit i pr of+ Split l x r -> Split (maybe Empty digitToTree l) x (deepL r m sf)+ | i < spm = case splitTree im m of+ Split ml xs mr -> case splitNode (im - size ml) xs of+ Split l x r -> Split (deepR pr ml l) x (deepL r mr sf)+ | otherwise = case splitDigit (i - spm) sf of+ Split l x r -> Split (deepR pr m l) x (maybe Empty digitToTree r)+ where+ spr = size pr+ spm = spr + size m+ im = i - spr++{-# SPECIALIZE splitNode :: Int -> Node (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}+{-# SPECIALIZE splitNode :: Int -> Node (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}+splitNode :: Sized a => Int -> Node a -> Split (Maybe (Digit a)) a+splitNode i (Node2 _ a b)+ | i < sa = Split Nothing a (Just (One b))+ | otherwise = Split (Just (One a)) b Nothing+ where+ sa = size a+splitNode i (Node3 _ a b c)+ | i < sa = Split Nothing a (Just (Two b c))+ | i < sab = Split (Just (One a)) b (Just (One c))+ | otherwise = Split (Just (Two a b)) c Nothing+ where+ sa = size a+ sab = sa + size b++{-# SPECIALIZE splitDigit :: Int -> Digit (Elem a) -> Split (Maybe (Digit (Elem a))) (Elem a) #-}+{-# SPECIALIZE splitDigit :: Int -> Digit (Node a) -> Split (Maybe (Digit (Node a))) (Node a) #-}+splitDigit :: Sized a => Int -> Digit a -> Split (Maybe (Digit a)) a+splitDigit i (One a) = i `seq` Split Nothing a Nothing+splitDigit i (Two a b)+ | i < sa = Split Nothing a (Just (One b))+ | otherwise = Split (Just (One a)) b Nothing+ where+ sa = size a+splitDigit i (Three a b c)+ | i < sa = Split Nothing a (Just (Two b c))+ | i < sab = Split (Just (One a)) b (Just (One c))+ | otherwise = Split (Just (Two a b)) c Nothing+ where+ sa = size a+ sab = sa + size b+splitDigit i (Four a b c d)+ | i < sa = Split Nothing a (Just (Three b c d))+ | i < sab = Split (Just (One a)) b (Just (Two c d))+ | i < sabc = Split (Just (Two a b)) c (Just (One d))+ | otherwise = Split (Just (Three a b c)) d Nothing+ where+ sa = size a+ sab = sa + size b+ sabc = sab + size c++-- | /O(n)/. Returns a sequence of all suffixes of this sequence,+-- longest first. For example,+--+-- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]+--+-- Evaluating the /i/th suffix takes /O(log(min(i, n-i)))/, but evaluating+-- every suffix in the sequence takes /O(n)/ due to sharing.+tails :: Seq a -> Seq (Seq a)+tails (Seq xs) = Seq (tailsTree (Elem . Seq) xs) |> empty++-- | /O(n)/. Returns a sequence of all prefixes of this sequence,+-- shortest first. For example,+--+-- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]+--+-- Evaluating the /i/th prefix takes /O(log(min(i, n-i)))/, but evaluating+-- every prefix in the sequence takes /O(n)/ due to sharing.+inits :: Seq a -> Seq (Seq a)+inits (Seq xs) = empty <| Seq (initsTree (Elem . Seq) xs)++-- This implementation of tails (and, analogously, inits) has the+-- following algorithmic advantages:+-- Evaluating each tail in the sequence takes linear total time,+-- which is better than we could say for+-- @fromList [drop n xs | n <- [0..length xs]]@.+-- Evaluating any individual tail takes logarithmic time, which is+-- better than we can say for either+-- @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@.+--+-- Moreover, if we actually look at every tail in the sequence, the+-- following benchmarks demonstrate that this implementation is modestly+-- faster than any of the above:+--+-- Times (ms)+-- min mean +/-sd median max+-- Seq.tails: 21.986 24.961 10.169 22.417 86.485+-- scanr: 85.392 87.942 2.488 87.425 100.217+-- iterateN: 29.952 31.245 1.574 30.412 37.268+--+-- The algorithm for tails (and, analogously, inits) is as follows:+--+-- A Node in the FingerTree of tails is constructed by evaluating the+-- corresponding tail of the FingerTree of Nodes, considering the first+-- Node in this tail, and constructing a Node in which each tail of this+-- Node is made to be the prefix of the remaining tree. This ends up+-- working quite elegantly, as the remainder of the tail of the FingerTree+-- of Nodes becomes the middle of a new tail, the suffix of the Node is+-- the prefix, and the suffix of the original tree is retained.+--+-- In particular, evaluating the /i/th tail involves making as+-- many partial evaluations as the Node depth of the /i/th element.+-- In addition, when we evaluate the /i/th tail, and we also evaluate+-- the /j/th tail, and /m/ Nodes are on the path to both /i/ and /j/,+-- each of those /m/ evaluations are shared between the computation of+-- the /i/th and /j/th tails.+--+-- wasserman.louis@gmail.com, 7/16/09++tailsDigit :: Digit a -> Digit (Digit a)+tailsDigit (One a) = One (One a)+tailsDigit (Two a b) = Two (Two a b) (One b)+tailsDigit (Three a b c) = Three (Three a b c) (Two b c) (One c)+tailsDigit (Four a b c d) = Four (Four a b c d) (Three b c d) (Two c d) (One d)++initsDigit :: Digit a -> Digit (Digit a)+initsDigit (One a) = One (One a)+initsDigit (Two a b) = Two (One a) (Two a b)+initsDigit (Three a b c) = Three (One a) (Two a b) (Three a b c)+initsDigit (Four a b c d) = Four (One a) (Two a b) (Three a b c) (Four a b c d)++tailsNode :: Node a -> Node (Digit a)+tailsNode (Node2 s a b) = Node2 s (Two a b) (One b)+tailsNode (Node3 s a b c) = Node3 s (Three a b c) (Two b c) (One c)++initsNode :: Node a -> Node (Digit a)+initsNode (Node2 s a b) = Node2 s (One a) (Two a b)+initsNode (Node3 s a b c) = Node3 s (One a) (Two a b) (Three a b c)++{-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}+{-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}+-- | Given a function to apply to tails of a tree, applies that function+-- to every tail of the specified tree.+tailsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b+tailsTree _ Empty = Empty+tailsTree f (Single x) = Single (f (Single x))+tailsTree f (Deep n pr m sf) =+ Deep n (fmap (\ pr' -> f (deep pr' m sf)) (tailsDigit pr))+ (tailsTree f' m)+ (fmap (f . digitToTree) (tailsDigit sf))+ where+ f' ms = let Just2 node m' = viewLTree ms in+ fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)++{-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}+{-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}+-- | Given a function to apply to inits of a tree, applies that function+-- to every init of the specified tree.+initsTree :: (Sized a, Sized b) => (FingerTree a -> b) -> FingerTree a -> FingerTree b+initsTree _ Empty = Empty+initsTree f (Single x) = Single (f (Single x))+initsTree f (Deep n pr m sf) =+ Deep n (fmap (f . digitToTree) (initsDigit pr))+ (initsTree f' m)+ (fmap (f . deep pr m) (initsDigit sf))+ where+ f' ms = let Just2 m' node = viewRTree ms in+ fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)++{-# INLINE foldlWithIndex #-}+-- | 'foldlWithIndex' is a version of 'foldl' that also provides access+-- to the index of each element.+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b+foldlWithIndex f z xs = foldl (\ g x i -> i `seq` f (g (i - 1)) i x) (const z) xs (length xs - 1)++{-# INLINE foldrWithIndex #-}+-- | 'foldrWithIndex' is a version of 'foldr' that also provides access+-- to the index of each element.+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldrWithIndex f z xs = foldr (\ x g i -> i `seq` f i x (g (i+1))) (const z) xs 0++{-# INLINE listToMaybe' #-}+-- 'listToMaybe\'' is a good consumer version of 'listToMaybe'.+listToMaybe' :: [a] -> Maybe a+listToMaybe' = foldr (\ x _ -> Just x) Nothing++-- | /O(i)/ where /i/ is the prefix length. 'takeWhileL', applied+-- to a predicate @p@ and a sequence @xs@, returns the longest prefix+-- (possibly empty) of @xs@ of elements that satisfy @p@.+takeWhileL :: (a -> Bool) -> Seq a -> Seq a+takeWhileL p = fst . spanl p++-- | /O(i)/ where /i/ is the suffix length. 'takeWhileR', applied+-- to a predicate @p@ and a sequence @xs@, returns the longest suffix+-- (possibly empty) of @xs@ of elements that satisfy @p@.+--+-- @'takeWhileR' p xs@ is equivalent to @'reverse' ('takeWhileL' p ('reverse' xs))@.+takeWhileR :: (a -> Bool) -> Seq a -> Seq a+takeWhileR p = fst . spanr p++-- | /O(i)/ where /i/ is the prefix length. @'dropWhileL' p xs@ returns+-- the suffix remaining after @'takeWhileL' p xs@.+dropWhileL :: (a -> Bool) -> Seq a -> Seq a+dropWhileL p = snd . spanl p++-- | /O(i)/ where /i/ is the suffix length. @'dropWhileR' p xs@ returns+-- the prefix remaining after @'takeWhileR' p xs@.+--+-- @'dropWhileR' p xs@ is equivalent to @'reverse' ('dropWhileL' p ('reverse' xs))@.+dropWhileR :: (a -> Bool) -> Seq a -> Seq a+dropWhileR p = snd . spanr p++-- | /O(i)/ where /i/ is the prefix length. 'spanl', applied to+-- a predicate @p@ and a sequence @xs@, returns a pair whose first+-- element is the longest prefix (possibly empty) of @xs@ of elements that+-- satisfy @p@ and the second element is the remainder of the sequence.+spanl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+spanl p = breakl (not . p)++-- | /O(i)/ where /i/ is the suffix length. 'spanr', applied to a+-- predicate @p@ and a sequence @xs@, returns a pair whose /first/ element+-- is the longest /suffix/ (possibly empty) of @xs@ of elements that+-- satisfy @p@ and the second element is the remainder of the sequence.+spanr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+spanr p = breakr (not . p)++{-# INLINE breakl #-}+-- | /O(i)/ where /i/ is the breakpoint index. 'breakl', applied to a+-- predicate @p@ and a sequence @xs@, returns a pair whose first element+-- is the longest prefix (possibly empty) of @xs@ of elements that+-- /do not satisfy/ @p@ and the second element is the remainder of+-- the sequence.+--+-- @'breakl' p@ is equivalent to @'spanl' (not . p)@.+breakl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+breakl p xs = foldr (\ i _ -> splitAt i xs) (xs, empty) (findIndicesL p xs)++{-# 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 + 1) xs)) (xs, empty) (findIndicesR p xs)+ where flipPair (x, y) = (y, x)++-- | /O(n)/. The 'partition' function takes a predicate @p@ and a+-- sequence @xs@ and returns sequences of those elements which do and+-- do not satisfy the predicate.+partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+partition p = foldl part (empty, empty)+ where+ part (xs, ys) x+ | p x = (xs |> x, ys)+ | otherwise = (xs, ys |> x)++-- | /O(n)/. The 'filter' function takes a predicate @p@ and a sequence+-- @xs@ and returns a sequence of those elements which satisfy the+-- predicate.+filter :: (a -> Bool) -> Seq a -> Seq a+filter p = foldl (\ xs x -> if p x then xs |> x else xs) empty++-- Indexing sequences++-- | 'elemIndexL' finds the leftmost index of the specified element,+-- if it is present, and otherwise 'Nothing'.+elemIndexL :: Eq a => a -> Seq a -> Maybe Int+elemIndexL x = findIndexL (x ==)++-- | 'elemIndexR' finds the rightmost index of the specified element,+-- if it is present, and otherwise 'Nothing'.+elemIndexR :: Eq a => a -> Seq a -> Maybe Int+elemIndexR x = findIndexR (x ==)++-- | 'elemIndicesL' finds the indices of the specified element, from+-- left to right (i.e. in ascending order).+elemIndicesL :: Eq a => a -> Seq a -> [Int]+elemIndicesL x = findIndicesL (x ==)++-- | 'elemIndicesR' finds the indices of the specified element, from+-- right to left (i.e. in descending order).+elemIndicesR :: Eq a => a -> Seq a -> [Int]+elemIndicesR x = findIndicesR (x ==)++-- | @'findIndexL' p xs@ finds the index of the leftmost element that+-- satisfies @p@, if any exist.+findIndexL :: (a -> Bool) -> Seq a -> Maybe Int+findIndexL p = listToMaybe' . findIndicesL p++-- | @'findIndexR' p xs@ finds the index of the rightmost element that+-- satisfies @p@, if any exist.+findIndexR :: (a -> Bool) -> Seq a -> Maybe Int+findIndexR p = listToMaybe' . findIndicesR p++{-# INLINE findIndicesL #-}+-- | @'findIndicesL' p@ finds all indices of elements that satisfy @p@,+-- in ascending order.+findIndicesL :: (a -> Bool) -> Seq a -> [Int]+#if __GLASGOW_HASKELL__+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+#endif++{-# INLINE findIndicesR #-}+-- | @'findIndicesR' p@ finds all indices of elements that satisfy @p@,+-- in descending order.+findIndicesR :: (a -> Bool) -> Seq a -> [Int]+#if __GLASGOW_HASKELL__+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+#endif++------------------------------------------------------------------------+-- Lists+------------------------------------------------------------------------++-- | /O(n)/. Create a sequence from a finite list of elements.+-- There is a function 'toList' in the opposite direction for all+-- instances of the 'Foldable' class, including 'Seq'.+fromList :: [a] -> Seq a+fromList = Data.List.foldl' (|>) empty++------------------------------------------------------------------------+-- Reverse+------------------------------------------------------------------------++-- | /O(n)/. The reverse of a sequence.+reverse :: Seq a -> Seq a+reverse (Seq xs) = Seq (reverseTree id xs)++reverseTree :: (a -> a) -> FingerTree a -> FingerTree a+reverseTree _ Empty = Empty+reverseTree f (Single x) = Single (f x)+reverseTree f (Deep s pr m sf) =+ Deep s (reverseDigit f sf)+ (reverseTree (reverseNode f) m)+ (reverseDigit f pr)++{-# INLINE reverseDigit #-}+reverseDigit :: (a -> a) -> Digit a -> Digit a+reverseDigit f (One a) = One (f a)+reverseDigit f (Two a b) = Two (f b) (f a)+reverseDigit f (Three a b c) = Three (f c) (f b) (f a)+reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)++reverseNode :: (a -> a) -> Node a -> Node a+reverseNode f (Node2 s a b) = Node2 s (f b) (f a)+reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)++------------------------------------------------------------------------+-- Zipping+------------------------------------------------------------------------++-- | /O(min(n1,n2))/. 'zip' takes two sequences and returns a sequence+-- of corresponding pairs. If one input is short, excess elements are+-- discarded from the right end of the longer sequence.+zip :: Seq a -> Seq b -> Seq (a, b)+zip = zipWith (,)++-- | /O(min(n1,n2))/. 'zipWith' generalizes 'zip' by zipping with the+-- function given as the first argument, instead of a tupling function.+-- For example, @zipWith (+)@ is applied to two sequences to take the+-- sequence of corresponding sums.+zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+zipWith f xs ys+ | length xs <= length ys = zipWith' f xs ys+ | otherwise = zipWith' (flip f) ys xs++-- like 'zipWith', but assumes length xs <= length ys+zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+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'.+zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)+zip3 = zipWith3 (,,)++-- | /O(min(n1,n2,n3))/. 'zipWith3' takes a function which combines+-- three elements, as well as three sequences and returns a sequence of+-- their point-wise combinations, analogous to 'zipWith'.+zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+zipWith3 f s1 s2 s3 = zipWith ($) (zipWith f s1 s2) s3++-- | /O(min(n1,n2,n3,n4))/. 'zip4' takes four sequences and returns a+-- sequence of quadruples, analogous to 'zip'.+zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)+zip4 = zipWith4 (,,,)++-- | /O(min(n1,n2,n3,n4))/. 'zipWith4' takes a function which combines+-- four elements, as well as four sequences and returns a sequence of+-- their point-wise combinations, analogous to 'zipWith'.+zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e+zipWith4 f s1 s2 s3 s4 = zipWith ($) (zipWith ($) (zipWith f s1 s2) s3) s4++------------------------------------------------------------------------+-- Sorting+--+-- sort and sortBy are implemented by simple deforestations of+-- \ xs -> fromList2 (length xs) . Data.List.sortBy cmp . toList+-- which does not get deforested automatically, it would appear.+--+-- Unstable sorting is performed by a heap sort implementation based on+-- pairing heaps. Because the internal structure of sequences is quite+-- varied, it is difficult to get blocks of elements of roughly the same+-- length, which would improve merge sort performance. Pairing heaps,+-- on the other hand, are relatively resistant to the effects of merging+-- heaps of wildly different sizes, as guaranteed by its amortized+-- constant-time merge operation. Moreover, extensive use of SpecConstr+-- transformations can be done on pairing heaps, especially when we're+-- only constructing them to immediately be unrolled.+--+-- On purely random sequences of length 50000, with no RTS options,+-- I get the following statistics, in which heapsort is about 42.5%+-- faster: (all comparisons done with -O2)+--+-- Times (ms) min mean +/-sd median max+-- to/from list: 103.802 108.572 7.487 106.436 143.339+-- unstable heapsort: 60.686 62.968 4.275 61.187 79.151+--+-- Heapsort, it would seem, is less of a memory hog than Data.List.sortBy.+-- The gap is narrowed when more memory is available, but heapsort still+-- wins, 15% faster, with +RTS -H128m:+--+-- Times (ms) min mean +/-sd median max+-- to/from list: 42.692 45.074 2.596 44.600 56.601+-- unstable heapsort: 37.100 38.344 3.043 37.715 55.526+--+-- In addition, on strictly increasing sequences the gap is even wider+-- than normal; heapsort is 68.5% faster with no RTS options:+-- Times (ms) min mean +/-sd median max+-- to/from list: 52.236 53.574 1.987 53.034 62.098+-- unstable heapsort: 16.433 16.919 0.931 16.681 21.622+--+-- This may be attributed to the elegant nature of the pairing heap.+--+-- wasserman.louis@gmail.com, 7/20/09+------------------------------------------------------------------------++-- | /O(n log n)/. 'sort' sorts the specified 'Seq' by the natural+-- ordering of its elements. The sort is stable.+-- If stability is not required, 'unstableSort' can be considerably+-- faster, and in particular uses less memory.+sort :: Ord a => Seq a -> Seq a+sort = sortBy compare++-- | /O(n log n)/. 'sortBy' sorts the specified 'Seq' according to the+-- specified comparator. The sort is stable.+-- If stability is not required, 'unstableSortBy' can be considerably+-- faster, and in particular uses less memory.+sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a+sortBy cmp xs = fromList2 (length xs) (Data.List.sortBy cmp (toList xs))++-- | /O(n log n)/. 'unstableSort' sorts the specified 'Seq' by+-- the natural ordering of its elements, but the sort is not stable.+-- This algorithm is frequently faster and uses less memory than 'sort',+-- and performs extremely well -- frequently twice as fast as 'sort' --+-- when the sequence is already nearly sorted.+unstableSort :: Ord a => Seq a -> Seq a+unstableSort = unstableSortBy compare++-- | /O(n log n)/. A generalization of 'unstableSort', 'unstableSortBy'+-- takes an arbitrary comparator and sorts the specified sequence.+-- The sort is not stable. This algorithm is frequently faster and+-- uses less memory than 'sortBy', and performs extremely well --+-- frequently twice as fast as 'sortBy' -- when the sequence is already+-- nearly sorted.+unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a+unstableSortBy cmp (Seq xs) =+ fromList2 (size xs) $ maybe [] (unrollPQ cmp) $+ toPQ cmp (\ (Elem x) -> PQueue x Nil) xs++-- | fromList2, given a list and its length, constructs a completely+-- balanced Seq whose elements are that list using the applicativeTree+-- generalization.+fromList2 :: Int -> [a] -> Seq a+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)+data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e++infixr 8 :&++#if TESTING++instance Functor PQueue where+ fmap f (PQueue x ts) = PQueue (f x) (fmap f ts)++instance Functor PQL where+ fmap f (q :& qs) = fmap f q :& fmap f qs+ fmap _ Nil = Nil++instance Show e => Show (PQueue e) where+ show = unlines . draw . fmap show++-- borrowed wholesale from Data.Tree, as Data.Tree actually depends+-- on Data.Sequence+draw :: PQueue String -> [String]+draw (PQueue x ts0) = x : drawSubTrees ts0+ where+ drawSubTrees Nil = []+ drawSubTrees (t :& Nil) =+ "|" : shift "`- " " " (draw t)+ drawSubTrees (t :& ts) =+ "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts++ shift first other = Data.List.zipWith (++) (first : repeat other)+#endif++-- | 'unrollPQ', given a comparator function, unrolls a 'PQueue' into+-- a sorted list.+unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e]+unrollPQ cmp = unrollPQ'+ where+ {-# INLINE unrollPQ' #-}+ unrollPQ' (PQueue x ts) = x:mergePQs0 ts+ (<>) = mergePQ cmp+ mergePQs0 Nil = []+ mergePQs0 (t :& Nil) = unrollPQ' t+ mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <> t2) ts+ mergePQs t ts = t `seq` case ts of+ Nil -> unrollPQ' t+ t1 :& Nil -> unrollPQ' (t <> t1)+ t1 :& t2 :& ts' -> mergePQs (t <> (t1 <> t2)) ts'++-- | 'toPQ', given an ordering function and a mechanism for queueifying+-- elements, converts a 'FingerTree' to a 'PQueue'.+toPQ :: (e -> e -> Ordering) -> (a -> PQueue e) -> FingerTree a -> Maybe (PQueue e)+toPQ _ _ Empty = Nothing+toPQ _ f (Single x) = Just (f x)+toPQ cmp f (Deep _ pr m sf) = Just (maybe (pr' <> sf') ((pr' <> sf') <>) (toPQ cmp fNode m))+ where+ fDigit digit = case fmap f digit of+ One a -> a+ Two a b -> a <> b+ Three a b c -> a <> b <> c+ Four a b c d -> (a <> b) <> (c <> d)+ (<>) = mergePQ cmp+ fNode = fDigit . nodeToDigit+ pr' = fDigit pr+ sf' = fDigit sf++-- | 'mergePQ' merges two 'PQueue's.+mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a+mergePQ cmp q1@(PQueue x1 ts1) q2@(PQueue x2 ts2)+ | cmp x1 x2 == GT = PQueue x2 (q1 :& ts2)+ | otherwise = PQueue x1 (q2 :& ts1)++#if TESTING++------------------------------------------------------------------------+-- QuickCheck+------------------------------------------------------------------------++instance Arbitrary a => Arbitrary (Seq a) where+ arbitrary = Seq <$> arbitrary+ shrink (Seq x) = map Seq (shrink x)++instance Arbitrary a => Arbitrary (Elem a) where+ arbitrary = Elem <$> arbitrary++instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where+ arbitrary = sized arb+ where+ arb :: (Arbitrary a, Sized a) => Int -> Gen (FingerTree a)+ arb 0 = return Empty+ arb 1 = Single <$> arbitrary+ arb n = deep <$> arbitrary <*> arb (n `div` 2) <*> arbitrary++ shrink (Deep _ (One a) Empty (One b)) = [Single a, Single b]+ shrink (Deep _ pr m sf) =+ [deep pr' m sf | pr' <- shrink pr] +++ [deep pr m' sf | m' <- shrink m] +++ [deep pr m sf' | sf' <- shrink sf]+ shrink (Single x) = map Single (shrink x)+ shrink Empty = []++instance (Arbitrary a, Sized a) => Arbitrary (Node a) where+ arbitrary = oneof [+ node2 <$> arbitrary <*> arbitrary,+ node3 <$> arbitrary <*> arbitrary <*> arbitrary]++ shrink (Node2 _ a b) =+ [node2 a' b | a' <- shrink a] +++ [node2 a b' | b' <- shrink b]+ shrink (Node3 _ a b c) =+ [node2 a b, node2 a c, node2 b c] +++ [node3 a' b c | a' <- shrink a] +++ [node3 a b' c | b' <- shrink b] +++ [node3 a b c' | c' <- shrink c]++instance Arbitrary a => Arbitrary (Digit a) where+ arbitrary = oneof [+ One <$> arbitrary,+ Two <$> arbitrary <*> arbitrary,+ Three <$> arbitrary <*> arbitrary <*> arbitrary,+ Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary]++ shrink (One a) = map One (shrink a)+ shrink (Two a b) = [One a, One b]+ shrink (Three a b c) = [Two a b, Two a c, Two b c]+ shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]++------------------------------------------------------------------------+-- Valid trees+------------------------------------------------------------------------++class Valid a where+ valid :: a -> Bool++instance Valid (Elem a) where+ valid _ = True++instance Valid (Seq a) where+ valid (Seq xs) = valid xs++instance (Sized a, Valid a) => Valid (FingerTree a) where+ valid Empty = True+ valid (Single x) = valid x+ valid (Deep s pr m sf) =+ s == size pr + size m + size sf && valid pr && valid m && valid sf++instance (Sized a, Valid a) => Valid (Node a) where+ valid node = size node == sum (fmap size node) && all valid node++instance Valid a => Valid (Digit a) where+ valid = all valid #endif
Data/Set.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -cpp #-}+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Set@@ -20,12 +20,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@@ -34,9 +34,28 @@ -- equality. ----------------------------------------------------------------------------- -module Data.Set ( +-- It is crucial to the performance that the functions specialize on the Ord+-- type when possible. GHC 7.0 and higher does this by itself when it sees th+-- unfolding of a function -- that is why all public functions are marked+-- INLINABLE (that exposes the unfolding).+--+-- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.+-- We mark the functions that just navigate down the tree (lookup, insert,+-- delete and similar). That navigation code gets inlined and thus specialized+-- when possible. There is a price to pay -- code growth. The code INLINED is+-- therefore only the tree navigation, all the real work (rebalancing) is not+-- INLINED by using a NOINLINE.+--+-- All methods that can be INLINE are not recursive -- a 'go' function doing+-- the real work is provided.++module Data.Set ( -- * Set type+#if !defined(TESTING) Set -- instance Eq,Ord,Show,Read,Data,Typeable+#else+ Set(..)+#endif -- * Operators , (\\)@@ -48,18 +67,19 @@ , notMember , isSubsetOf , isProperSubsetOf- + -- * Construction , empty , singleton , insert , delete- + -- * Combine- , union, unions+ , union+ , unions , difference , intersection- + -- * Filter , filter , partition@@ -67,8 +87,8 @@ , splitMember -- * Map- , map- , mapMonotonic+ , map+ , mapMonotonic -- * Fold , fold@@ -89,26 +109,31 @@ , elems , toList , fromList- + -- ** Ordered list , toAscList , fromAscList , fromDistinctAscList- + -- * Debugging , showTree , showTreeWith , valid++#if defined(TESTING)+ -- Internals (for testing)+ , bin+ , balanced+ , join+ , merge+#endif ) where import Prelude hiding (filter,foldr,null,map) import qualified Data.List as List import Data.Monoid (Monoid(..)) import Data.Foldable (Foldable(foldMap))-#ifndef __GLASGOW_HASKELL__-import Data.Typeable (Typeable, typeOf, typeOfDefault)-#endif-import Data.Typeable (Typeable1(..), TyCon, mkTyCon, mkTyConApp)+import Data.Typeable {- -- just for testing@@ -119,9 +144,15 @@ #if __GLASGOW_HASKELL__ import Text.Read-import Data.Data (Data(..), mkNoRepType, gcast1)+import Data.Data #endif +-- Use macros to define strictness of functions.+-- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.+-- We do not use BangPatterns, because they are not in any standard and we+-- want the compilers to be compiled by as many compilers as possible.+#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined+ {-------------------------------------------------------------------- Operators --------------------------------------------------------------------}@@ -130,13 +161,16 @@ -- | /O(n+m)/. See 'difference'. (\\) :: Ord a => Set a -> Set a -> Set a m1 \\ m2 = difference m1 m2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE (\\) #-}+#endif {-------------------------------------------------------------------- Sets are size balanced trees --------------------------------------------------------------------} -- | A set of values @a@. data Set a = Tip - | Bin {-# UNPACK #-} !Size a !(Set a) !(Set a) + | Bin {-# UNPACK #-} !Size !a !(Set a) !(Set a) type Size = Int @@ -172,45 +206,51 @@ --------------------------------------------------------------------} -- | /O(1)/. Is this the empty set? null :: Set a -> Bool-null t- = case t of- Tip -> True- Bin {} -> False+null Tip = True+null (Bin {}) = False+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE null #-}+#endif -- | /O(1)/. The number of elements in the set. size :: Set a -> Int-size t- = case t of- Tip -> 0- Bin sz _ _ _ -> sz+size Tip = 0+size (Bin sz _ _ _) = sz+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE size #-}+#endif -- | /O(log n)/. Is the element in the set? member :: Ord a => a -> Set a -> Bool-member x t- = case t of- Tip -> False- Bin _ y l r- -> case compare x y of- LT -> member x l- GT -> member x r- EQ -> True +member = go+ where+ STRICT_1_OF_2(go)+ go _ Tip = False+ go x (Bin _ y l r) = case compare x y of+ LT -> go x l+ GT -> go x r+ EQ -> True+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE member #-}+#else+{-# INLINE member #-}+#endif -- | /O(log n)/. Is the element not in the set? notMember :: Ord a => a -> Set a -> Bool-notMember x t = not $ member x t+notMember a t = not $ member a t+{-# INLINE notMember #-} {-------------------------------------------------------------------- Construction --------------------------------------------------------------------} -- | /O(1)/. The empty set. empty :: Set a-empty- = Tip+empty = Tip -- | /O(1)/. Create a singleton set. singleton :: a -> Set a-singleton x - = Bin 1 x Tip Tip+singleton x = Bin 1 x Tip Tip {-------------------------------------------------------------------- Insertion, Deletion@@ -219,26 +259,52 @@ -- If the set already contains an element equal to the given value, -- it is replaced with the new value. insert :: Ord a => a -> Set a -> Set a-insert x t- = case t of- Tip -> singleton x- Bin sz y l r- -> case compare x y of- LT -> balance y (insert x l) r- GT -> balance y l (insert x r)- EQ -> Bin sz x l r+insert = go+ where+ STRICT_1_OF_2(go)+ go x Tip = singleton x+ go x (Bin sz y l r) = case compare x y of+ LT -> balanceL y (go x l) r+ GT -> balanceR y l (go x r)+ EQ -> Bin sz x l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINEABLE insert #-}+#else+{-# INLINE insert #-}+#endif +-- Insert an element to the set only if it is not in the set. Used by+-- `union`.+insertR :: Ord a => a -> Set a -> Set a+insertR = go+ where+ STRICT_1_OF_2(go)+ go x Tip = singleton x+ go x t@(Bin _ y l r) = case compare x y of+ LT -> balanceL y (go x l) r+ GT -> balanceR y l (go x r)+ EQ -> t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINEABLE insertR #-}+#else+{-# INLINE insertR #-}+#endif -- | /O(log n)/. Delete an element from a set. delete :: Ord a => a -> Set a -> Set a-delete x t- = case t of- Tip -> Tip- Bin _ y l r- -> case compare x y of- LT -> balance y (delete x l) r- GT -> balance y l (delete x r)- EQ -> glue l r+delete = go+ where+ STRICT_1_OF_2(go)+ go _ Tip = Tip+ go x (Bin _ y l r) = case compare x y of+ LT -> balanceR y (go x l) r+ GT -> balanceL y l (go x r)+ EQ -> glue l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINEABLE delete #-}+#else+{-# INLINE delete #-}+#endif {-------------------------------------------------------------------- Subset@@ -247,6 +313,9 @@ isProperSubsetOf :: Ord a => Set a -> Set a -> Bool isProperSubsetOf s1 s2 = (size s1 < size s2) && (isSubsetOf s1 s2)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE isProperSubsetOf #-}+#endif -- | /O(n+m)/. Is this a subset?@@ -254,6 +323,9 @@ isSubsetOf :: Ord a => Set a -> Set a -> Bool isSubsetOf t1 t2 = (size t1 <= size t2) && (isSubsetOfX t1 t2)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE isSubsetOf #-}+#endif isSubsetOfX :: Ord a => Set a -> Set a -> Bool isSubsetOfX Tip _ = True@@ -262,6 +334,9 @@ = found && isSubsetOfX l lt && isSubsetOfX r gt where (lt,found,gt) = splitMember x t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE isSubsetOfX #-}+#endif {--------------------------------------------------------------------@@ -272,34 +347,46 @@ findMin (Bin _ x Tip _) = x findMin (Bin _ _ l _) = findMin l findMin Tip = error "Set.findMin: empty set has no minimal element"+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE findMin #-}+#endif -- | /O(log n)/. The maximal element of a set. findMax :: Set a -> a findMax (Bin _ x _ Tip) = x findMax (Bin _ _ _ r) = findMax r findMax Tip = error "Set.findMax: empty set has no maximal element"+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE findMax #-}+#endif -- | /O(log n)/. Delete the minimal element. deleteMin :: Set a -> Set a deleteMin (Bin _ _ Tip r) = r-deleteMin (Bin _ x l r) = balance x (deleteMin l) r+deleteMin (Bin _ x l r) = balanceR x (deleteMin l) r deleteMin Tip = Tip+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE deleteMin #-}+#endif -- | /O(log n)/. Delete the maximal element. deleteMax :: Set a -> Set a deleteMax (Bin _ _ l Tip) = l-deleteMax (Bin _ x l r) = balance x l (deleteMax r)+deleteMax (Bin _ x l r) = balanceL x l (deleteMax r) deleteMax Tip = Tip-+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE deleteMax #-}+#endif {-------------------------------------------------------------------- Union. --------------------------------------------------------------------} -- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@). unions :: Ord a => [Set a] -> Set a-unions ts- = foldlStrict union empty ts-+unions = foldlStrict union empty+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE unions #-}+#endif -- | /O(n+m)/. The union of two sets, preferring the first set when -- equal elements are encountered.@@ -308,19 +395,27 @@ union :: Ord a => Set a -> Set a -> Set a union Tip t2 = t2 union t1 Tip = t1-union t1 t2 = hedgeUnion (const LT) (const GT) t1 t2+union (Bin _ x Tip Tip) t = insert x t+union t (Bin _ x Tip Tip) = insertR x t+union t1 t2 = hedgeUnion NothingS NothingS t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE union #-}+#endif hedgeUnion :: Ord a- => (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a -> Set a+ => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a hedgeUnion _ _ t1 Tip = t1-hedgeUnion cmplo cmphi Tip (Bin _ x l r)- = join x (filterGt cmplo l) (filterLt cmphi r)-hedgeUnion cmplo cmphi (Bin _ x l r) t2- = join x (hedgeUnion cmplo cmpx l (trim cmplo cmpx t2)) - (hedgeUnion cmpx cmphi r (trim cmpx cmphi t2))+hedgeUnion blo bhi Tip (Bin _ x l r)+ = join x (filterGt blo l) (filterLt bhi r)+hedgeUnion blo bhi (Bin _ x l r) t2+ = join x (hedgeUnion blo bmi l (trim blo bmi t2))+ (hedgeUnion bmi bhi r (trim bmi bhi t2)) where- cmpx y = compare x y+ bmi = JustS x+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE hedgeUnion #-}+#endif {-------------------------------------------------------------------- Difference@@ -330,19 +425,25 @@ difference :: Ord a => Set a -> Set a -> Set a difference Tip _ = Tip difference t1 Tip = t1-difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2+difference t1 t2 = hedgeDiff NothingS NothingS t1 t2+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE difference #-}+#endif hedgeDiff :: Ord a- => (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a -> Set a+ => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a hedgeDiff _ _ Tip _ = Tip-hedgeDiff cmplo cmphi (Bin _ x l r) Tip - = join x (filterGt cmplo l) (filterLt cmphi r)-hedgeDiff cmplo cmphi t (Bin _ x l r) - = merge (hedgeDiff cmplo cmpx (trim cmplo cmpx t) l) - (hedgeDiff cmpx cmphi (trim cmpx cmphi t) r)+hedgeDiff blo bhi (Bin _ x l r) Tip+ = join x (filterGt blo l) (filterLt bhi r)+hedgeDiff blo bhi t (Bin _ x l r)+ = merge (hedgeDiff blo bmi (trim blo bmi t) l)+ (hedgeDiff bmi bhi (trim bmi bhi t) r) where- cmpx y = compare x y+ bmi = JustS x+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE hedgeDiff #-}+#endif {-------------------------------------------------------------------- Intersection@@ -374,6 +475,9 @@ tr = intersection r1 gt in if found then join x1 tl tr else merge tl tr+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE intersection #-}+#endif {-------------------------------------------------------------------- Filter and partition@@ -382,20 +486,24 @@ filter :: Ord a => (a -> Bool) -> Set a -> Set a filter _ Tip = Tip filter p (Bin _ x l r)- | p x = join x (filter p l) (filter p r)- | otherwise = merge (filter p l) (filter p r)+ | p x = join x (filter p l) (filter p r)+ | otherwise = merge (filter p l) (filter p r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE filter #-}+#endif -- | /O(n)/. Partition the set into two sets, one with all elements that satisfy -- the predicate and one with all elements that don't satisfy the predicate. -- See also 'split'. partition :: Ord a => (a -> Bool) -> Set a -> (Set a,Set a)-partition _ Tip = (Tip,Tip)-partition p (Bin _ x l r)- | p x = (join x l1 r1,merge l2 r2)- | otherwise = (merge l1 r1,join x l2 r2)- where- (l1,l2) = partition p l- (r1,r2) = partition p r+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)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE partition #-}+#endif {---------------------------------------------------------------------- Map@@ -409,6 +517,9 @@ map :: (Ord a, Ord b) => (a->b) -> Set a -> Set b map f = fromList . List.map f . toList+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE map #-}+#endif -- | /O(n)/. The --@@ -422,51 +533,62 @@ mapMonotonic :: (a->b) -> Set a -> Set b mapMonotonic _ Tip = Tip-mapMonotonic f (Bin sz x l r) =- Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)-+mapMonotonic f (Bin sz x l r) = Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE mapMonotonic #-}+#endif {-------------------------------------------------------------------- Fold --------------------------------------------------------------------} -- | /O(n)/. Fold over the elements of a set in an unspecified order. fold :: (a -> b -> b) -> b -> Set a -> b-fold f z s- = foldr f z s+fold = foldr+{-# INLINE fold #-} -- | /O(n)/. Post-order fold. foldr :: (a -> b -> b) -> b -> Set a -> b-foldr _ z Tip = z-foldr f z (Bin _ x l r) = foldr f (f x (foldr f z r)) l+foldr f = go+ where+ go z Tip = z+ go z (Bin _ x l r) = go (f x (go z r)) l+{-# INLINE foldr #-} {-------------------------------------------------------------------- List variations --------------------------------------------------------------------} -- | /O(n)/. The elements of a set. elems :: Set a -> [a]-elems s- = toList s+elems = toList+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE elems #-}+#endif {-------------------------------------------------------------------- Lists --------------------------------------------------------------------} -- | /O(n)/. Convert the set to a list of elements. toList :: Set a -> [a]-toList s- = toAscList s+toList = toAscList+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE toList #-}+#endif -- | /O(n)/. Convert the set to an ascending list of elements. toAscList :: Set a -> [a]-toAscList t - = foldr (:) [] t-+toAscList = foldr (:) []+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE toAscList #-}+#endif -- | /O(n*log n)/. Create a set from a list of elements. fromList :: Ord a => [a] -> Set a -fromList xs - = foldlStrict ins empty xs+fromList = foldlStrict ins empty where ins t x = insert x t+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromList #-}+#endif {-------------------------------------------------------------------- Building trees from ascending/descending lists can be done in linear time.@@ -491,6 +613,9 @@ combineEq' z (x:xs') | z==x = combineEq' z xs' | otherwise = z:combineEq' x xs'+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromAscList #-}+#endif -- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.@@ -514,6 +639,9 @@ buildR n c l (x:ys) = build (buildB l x c) n ys buildR _ _ _ [] = error "fromDistinctAscList buildR []" buildB l x c r zs = c (bin x l r) zs+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE fromDistinctAscList #-}+#endif {-------------------------------------------------------------------- Eq converts the set to a list. In a lazy setting, this @@ -537,19 +665,6 @@ showsPrec p xs = showParen (p > 10) $ showString "fromList " . shows (toList xs) -{--XXX unused code--showSet :: (Show a) => [a] -> ShowS-showSet [] - = showString "{}" -showSet (x:xs) - = showChar '{' . shows x . showTail xs- where- showTail [] = showChar '}'- showTail (x':xs') = showChar ',' . shows x' . showTail xs'--}- {-------------------------------------------------------------------- Read --------------------------------------------------------------------}@@ -577,14 +692,15 @@ {-------------------------------------------------------------------- Utility functions that return sub-ranges of the original- tree. Some functions take a comparison function as argument to- allow comparisons against infinite values. A function [cmplo x]- should be read as [compare lo x].+ tree. Some functions take a `Maybe value` as an argument to+ allow comparisons against infinite values. These are called `blow`+ (Nothing is -\infty) and `bhigh` (here Nothing is +\infty).+ We use MaybeS value, which is a Maybe strict in the Just case. - [trim cmplo cmphi t] A tree that is either empty or where [cmplo x == LT]- and [cmphi x == GT] for the value [x] of the root.- [filterGt cmp t] A tree where for all values [k]. [cmp k == LT]- [filterLt cmp t] A tree where for all values [k]. [cmp k == GT]+ [trim blow bhigh t] A tree that is either empty or where [x > blow]+ and [x < bhigh] for the value [x] of the root.+ [filterGt blow t] A tree where for all values [k]. [k > blow]+ [filterLt bhigh t] A tree where for all values [k]. [k < bhigh] [split k t] Returns two trees [l] and [r] where all values in [l] are <[k] and all keys in [r] are >[k].@@ -592,54 +708,53 @@ was found in the tree. --------------------------------------------------------------------} +data MaybeS a = NothingS | JustS !a+ {--------------------------------------------------------------------- [trim lo hi t] trims away all subtrees that surely contain no- values between the range [lo] to [hi]. The returned tree is either- empty or the key of the root is between @lo@ and @hi@.+ [trim blo bhi t] trims away all subtrees that surely contain no+ values between the range [blo] to [bhi]. The returned tree is either+ empty or the key of the root is between @blo@ and @bhi@. --------------------------------------------------------------------}-trim :: (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a-trim _ _ Tip = Tip-trim cmplo cmphi t@(Bin _ x l r)- = case cmplo x of- LT -> case cmphi x of- GT -> t- _ -> trim cmplo cmphi l- _ -> trim cmplo cmphi r--{--XXX unused code--trimMemberLo :: Ord a => a -> (a -> Ordering) -> Set a -> (Bool, Set a)-trimMemberLo _ _ Tip = (False,Tip)-trimMemberLo lo cmphi t@(Bin _ x l r)- = case compare lo x of- LT -> case cmphi x of- GT -> (member lo t, t)- _ -> trimMemberLo lo cmphi l- GT -> trimMemberLo lo cmphi r- EQ -> (True,trim (compare lo) cmphi r)--}+trim :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a+trim NothingS NothingS t = t+trim (JustS lx) NothingS t = greater lx t where greater lo (Bin _ x _ r) | x <= lo = greater lo r+ greater _ t' = t'+trim NothingS (JustS hx) t = lesser hx t where lesser hi (Bin _ x l _) | x >= hi = lesser hi l+ lesser _ t' = t'+trim (JustS lx) (JustS hx) t = middle lx hx t where middle lo hi (Bin _ x _ r) | x <= lo = middle lo hi r+ middle lo hi (Bin _ x l _) | x >= hi = middle lo hi l+ middle _ _ t' = t'+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE trim #-}+#endif {--------------------------------------------------------------------- [filterGt x t] filter all values >[x] from tree [t]- [filterLt x t] filter all values <[x] from tree [t]+ [filterGt b t] filter all values >[b] from tree [t]+ [filterLt b t] filter all values <[b] from tree [t] --------------------------------------------------------------------}-filterGt :: (a -> Ordering) -> Set a -> Set a-filterGt _ Tip = Tip-filterGt cmp (Bin _ x l r)- = case cmp x of- LT -> join x (filterGt cmp l) r- GT -> filterGt cmp r- EQ -> r- -filterLt :: (a -> Ordering) -> Set a -> Set a-filterLt _ Tip = Tip-filterLt cmp (Bin _ x l r)- = case cmp x of- LT -> filterLt cmp l- GT -> join x l (filterLt cmp r)- EQ -> l+filterGt :: Ord a => MaybeS a -> Set a -> Set a+filterGt NothingS t = t+filterGt (JustS b) t = filter' b t+ where filter' _ Tip = Tip+ filter' b' (Bin _ x l r) =+ case compare b' x of LT -> join x (filter' b' l) r+ EQ -> r+ GT -> filter' b' r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE filterGt #-}+#endif +filterLt :: Ord a => MaybeS a -> Set a -> Set a+filterLt NothingS t = t+filterLt (JustS b) t = filter' b t+ where filter' _ Tip = Tip+ filter' b' (Bin _ x l r) =+ case compare x b' of LT -> join x l (filter' b' r)+ EQ -> l+ GT -> filter' b' l+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE filterLt #-}+#endif {-------------------------------------------------------------------- Split@@ -654,12 +769,18 @@ 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)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE split #-}+#endif -- | /O(log n)/. Performs a 'split' but also returns whether the pivot -- element was found in the original set. splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a) splitMember x t = let (l,m,r) = splitLookup x t in (l,maybe False (const True) m,r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE splitMember #-}+#endif -- | /O(log n)/. Performs a 'split' but also returns the pivot -- element that was found in the original set.@@ -670,6 +791,9 @@ LT -> let (lt,found,gt) = splitLookup x l in (lt,found,join y gt r) GT -> let (lt,found,gt) = splitLookup x r in (join y l lt,found,gt) EQ -> (l,Just y,r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE splitLookup #-}+#endif {-------------------------------------------------------------------- Utility functions that maintain the balance properties of the tree.@@ -707,9 +831,12 @@ join x Tip r = insertMin x r join x l Tip = insertMax x l join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)- | delta*sizeL <= sizeR = balance z (join x l lz) rz- | delta*sizeR <= sizeL = balance y ly (join x ry r)- | otherwise = bin x l r+ | delta*sizeL < sizeR = balanceL z (join x l lz) rz+ | delta*sizeR < sizeL = balanceR y ly (join x ry r)+ | otherwise = bin x l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE join #-}+#endif -- insertMin and insertMax don't perform potentially expensive comparisons.@@ -718,14 +845,20 @@ = case t of Tip -> singleton x Bin _ y l r- -> balance y l (insertMax x r)- + -> balanceR y l (insertMax x r)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertMax #-}+#endif+ insertMin x t = case t of Tip -> singleton x Bin _ y l r- -> balance y (insertMin x l) r- + -> balanceL y (insertMin x l) r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE insertMin #-}+#endif+ {-------------------------------------------------------------------- [merge l r]: merges two trees. --------------------------------------------------------------------}@@ -733,9 +866,12 @@ merge Tip r = r merge l Tip = l merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)- | delta*sizeL <= sizeR = balance y (merge l ly) ry- | delta*sizeR <= sizeL = balance x lx (merge rx r)- | otherwise = glue l r+ | delta*sizeL < sizeR = balanceL y (merge l ly) ry+ | delta*sizeR < sizeL = balanceR x lx (merge rx r)+ | otherwise = glue l r+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE merge #-}+#endif {-------------------------------------------------------------------- [glue l r]: glues two trees together.@@ -745,8 +881,11 @@ glue Tip r = r glue l Tip = l glue l r - | size l > size r = let (m,l') = deleteFindMax l in balance m l' r- | otherwise = let (m,r') = deleteFindMin r in balance m l r'+ | size l > size r = let (m,l') = deleteFindMax l in balanceR m l' r+ | otherwise = let (m,r') = deleteFindMin r in balanceL m l r'+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE glue #-}+#endif -- | /O(log n)/. Delete and find the minimal element.@@ -757,8 +896,11 @@ deleteFindMin t = case t of Bin _ x Tip r -> (x,r)- Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balance x l' r)+ Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balanceR x l' r) Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE deleteFindMin #-}+#endif -- | /O(log n)/. Delete and find the maximal element. -- @@ -767,20 +909,29 @@ deleteFindMax t = case t of Bin _ x l Tip -> (x,l)- Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balance x l r')+ Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balanceL x l r') Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE deleteFindMax #-}+#endif -- | /O(log n)/. Retrieves the minimal key of the set, and the set -- stripped of that element, or 'Nothing' if passed an empty set. minView :: Set a -> Maybe (a, Set a) minView Tip = Nothing minView x = Just (deleteFindMin x)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE minView #-}+#endif -- | /O(log n)/. Retrieves the maximal key of the set, and the set -- stripped of that element, or 'Nothing' if passed an empty set. maxView :: Set a -> Maybe (a, Set a) maxView Tip = Nothing maxView x = Just (deleteFindMax x)+#if __GLASGOW_HASKELL__ >= 700+{-# INLINABLE maxView #-}+#endif {-------------------------------------------------------------------- [balance x l r] balances two trees with value x.@@ -788,104 +939,142 @@ size of one of them. (a rotation). [delta] is the maximal relative difference between the sizes of- two trees, it corresponds with the [w] in Adams' paper,- or equivalently, [1/delta] corresponds with the $\alpha$- in Nievergelt's paper. Adams shows that [delta] should- be larger than 3.745 in order to garantee that the- rotations can always restore balance. -+ two trees, it corresponds with the [w] in Adams' paper. [ratio] is the ratio between an outer and inner sibling of the heavier subtree in an unbalanced setting. It determines whether a double or single rotation should be performed to restore balance. It is correspondes with the inverse of $\alpha$ in Adam's article. - Note that:+ Note that according to the Adam's paper: - [delta] should be larger than 4.646 with a [ratio] of 2. - [delta] should be larger than 3.745 with a [ratio] of 1.534.- ++ But the Adam's paper is errorneous:+ - it can be proved that for delta=2 and delta>=5 there does+ not exist any ratio that would work+ - delta=4.5 and ratio=2 does not work++ That leaves two reasonable variants, delta=3 and delta=4,+ both with ratio=2.+ - A lower [delta] leads to a more 'perfectly' balanced tree. - A higher [delta] performs less rebalancing. - - Balancing is automatic for random data and a balancing- scheme is only necessary to avoid pathological worst cases.- Almost any choice will do in practice- - - Allthough it seems that a rather large [delta] may perform better - than smaller one, measurements have shown that the smallest [delta]- of 4 is actually the fastest on a wide range of operations. It- especially improves performance on worst-case scenarios like- a sequence of ordered insertions.+ In the benchmarks, delta=3 is faster on insert operations,+ and delta=4 has slightly better deletes. As the insert speedup+ is larger, we currently use delta=3. - Note: in contrast to Adams' paper, we use a ratio of (at least) 2- to decide whether a single or double rotation is needed. Allthough- he actually proves that this ratio is needed to maintain the- invariants, his implementation uses a (invalid) ratio of 1. - He is aware of the problem though since he has put a comment in his - original source code that he doesn't care about generating a - slightly inbalanced tree since it doesn't seem to matter in practice. - However (since we use quickcheck :-) we will stick to strictly balanced - trees. --------------------------------------------------------------------} delta,ratio :: Int-delta = 4+delta = 3 ratio = 2 -balance :: a -> Set a -> Set a -> Set a-balance x l r- | sizeL + sizeR <= 1 = Bin sizeX x l r- | sizeR >= delta*sizeL = rotateL x l r- | sizeL >= delta*sizeR = rotateR x l r- | otherwise = Bin sizeX x l r- where- sizeL = size l- sizeR = size r- sizeX = sizeL + sizeR + 1+-- The balance function is equivalent to the following:+--+-- balance :: a -> Set a -> Set a -> Set a+-- balance x l r+-- | sizeL + sizeR <= 1 = Bin sizeX x l r+-- | sizeR > delta*sizeL = rotateL x l r+-- | sizeL > delta*sizeR = rotateR x l r+-- | otherwise = Bin sizeX x l r+-- where+-- sizeL = size l+-- sizeR = size r+-- sizeX = sizeL + sizeR + 1+--+-- rotateL :: a -> Set a -> Set a -> Set a+-- rotateL x l r@(Bin _ _ ly ry) | size ly < ratio*size ry = singleL x l r+-- | otherwise = doubleL x l r+-- rotateR :: a -> Set a -> Set a -> Set a+-- rotateR x l@(Bin _ _ ly ry) r | size ry < ratio*size ly = singleR x l r+-- | otherwise = doubleR x l r+--+-- singleL, singleR :: a -> Set a -> Set a -> Set a+-- singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3+-- singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3)+--+-- doubleL, doubleR :: a -> Set a -> Set a -> Set a+-- doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)+-- doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)+--+-- It is only written in such a way that every node is pattern-matched only once.+--+-- Only balanceL and balanceR are needed at the moment, so balance is not here anymore.+-- In case it is needed, it can be found in Data.Map. --- rotate-rotateL :: a -> Set a -> Set a -> Set a-rotateL x l r@(Bin _ _ ly ry)- | size ly < ratio*size ry = singleL x l r- | otherwise = doubleL x l r-rotateL _ _ Tip = error "rotateL Tip"+-- Functions balanceL and balanceR are specialised versions of balance.+-- balanceL only checks whether the left subtree is too big,+-- balanceR only checks whether the right subtree is too big. -rotateR :: a -> Set a -> Set a -> Set a-rotateR x l@(Bin _ _ ly ry) r- | size ry < ratio*size ly = singleR x l r- | otherwise = doubleR x l r-rotateR _ Tip _ = error "rotateL Tip"+-- balanceL is called when left subtree might have been inserted to or when+-- right subtree might have been deleted from.+balanceL :: a -> Set a -> Set a -> Set a+balanceL x l r = case r of+ Tip -> case l of+ Tip -> Bin 1 x Tip Tip+ (Bin _ _ Tip Tip) -> Bin 2 x l Tip+ (Bin _ lx Tip (Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)+ (Bin _ lx ll@(Bin _ _ _ _) Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip)+ (Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr))+ | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)+ | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip) --- basic rotations-singleL, singleR :: a -> Set a -> Set a -> Set a-singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3-singleL _ _ Tip = error "singleL"-singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3)-singleR _ Tip _ = error "singleR"+ (Bin rs _ _ _) -> case l of+ Tip -> Bin (1+rs) x Tip r -doubleL, doubleR :: a -> Set a -> Set a -> Set a-doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)-doubleL _ _ _ = error "doubleL"-doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)-doubleR _ _ _ = error "doubleR"+ (Bin ls lx ll lr)+ | ls > delta*rs -> case (ll, lr) of+ (Bin lls _ _ _, Bin lrs lrx lrl lrr)+ | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)+ | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)+ (_, _) -> error "Failure in Data.Map.balanceL"+ | otherwise -> Bin (1+ls+rs) x l r+{-# NOINLINE balanceL #-} +-- balanceR is called when right subtree might have been inserted to or when+-- left subtree might have been deleted from.+balanceR :: a -> Set a -> Set a -> Set a+balanceR x l r = case l of+ Tip -> case r of+ Tip -> Bin 1 x Tip Tip+ (Bin _ _ Tip Tip) -> Bin 2 x Tip r+ (Bin _ rx Tip rr@(Bin _ _ _ _)) -> Bin 3 rx (Bin 1 x Tip Tip) rr+ (Bin _ rx (Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)+ (Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _))+ | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr+ | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr) + (Bin ls _ _ _) -> case r of+ Tip -> Bin (1+ls) x l Tip++ (Bin rs rx rl rr)+ | rs > delta*ls -> case (rl, rr) of+ (Bin rls rlx rll rlr, Bin rrs _ _ _)+ | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr+ | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)+ (_, _) -> error "Failure in Data.Map.balanceR"+ | otherwise -> Bin (1+ls+rs) x l r+{-# NOINLINE balanceR #-}+ {-------------------------------------------------------------------- The bin constructor maintains the size of the tree --------------------------------------------------------------------} bin :: a -> Set a -> Set a -> Set a bin x l r = Bin (size l + size r + 1) x l r+{-# INLINE bin #-} {-------------------------------------------------------------------- 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)-+foldlStrict f = go+ where+ go z [] = z+ go z (x:xs) = let z' = f z x in z' `seq` go z' xs+{-# INLINE foldlStrict #-} {-------------------------------------------------------------------- Debugging@@ -1015,166 +1204,3 @@ Bin sz _ l r -> case (realsize l,realsize r) of (Just n,Just m) | n+m+1 == sz -> Just sz _ -> Nothing--{--{--------------------------------------------------------------------- Testing---------------------------------------------------------------------}-testTree :: [Int] -> Set Int-testTree xs = fromList 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- 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 a) => Arbitrary (Set a) where- arbitrary = sized (arbtree 0 maxkey)- where maxkey = 10000--arbtree :: (Enum a) => Int -> Int -> Int -> Gen (Set a)-arbtree lo hi n- | n <= 0 = return Tip- | lo >= hi = return Tip- | otherwise = do{ 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) l r)- } ---{--------------------------------------------------------------------- Valid tree's---------------------------------------------------------------------}-forValid :: (Enum a,Show a,Testable b) => (Set 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 => (Set Int -> a) -> Property-forValidIntTree f- = forValid f--forValidUnitTree :: Testable a => (Set Int -> a) -> Property-forValidUnitTree f- = forValid f---prop_Valid - = forValidUnitTree $ \t -> valid t--{--------------------------------------------------------------------- Single, Insert, Delete---------------------------------------------------------------------}-prop_Single :: Int -> Bool-prop_Single x- = (insert x empty == singleton x)--prop_InsertValid :: Int -> Property-prop_InsertValid k- = forValidUnitTree $ \t -> valid (insert k t)--prop_InsertDelete :: Int -> Set Int -> Property-prop_InsertDelete k t- = not (member k t) ==> 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 x- = forValidUnitTree $ \t ->- let (l,r) = split x t- in valid (join x l r)--prop_Merge :: Int -> Property -prop_Merge x- = forValidUnitTree $ \t ->- let (l,r) = split x t- in valid (merge l r)---{--------------------------------------------------------------------- Union---------------------------------------------------------------------}-prop_UnionValid :: Property-prop_UnionValid- = forValidUnitTree $ \t1 ->- forValidUnitTree $ \t2 ->- valid (union t1 t2)--prop_UnionInsert :: Int -> Set Int -> Bool-prop_UnionInsert x t- = union t (singleton x) == insert x t--prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool-prop_UnionAssoc t1 t2 t3- = union t1 (union t2 t3) == union (union t1 t2) t3--prop_UnionComm :: Set Int -> Set Int -> Bool-prop_UnionComm t1 t2- = (union t1 t2 == union t2 t1)---prop_DiffValid- = forValidUnitTree $ \t1 ->- forValidUnitTree $ \t2 ->- valid (difference t1 t2)--prop_Diff :: [Int] -> [Int] -> Bool-prop_Diff xs ys- = toAscList (difference (fromList xs) (fromList ys))- == List.sort ((List.\\) (nub xs) (nub ys))--prop_IntValid- = forValidUnitTree $ \t1 ->- forValidUnitTree $ \t2 ->- valid (intersection t1 t2)--prop_Int :: [Int] -> [Int] -> Bool-prop_Int xs ys- = toAscList (intersection (fromList xs) (fromList ys))- == List.sort (nub ((List.intersect) (xs) (ys)))--{--------------------------------------------------------------------- Lists---------------------------------------------------------------------}-prop_Ordered- = forAll (choose (5,100)) $ \n ->- let xs = [0..n::Int]- in fromAscList xs == fromList xs--prop_List :: [Int] -> Bool-prop_List xs- = (sort (nub xs) == toList (fromList xs))--}
Data/Tree.hs view
@@ -13,26 +13,22 @@ ----------------------------------------------------------------------------- module Data.Tree(- Tree(..), Forest,- -- * Two-dimensional drawing- drawTree, drawForest,- -- * Extraction- flatten, levels,- -- * Building trees- unfoldTree, unfoldForest,- unfoldTreeM, unfoldForestM,- unfoldTreeM_BF, unfoldForestM_BF,+ Tree(..), Forest,+ -- * Two-dimensional drawing+ drawTree, drawForest,+ -- * Extraction+ flatten, levels,+ -- * Building trees+ unfoldTree, unfoldForest,+ unfoldTreeM, unfoldForestM,+ unfoldTreeM_BF, unfoldForestM_BF, ) where -#ifdef __HADDOCK__-import Prelude-#endif- import Control.Applicative (Applicative(..), (<$>)) import Control.Monad import Data.Monoid (Monoid(..)) import Data.Sequence (Seq, empty, singleton, (<|), (|>), fromList,- ViewL(..), ViewR(..), viewl, viewr)+ ViewL(..), ViewR(..), viewl, viewr) import Data.Foldable (Foldable(foldMap), toList) import Data.Traversable (Traversable(traverse)) import Data.Typeable@@ -42,21 +38,14 @@ #endif -- | Multi-way trees, also known as /rose trees/.-data Tree a = Node {- rootLabel :: a, -- ^ label value- subForest :: Forest a -- ^ zero or more child trees- }-#ifndef __HADDOCK__-# ifdef __GLASGOW_HASKELL__+data Tree a = Node {+ rootLabel :: a, -- ^ label value+ subForest :: Forest a -- ^ zero or more child trees+ }+#ifdef __GLASGOW_HASKELL__ deriving (Eq, Read, Show, Data)-# else+#else deriving (Eq, Read, Show)-# endif-#else /* __HADDOCK__ (which can't figure these out by itself) */-instance Eq a => Eq (Tree a)-instance Read a => Read (Tree a)-instance Show a => Show (Tree a)-instance Data a => Data (Tree a) #endif type Forest a = [Tree a] @@ -64,23 +53,23 @@ INSTANCE_TYPEABLE1(Tree,treeTc,"Tree") instance Functor Tree where- fmap f (Node x ts) = Node (f x) (map (fmap f) ts)+ fmap f (Node x ts) = Node (f x) (map (fmap f) ts) instance Applicative Tree where- pure x = Node x []- Node f tfs <*> tx@(Node x txs) =- Node (f x) (map (f <$>) txs ++ map (<*> tx) tfs)+ pure x = Node x []+ Node f tfs <*> tx@(Node x txs) =+ Node (f x) (map (f <$>) txs ++ map (<*> tx) tfs) instance Monad Tree where- return x = Node x []- Node x ts >>= f = Node x' (ts' ++ map (>>= f) ts)- where Node x' ts' = f x+ return x = Node x []+ Node x ts >>= f = Node x' (ts' ++ map (>>= f) ts)+ where Node x' ts' = f x instance Traversable Tree where- traverse f (Node x ts) = Node <$> f x <*> traverse (traverse f) ts+ traverse f (Node x ts) = Node <$> f x <*> traverse (traverse f) ts instance Foldable Tree where- foldMap f (Node x ts) = f x `mappend` foldMap (foldMap f) ts+ foldMap f (Node x ts) = f x `mappend` foldMap (foldMap f) ts -- | Neat 2-dimensional drawing of a tree. drawTree :: Tree String -> String@@ -92,13 +81,14 @@ draw :: Tree String -> [String] draw (Node x ts0) = x : drawSubTrees ts0- where drawSubTrees [] = []- drawSubTrees [t] =- "|" : shift "`- " " " (draw t)- drawSubTrees (t:ts) =- "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts+ where+ drawSubTrees [] = []+ drawSubTrees [t] =+ "|" : shift "`- " " " (draw t)+ drawSubTrees (t:ts) =+ "|" : shift "+- " "| " (draw t) ++ drawSubTrees ts - shift first other = zipWith (++) (first : repeat other)+ shift first other = zipWith (++) (first : repeat other) -- | The elements of a tree in pre-order. flatten :: Tree a -> [a]@@ -107,9 +97,10 @@ -- | Lists of nodes at each level of the tree. levels :: Tree a -> [[a]]-levels t = map (map rootLabel) $- takeWhile (not . null) $- iterate (concatMap subForest) [t]+levels t =+ map (map rootLabel) $+ takeWhile (not . null) $+ iterate (concatMap subForest) [t] -- | Build a tree from a seed value unfoldTree :: (b -> (a, [b])) -> b -> Tree a@@ -122,9 +113,9 @@ -- | Monadic tree builder, in depth-first order unfoldTreeM :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a) unfoldTreeM f b = do- (a, bs) <- f b- ts <- unfoldForestM f bs- return (Node a ts)+ (a, bs) <- f b+ ts <- unfoldForestM f bs+ return (Node a ts) -- | Monadic forest builder, in depth-first order #ifndef __NHC__@@ -138,9 +129,10 @@ -- by Chris Okasaki, /ICFP'00/. unfoldTreeM_BF :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a) unfoldTreeM_BF f b = liftM getElement $ unfoldForestQ f (singleton b)- where getElement xs = case viewl xs of- x :< _ -> x- EmptyL -> error "unfoldTreeM_BF"+ where+ getElement xs = case viewl xs of+ x :< _ -> x+ EmptyL -> error "unfoldTreeM_BF" -- | Monadic forest builder, in breadth-first order, -- using an algorithm adapted from@@ -153,14 +145,15 @@ -- produces a sequence (reversed queue) of trees of the same length unfoldForestQ :: Monad m => (b -> m (a, [b])) -> Seq b -> m (Seq (Tree a)) unfoldForestQ f aQ = case viewl aQ of- EmptyL -> return empty- a :< aQ' -> do- (b, as) <- f a- tQ <- unfoldForestQ f (Prelude.foldl (|>) aQ' as)- let (tQ', ts) = splitOnto [] as tQ- return (Node b ts <| tQ')- where splitOnto :: [a'] -> [b'] -> Seq a' -> (Seq a', [a'])- splitOnto as [] q = (q, as)- splitOnto as (_:bs) q = case viewr q of- q' :> a -> splitOnto (a:as) bs q'- EmptyR -> error "unfoldForestQ"+ EmptyL -> return empty+ a :< aQ' -> do+ (b, as) <- f a+ tQ <- unfoldForestQ f (Prelude.foldl (|>) aQ' as)+ let (tQ', ts) = splitOnto [] as tQ+ return (Node b ts <| tQ')+ where+ splitOnto :: [a'] -> [b'] -> Seq a' -> (Seq a', [a'])+ splitOnto as [] q = (q, as)+ splitOnto as (_:bs) q = case viewr q of+ q' :> a -> splitOnto (a:as) bs q'+ EmptyR -> error "unfoldForestQ"
containers.cabal view
@@ -1,23 +1,23 @@-name: containers-version: 0.4.0.0-license: BSD3-license-file: LICENSE-maintainer: libraries@haskell.org+name: containers+version: 0.4.1.0+license: BSD3+license-file: LICENSE+maintainer: libraries@haskell.org bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries%20%28other%29-synopsis: Assorted concrete container types-category: Data Structures+synopsis: Assorted concrete container types+category: Data Structures description:- This package contains efficient general-purpose implementations- of various basic immutable container types. The declared cost of- each operation is either worst-case or amortized, but remains- valid even if structures are shared.+ This package contains efficient general-purpose implementations+ of various basic immutable container types. The declared cost of+ each operation is either worst-case or amortized, but remains+ valid even if structures are shared. build-type: Simple cabal-version: >=1.6 extra-source-files: include/Typeable.h source-repository head- type: darcs- location: http://darcs.haskell.org/packages/containers/+ type: git+ location: http://github.com/haskell/containers.git Library { build-depends: base >= 4.2 && < 6, array@@ -38,7 +38,8 @@ Data.Tree } if impl(ghc) {- extensions: DeriveDataTypeable, MagicHash, Rank2Types+ extensions: DeriveDataTypeable, StandaloneDeriving,+ MagicHash, Rank2Types } }
include/Typeable.h view
@@ -14,32 +14,22 @@ #ifndef TYPEABLE_H #define TYPEABLE_H -#define INSTANCE_TYPEABLE0(tycon,tcname,str) \-tcname :: TyCon; \-tcname = mkTyCon str; \-instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] }- #ifdef __GLASGOW_HASKELL__ --- // For GHC, the extra instances follow from general instance declarations--- // defined in Data.Typeable.+-- // For GHC, we can use DeriveDataTypeable + StandaloneDeriving to+-- // generate the instances. -#define INSTANCE_TYPEABLE1(tycon,tcname,str) \-tcname :: TyCon; \-tcname = mkTyCon str; \-instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }+#define INSTANCE_TYPEABLE0(tycon,tcname,str) deriving instance Typeable tycon+#define INSTANCE_TYPEABLE1(tycon,tcname,str) deriving instance Typeable1 tycon+#define INSTANCE_TYPEABLE2(tycon,tcname,str) deriving instance Typeable2 tycon+#define INSTANCE_TYPEABLE3(tycon,tcname,str) deriving instance Typeable3 tycon -#define INSTANCE_TYPEABLE2(tycon,tcname,str) \-tcname :: TyCon; \-tcname = mkTyCon str; \-instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }+#else /* !__GLASGOW_HASKELL__ */ -#define INSTANCE_TYPEABLE3(tycon,tcname,str) \+#define INSTANCE_TYPEABLE0(tycon,tcname,str) \ tcname :: TyCon; \ tcname = mkTyCon str; \-instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }--#else /* !__GLASGOW_HASKELL__ */+instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] } #define INSTANCE_TYPEABLE1(tycon,tcname,str) \ tcname = mkTyCon str; \