4767a1d6ecc0810e5a0e37399ff0108d87c83aa3
[packages/containers.git] / Data / Map / Base.hs
1 {-# LANGUAGE CPP #-}
2 #if __GLASGOW_HASKELL__
3 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
4 #endif
5 #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703
6 {-# LANGUAGE Trustworthy #-}
7 #endif
8 -----------------------------------------------------------------------------
9 -- |
10 -- Module : Data.Map.Base
11 -- Copyright : (c) Daan Leijen 2002
12 -- (c) Andriy Palamarchuk 2008
13 -- License : BSD-style
14 -- Maintainer : libraries@haskell.org
15 -- Stability : provisional
16 -- Portability : portable
17 --
18 -- An efficient implementation of maps from keys to values (dictionaries).
19 --
20 -- Since many function names (but not the type name) clash with
21 -- "Prelude" names, this module is usually imported @qualified@, e.g.
22 --
23 -- > import Data.Map (Map)
24 -- > import qualified Data.Map as Map
25 --
26 -- The implementation of 'Map' is based on /size balanced/ binary trees (or
27 -- trees of /bounded balance/) as described by:
28 --
29 -- * Stephen Adams, \"/Efficient sets: a balancing act/\",
30 -- Journal of Functional Programming 3(4):553-562, October 1993,
31 -- <http://www.swiss.ai.mit.edu/~adams/BB/>.
32 --
33 -- * J. Nievergelt and E.M. Reingold,
34 -- \"/Binary search trees of bounded balance/\",
35 -- SIAM journal of computing 2(1), March 1973.
36 --
37 -- Note that the implementation is /left-biased/ -- the elements of a
38 -- first argument are always preferred to the second, for example in
39 -- 'union' or 'insert'.
40 --
41 -- Operation comments contain the operation time complexity in
42 -- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.
43 -----------------------------------------------------------------------------
44
45 -- [Note: Using INLINABLE]
46 -- ~~~~~~~~~~~~~~~~~~~~~~~
47 -- It is crucial to the performance that the functions specialize on the Ord
48 -- type when possible. GHC 7.0 and higher does this by itself when it sees th
49 -- unfolding of a function -- that is why all public functions are marked
50 -- INLINABLE (that exposes the unfolding).
51
52
53 -- [Note: Using INLINE]
54 -- ~~~~~~~~~~~~~~~~~~~~
55 -- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.
56 -- We mark the functions that just navigate down the tree (lookup, insert,
57 -- delete and similar). That navigation code gets inlined and thus specialized
58 -- when possible. There is a price to pay -- code growth. The code INLINED is
59 -- therefore only the tree navigation, all the real work (rebalancing) is not
60 -- INLINED by using a NOINLINE.
61 --
62 -- All methods marked INLINE have to be nonrecursive -- a 'go' function doing
63 -- the real work is provided.
64
65
66 -- [Note: Type of local 'go' function]
67 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
68 -- If the local 'go' function uses an Ord class, it sometimes heap-allocates
69 -- the Ord dictionary when the 'go' function does not have explicit type.
70 -- In that case we give 'go' explicit type. But this slightly decrease
71 -- performance, as the resulting 'go' function can float out to top level.
72
73
74 -- [Note: Local 'go' functions and capturing]
75 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
76 -- As opposed to IntMap, when 'go' function captures an argument, increased
77 -- heap-allocation can occur: sometimes in a polymorphic function, the 'go'
78 -- floats out of its enclosing function and then it heap-allocates the
79 -- dictionary and the argument. Maybe it floats out too late and strictness
80 -- analyzer cannot see that these could be passed on stack.
81 --
82 -- For example, change 'member' so that its local 'go' function is not passing
83 -- argument k and then look at the resulting code for hedgeInt.
84
85
86 -- [Note: Order of constructors]
87 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
88 -- The order of constructors of Map matters when considering performance.
89 -- Currently in GHC 7.0, when type has 2 constructors, a forward conditional
90 -- jump is made when successfully matching second constructor. Successful match
91 -- of first constructor results in the forward jump not taken.
92 -- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip
93 -- improves the benchmark by up to 10% on x86.
94
95 module Data.Map.Base (
96 -- * Map type
97 Map(..) -- instance Eq,Show,Read
98
99 -- * Operators
100 , (!), (\\)
101
102 -- * Query
103 , null
104 , size
105 , member
106 , notMember
107 , lookup
108 , findWithDefault
109 , lookupLT
110 , lookupGT
111 , lookupLE
112 , lookupGE
113
114 -- * Construction
115 , empty
116 , singleton
117
118 -- ** Insertion
119 , insert
120 , insertWith
121 , insertWithKey
122 , insertLookupWithKey
123
124 -- ** Delete\/Update
125 , delete
126 , adjust
127 , adjustWithKey
128 , update
129 , updateWithKey
130 , updateLookupWithKey
131 , alter
132
133 -- * Combine
134
135 -- ** Union
136 , union
137 , unionWith
138 , unionWithKey
139 , unions
140 , unionsWith
141
142 -- ** Difference
143 , difference
144 , differenceWith
145 , differenceWithKey
146
147 -- ** Intersection
148 , intersection
149 , intersectionWith
150 , intersectionWithKey
151
152 -- ** Universal combining function
153 , mergeWithKey
154
155 -- * Traversal
156 -- ** Map
157 , map
158 , mapWithKey
159 , traverseWithKey
160 , mapAccum
161 , mapAccumWithKey
162 , mapAccumRWithKey
163 , mapKeys
164 , mapKeysWith
165 , mapKeysMonotonic
166
167 -- * Folds
168 , foldr
169 , foldl
170 , foldrWithKey
171 , foldlWithKey
172 , foldMapWithKey
173
174 -- ** Strict folds
175 , foldr'
176 , foldl'
177 , foldrWithKey'
178 , foldlWithKey'
179
180 -- * Conversion
181 , elems
182 , keys
183 , assocs
184 , keysSet
185 , fromSet
186
187 -- ** Lists
188 , toList
189 , fromList
190 , fromListWith
191 , fromListWithKey
192
193 -- ** Ordered lists
194 , toAscList
195 , toDescList
196 , fromAscList
197 , fromAscListWith
198 , fromAscListWithKey
199 , fromDistinctAscList
200
201 -- * Filter
202 , filter
203 , filterWithKey
204 , partition
205 , partitionWithKey
206
207 , mapMaybe
208 , mapMaybeWithKey
209 , mapEither
210 , mapEitherWithKey
211
212 , split
213 , splitLookup
214
215 -- * Submap
216 , isSubmapOf, isSubmapOfBy
217 , isProperSubmapOf, isProperSubmapOfBy
218
219 -- * Indexed
220 , lookupIndex
221 , findIndex
222 , elemAt
223 , updateAt
224 , deleteAt
225
226 -- * Min\/Max
227 , findMin
228 , findMax
229 , deleteMin
230 , deleteMax
231 , deleteFindMin
232 , deleteFindMax
233 , updateMin
234 , updateMax
235 , updateMinWithKey
236 , updateMaxWithKey
237 , minView
238 , maxView
239 , minViewWithKey
240 , maxViewWithKey
241
242 -- * Debugging
243 , showTree
244 , showTreeWith
245 , valid
246
247 -- Used by the strict version
248 , bin
249 , balance
250 , balanced
251 , balanceL
252 , balanceR
253 , delta
254 , link
255 , insertMax
256 , merge
257 , glue
258 , trim
259 , trimLookupLo
260 , foldlStrict
261 , splitTree
262 , MaybeS(..)
263 , filterGt
264 , filterLt
265 ) where
266
267 import Control.Applicative (Applicative(..), (<$>))
268 import Control.DeepSeq (NFData(rnf))
269 import Data.Bits (shiftL, shiftR)
270 import qualified Data.Foldable as Foldable
271 import Data.Monoid (Monoid(..))
272 import Data.StrictPair
273 import Data.Traversable (Traversable(traverse))
274 import Data.Typeable
275 import Prelude hiding (lookup, map, filter, foldr, foldl, null)
276
277 import qualified Data.Set.Base as Set
278
279 #if __GLASGOW_HASKELL__
280 import GHC.Exts ( build )
281 import Text.Read
282 import Data.Data
283 #endif
284
285 -- Use macros to define strictness of functions.
286 -- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.
287 -- We do not use BangPatterns, because they are not in any standard and we
288 -- want the compilers to be compiled by as many compilers as possible.
289 #define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined
290 #define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined
291 #define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefined
292 #define STRICT_1_OF_4(fn) fn arg _ _ _ | arg `seq` False = undefined
293 #define STRICT_2_OF_4(fn) fn _ arg _ _ | arg `seq` False = undefined
294
295 {--------------------------------------------------------------------
296 Operators
297 --------------------------------------------------------------------}
298 infixl 9 !,\\ --
299
300 -- | /O(log n)/. Find the value at a key.
301 -- Calls 'error' when the element can not be found.
302 --
303 -- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map
304 -- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'
305
306 (!) :: Ord k => Map k a -> k -> a
307 m ! k = find k m
308 #if __GLASGOW_HASKELL__ >= 700
309 {-# INLINABLE (!) #-}
310 #endif
311
312 -- | Same as 'difference'.
313 (\\) :: Ord k => Map k a -> Map k b -> Map k a
314 m1 \\ m2 = difference m1 m2
315 #if __GLASGOW_HASKELL__ >= 700
316 {-# INLINABLE (\\) #-}
317 #endif
318
319 {--------------------------------------------------------------------
320 Size balanced trees.
321 --------------------------------------------------------------------}
322 -- | A Map from keys @k@ to values @a@.
323
324 -- See Note: Order of constructors
325 data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
326 | Tip
327
328 type Size = Int
329
330 instance (Ord k) => Monoid (Map k v) where
331 mempty = empty
332 mappend = union
333 mconcat = unions
334
335 #if __GLASGOW_HASKELL__
336
337 {--------------------------------------------------------------------
338 A Data instance
339 --------------------------------------------------------------------}
340
341 -- This instance preserves data abstraction at the cost of inefficiency.
342 -- We provide limited reflection services for the sake of data abstraction.
343
344 instance (Data k, Data a, Ord k) => Data (Map k a) where
345 gfoldl f z m = z fromList `f` toList m
346 toConstr _ = fromListConstr
347 gunfold k z c = case constrIndex c of
348 1 -> k (z fromList)
349 _ -> error "gunfold"
350 dataTypeOf _ = mapDataType
351 dataCast2 f = gcast2 f
352
353 fromListConstr :: Constr
354 fromListConstr = mkConstr mapDataType "fromList" [] Prefix
355
356 mapDataType :: DataType
357 mapDataType = mkDataType "Data.Map.Base.Map" [fromListConstr]
358
359 #endif
360
361 {--------------------------------------------------------------------
362 Query
363 --------------------------------------------------------------------}
364 -- | /O(1)/. Is the map empty?
365 --
366 -- > Data.Map.null (empty) == True
367 -- > Data.Map.null (singleton 1 'a') == False
368
369 null :: Map k a -> Bool
370 null Tip = True
371 null (Bin {}) = False
372 {-# INLINE null #-}
373
374 -- | /O(1)/. The number of elements in the map.
375 --
376 -- > size empty == 0
377 -- > size (singleton 1 'a') == 1
378 -- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3
379
380 size :: Map k a -> Int
381 size Tip = 0
382 size (Bin sz _ _ _ _) = sz
383 {-# INLINE size #-}
384
385
386 -- | /O(log n)/. Lookup the value at a key in the map.
387 --
388 -- The function will return the corresponding value as @('Just' value)@,
389 -- or 'Nothing' if the key isn't in the map.
390 --
391 -- An example of using @lookup@:
392 --
393 -- > import Prelude hiding (lookup)
394 -- > import Data.Map
395 -- >
396 -- > employeeDept = fromList([("John","Sales"), ("Bob","IT")])
397 -- > deptCountry = fromList([("IT","USA"), ("Sales","France")])
398 -- > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])
399 -- >
400 -- > employeeCurrency :: String -> Maybe String
401 -- > employeeCurrency name = do
402 -- > dept <- lookup name employeeDept
403 -- > country <- lookup dept deptCountry
404 -- > lookup country countryCurrency
405 -- >
406 -- > main = do
407 -- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John"))
408 -- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete"))
409 --
410 -- The output of this program:
411 --
412 -- > John's currency: Just "Euro"
413 -- > Pete's currency: Nothing
414 lookup :: Ord k => k -> Map k a -> Maybe a
415 lookup = go
416 where
417 STRICT_1_OF_2(go)
418 go _ Tip = Nothing
419 go k (Bin _ kx x l r) = case compare k kx of
420 LT -> go k l
421 GT -> go k r
422 EQ -> Just x
423 #if __GLASGOW_HASKELL__ >= 700
424 {-# INLINABLE lookup #-}
425 #else
426 {-# INLINE lookup #-}
427 #endif
428
429 -- | /O(log n)/. Is the key a member of the map? See also 'notMember'.
430 --
431 -- > member 5 (fromList [(5,'a'), (3,'b')]) == True
432 -- > member 1 (fromList [(5,'a'), (3,'b')]) == False
433 member :: Ord k => k -> Map k a -> Bool
434 member = go
435 where
436 STRICT_1_OF_2(go)
437 go _ Tip = False
438 go k (Bin _ kx _ l r) = case compare k kx of
439 LT -> go k l
440 GT -> go k r
441 EQ -> True
442 #if __GLASGOW_HASKELL__ >= 700
443 {-# INLINABLE member #-}
444 #else
445 {-# INLINE member #-}
446 #endif
447
448 -- | /O(log n)/. Is the key not a member of the map? See also 'member'.
449 --
450 -- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False
451 -- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True
452
453 notMember :: Ord k => k -> Map k a -> Bool
454 notMember k m = not $ member k m
455 #if __GLASGOW_HASKELL__ >= 700
456 {-# INLINABLE notMember #-}
457 #else
458 {-# INLINE notMember #-}
459 #endif
460
461 -- | /O(log n)/. Find the value at a key.
462 -- Calls 'error' when the element can not be found.
463 find :: Ord k => k -> Map k a -> a
464 find = go
465 where
466 STRICT_1_OF_2(go)
467 go _ Tip = error "Map.!: given key is not an element in the map"
468 go k (Bin _ kx x l r) = case compare k kx of
469 LT -> go k l
470 GT -> go k r
471 EQ -> x
472 #if __GLASGOW_HASKELL__ >= 700
473 {-# INLINABLE find #-}
474 #else
475 {-# INLINE find #-}
476 #endif
477
478 -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
479 -- the value at key @k@ or returns default value @def@
480 -- when the key is not in the map.
481 --
482 -- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'
483 -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'
484 findWithDefault :: Ord k => a -> k -> Map k a -> a
485 findWithDefault = go
486 where
487 STRICT_2_OF_3(go)
488 go def _ Tip = def
489 go def k (Bin _ kx x l r) = case compare k kx of
490 LT -> go def k l
491 GT -> go def k r
492 EQ -> x
493 #if __GLASGOW_HASKELL__ >= 700
494 {-# INLINABLE findWithDefault #-}
495 #else
496 {-# INLINE findWithDefault #-}
497 #endif
498
499 -- | /O(log n)/. Find largest key smaller than the given one and return the
500 -- corresponding (key, value) pair.
501 --
502 -- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing
503 -- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
504 lookupLT :: Ord k => k -> Map k v -> Maybe (k, v)
505 lookupLT = goNothing
506 where
507 STRICT_1_OF_2(goNothing)
508 goNothing _ Tip = Nothing
509 goNothing k (Bin _ kx x l r) | k <= kx = goNothing k l
510 | otherwise = goJust k kx x r
511
512 STRICT_1_OF_4(goJust)
513 goJust _ kx' x' Tip = Just (kx', x')
514 goJust k kx' x' (Bin _ kx x l r) | k <= kx = goJust k kx' x' l
515 | otherwise = goJust k kx x r
516 #if __GLASGOW_HASKELL__ >= 700
517 {-# INLINABLE lookupLT #-}
518 #else
519 {-# INLINE lookupLT #-}
520 #endif
521
522 -- | /O(log n)/. Find smallest key greater than the given one and return the
523 -- corresponding (key, value) pair.
524 --
525 -- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
526 -- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing
527 lookupGT :: Ord k => k -> Map k v -> Maybe (k, v)
528 lookupGT = goNothing
529 where
530 STRICT_1_OF_2(goNothing)
531 goNothing _ Tip = Nothing
532 goNothing k (Bin _ kx x l r) | k < kx = goJust k kx x l
533 | otherwise = goNothing k r
534
535 STRICT_1_OF_4(goJust)
536 goJust _ kx' x' Tip = Just (kx', x')
537 goJust k kx' x' (Bin _ kx x l r) | k < kx = goJust k kx x l
538 | otherwise = goJust k kx' x' r
539 #if __GLASGOW_HASKELL__ >= 700
540 {-# INLINABLE lookupGT #-}
541 #else
542 {-# INLINE lookupGT #-}
543 #endif
544
545 -- | /O(log n)/. Find largest key smaller or equal to the given one and return
546 -- the corresponding (key, value) pair.
547 --
548 -- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing
549 -- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
550 -- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
551 lookupLE :: Ord k => k -> Map k v -> Maybe (k, v)
552 lookupLE = goNothing
553 where
554 STRICT_1_OF_2(goNothing)
555 goNothing _ Tip = Nothing
556 goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goNothing k l
557 EQ -> Just (kx, x)
558 GT -> goJust k kx x r
559
560 STRICT_1_OF_4(goJust)
561 goJust _ kx' x' Tip = Just (kx', x')
562 goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx' x' l
563 EQ -> Just (kx, x)
564 GT -> goJust k kx x r
565 #if __GLASGOW_HASKELL__ >= 700
566 {-# INLINABLE lookupLE #-}
567 #else
568 {-# INLINE lookupLE #-}
569 #endif
570
571 -- | /O(log n)/. Find smallest key greater or equal to the given one and return
572 -- the corresponding (key, value) pair.
573 --
574 -- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
575 -- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
576 -- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing
577 lookupGE :: Ord k => k -> Map k v -> Maybe (k, v)
578 lookupGE = goNothing
579 where
580 STRICT_1_OF_2(goNothing)
581 goNothing _ Tip = Nothing
582 goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l
583 EQ -> Just (kx, x)
584 GT -> goNothing k r
585
586 STRICT_1_OF_4(goJust)
587 goJust _ kx' x' Tip = Just (kx', x')
588 goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l
589 EQ -> Just (kx, x)
590 GT -> goJust k kx' x' r
591 #if __GLASGOW_HASKELL__ >= 700
592 {-# INLINABLE lookupGE #-}
593 #else
594 {-# INLINE lookupGE #-}
595 #endif
596
597 {--------------------------------------------------------------------
598 Construction
599 --------------------------------------------------------------------}
600 -- | /O(1)/. The empty map.
601 --
602 -- > empty == fromList []
603 -- > size empty == 0
604
605 empty :: Map k a
606 empty = Tip
607 {-# INLINE empty #-}
608
609 -- | /O(1)/. A map with a single element.
610 --
611 -- > singleton 1 'a' == fromList [(1, 'a')]
612 -- > size (singleton 1 'a') == 1
613
614 singleton :: k -> a -> Map k a
615 singleton k x = Bin 1 k x Tip Tip
616 {-# INLINE singleton #-}
617
618 {--------------------------------------------------------------------
619 Insertion
620 --------------------------------------------------------------------}
621 -- | /O(log n)/. Insert a new key and value in the map.
622 -- If the key is already present in the map, the associated value is
623 -- replaced with the supplied value. 'insert' is equivalent to
624 -- @'insertWith' 'const'@.
625 --
626 -- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]
627 -- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]
628 -- > insert 5 'x' empty == singleton 5 'x'
629
630 -- See Note: Type of local 'go' function
631 insert :: Ord k => k -> a -> Map k a -> Map k a
632 insert = go
633 where
634 go :: Ord k => k -> a -> Map k a -> Map k a
635 STRICT_1_OF_3(go)
636 go kx x Tip = singleton kx x
637 go kx x (Bin sz ky y l r) =
638 case compare kx ky of
639 LT -> balanceL ky y (go kx x l) r
640 GT -> balanceR ky y l (go kx x r)
641 EQ -> Bin sz kx x l r
642 #if __GLASGOW_HASKELL__ >= 700
643 {-# INLINABLE insert #-}
644 #else
645 {-# INLINE insert #-}
646 #endif
647
648 -- Insert a new key and value in the map if it is not already present.
649 -- Used by `union`.
650
651 -- See Note: Type of local 'go' function
652 insertR :: Ord k => k -> a -> Map k a -> Map k a
653 insertR = go
654 where
655 go :: Ord k => k -> a -> Map k a -> Map k a
656 STRICT_1_OF_3(go)
657 go kx x Tip = singleton kx x
658 go kx x t@(Bin _ ky y l r) =
659 case compare kx ky of
660 LT -> balanceL ky y (go kx x l) r
661 GT -> balanceR ky y l (go kx x r)
662 EQ -> t
663 #if __GLASGOW_HASKELL__ >= 700
664 {-# INLINABLE insertR #-}
665 #else
666 {-# INLINE insertR #-}
667 #endif
668
669 -- | /O(log n)/. Insert with a function, combining new value and old value.
670 -- @'insertWith' f key value mp@
671 -- will insert the pair (key, value) into @mp@ if key does
672 -- not exist in the map. If the key does exist, the function will
673 -- insert the pair @(key, f new_value old_value)@.
674 --
675 -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]
676 -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
677 -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"
678
679 insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
680 insertWith f = insertWithKey (\_ x' y' -> f x' y')
681 #if __GLASGOW_HASKELL__ >= 700
682 {-# INLINABLE insertWith #-}
683 #else
684 {-# INLINE insertWith #-}
685 #endif
686
687 -- | /O(log n)/. Insert with a function, combining key, new value and old value.
688 -- @'insertWithKey' f key value mp@
689 -- will insert the pair (key, value) into @mp@ if key does
690 -- not exist in the map. If the key does exist, the function will
691 -- insert the pair @(key,f key new_value old_value)@.
692 -- Note that the key passed to f is the same key passed to 'insertWithKey'.
693 --
694 -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
695 -- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]
696 -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
697 -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"
698
699 -- See Note: Type of local 'go' function
700 insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
701 insertWithKey = go
702 where
703 go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
704 STRICT_2_OF_4(go)
705 go _ kx x Tip = singleton kx x
706 go f kx x (Bin sy ky y l r) =
707 case compare kx ky of
708 LT -> balanceL ky y (go f kx x l) r
709 GT -> balanceR ky y l (go f kx x r)
710 EQ -> Bin sy kx (f kx x y) l r
711 #if __GLASGOW_HASKELL__ >= 700
712 {-# INLINABLE insertWithKey #-}
713 #else
714 {-# INLINE insertWithKey #-}
715 #endif
716
717 -- | /O(log n)/. Combines insert operation with old value retrieval.
718 -- The expression (@'insertLookupWithKey' f k x map@)
719 -- is a pair where the first element is equal to (@'lookup' k map@)
720 -- and the second element equal to (@'insertWithKey' f k x map@).
721 --
722 -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
723 -- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])
724 -- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])
725 -- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")
726 --
727 -- This is how to define @insertLookup@ using @insertLookupWithKey@:
728 --
729 -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t
730 -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])
731 -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])
732
733 -- See Note: Type of local 'go' function
734 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a
735 -> (Maybe a, Map k a)
736 insertLookupWithKey = go
737 where
738 go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
739 STRICT_2_OF_4(go)
740 go _ kx x Tip = (Nothing, singleton kx x)
741 go f kx x (Bin sy ky y l r) =
742 case compare kx ky of
743 LT -> let (found, l') = go f kx x l
744 in (found, balanceL ky y l' r)
745 GT -> let (found, r') = go f kx x r
746 in (found, balanceR ky y l r')
747 EQ -> (Just y, Bin sy kx (f kx x y) l r)
748 #if __GLASGOW_HASKELL__ >= 700
749 {-# INLINABLE insertLookupWithKey #-}
750 #else
751 {-# INLINE insertLookupWithKey #-}
752 #endif
753
754 {--------------------------------------------------------------------
755 Deletion
756 --------------------------------------------------------------------}
757 -- | /O(log n)/. Delete a key and its value from the map. When the key is not
758 -- a member of the map, the original map is returned.
759 --
760 -- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
761 -- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
762 -- > delete 5 empty == empty
763
764 -- See Note: Type of local 'go' function
765 delete :: Ord k => k -> Map k a -> Map k a
766 delete = go
767 where
768 go :: Ord k => k -> Map k a -> Map k a
769 STRICT_1_OF_2(go)
770 go _ Tip = Tip
771 go k (Bin _ kx x l r) =
772 case compare k kx of
773 LT -> balanceR kx x (go k l) r
774 GT -> balanceL kx x l (go k r)
775 EQ -> glue l r
776 #if __GLASGOW_HASKELL__ >= 700
777 {-# INLINABLE delete #-}
778 #else
779 {-# INLINE delete #-}
780 #endif
781
782 -- | /O(log n)/. Update a value at a specific key with the result of the provided function.
783 -- When the key is not
784 -- a member of the map, the original map is returned.
785 --
786 -- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
787 -- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
788 -- > adjust ("new " ++) 7 empty == empty
789
790 adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
791 adjust f = adjustWithKey (\_ x -> f x)
792 #if __GLASGOW_HASKELL__ >= 700
793 {-# INLINABLE adjust #-}
794 #else
795 {-# INLINE adjust #-}
796 #endif
797
798 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
799 -- a member of the map, the original map is returned.
800 --
801 -- > let f key x = (show key) ++ ":new " ++ x
802 -- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
803 -- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
804 -- > adjustWithKey f 7 empty == empty
805
806 adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
807 adjustWithKey f = updateWithKey (\k' x' -> Just (f k' x'))
808 #if __GLASGOW_HASKELL__ >= 700
809 {-# INLINABLE adjustWithKey #-}
810 #else
811 {-# INLINE adjustWithKey #-}
812 #endif
813
814 -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
815 -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
816 -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
817 --
818 -- > let f x = if x == "a" then Just "new a" else Nothing
819 -- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
820 -- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
821 -- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
822
823 update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
824 update f = updateWithKey (\_ x -> f x)
825 #if __GLASGOW_HASKELL__ >= 700
826 {-# INLINABLE update #-}
827 #else
828 {-# INLINE update #-}
829 #endif
830
831 -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
832 -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
833 -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
834 -- to the new value @y@.
835 --
836 -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
837 -- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
838 -- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
839 -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
840
841 -- See Note: Type of local 'go' function
842 updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
843 updateWithKey = go
844 where
845 go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
846 STRICT_2_OF_3(go)
847 go _ _ Tip = Tip
848 go f k(Bin sx kx x l r) =
849 case compare k kx of
850 LT -> balanceR kx x (go f k l) r
851 GT -> balanceL kx x l (go f k r)
852 EQ -> case f kx x of
853 Just x' -> Bin sx kx x' l r
854 Nothing -> glue l r
855 #if __GLASGOW_HASKELL__ >= 700
856 {-# INLINABLE updateWithKey #-}
857 #else
858 {-# INLINE updateWithKey #-}
859 #endif
860
861 -- | /O(log n)/. Lookup and update. See also 'updateWithKey'.
862 -- The function returns changed value, if it is updated.
863 -- Returns the original key value if the map entry is deleted.
864 --
865 -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
866 -- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])
867 -- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])
868 -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
869
870 -- See Note: Type of local 'go' function
871 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
872 updateLookupWithKey = go
873 where
874 go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
875 STRICT_2_OF_3(go)
876 go _ _ Tip = (Nothing,Tip)
877 go f k (Bin sx kx x l r) =
878 case compare k kx of
879 LT -> let (found,l') = go f k l in (found,balanceR kx x l' r)
880 GT -> let (found,r') = go f k r in (found,balanceL kx x l r')
881 EQ -> case f kx x of
882 Just x' -> (Just x',Bin sx kx x' l r)
883 Nothing -> (Just x,glue l r)
884 #if __GLASGOW_HASKELL__ >= 700
885 {-# INLINABLE updateLookupWithKey #-}
886 #else
887 {-# INLINE updateLookupWithKey #-}
888 #endif
889
890 -- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
891 -- 'alter' can be used to insert, delete, or update a value in a 'Map'.
892 -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.
893 --
894 -- > let f _ = Nothing
895 -- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
896 -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
897 -- >
898 -- > let f _ = Just "c"
899 -- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]
900 -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]
901
902 -- See Note: Type of local 'go' function
903 alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
904 alter = go
905 where
906 go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
907 STRICT_2_OF_3(go)
908 go f k Tip = case f Nothing of
909 Nothing -> Tip
910 Just x -> singleton k x
911
912 go f k (Bin sx kx x l r) = case compare k kx of
913 LT -> balance kx x (go f k l) r
914 GT -> balance kx x l (go f k r)
915 EQ -> case f (Just x) of
916 Just x' -> Bin sx kx x' l r
917 Nothing -> glue l r
918 #if __GLASGOW_HASKELL__ >= 700
919 {-# INLINABLE alter #-}
920 #else
921 {-# INLINE alter #-}
922 #endif
923
924 {--------------------------------------------------------------------
925 Indexing
926 --------------------------------------------------------------------}
927 -- | /O(log n)/. Return the /index/ of a key, which is its zero-based index in
928 -- the sequence sorted by keys. The index is a number from /0/ up to, but not
929 -- including, the 'size' of the map. Calls 'error' when the key is not
930 -- a 'member' of the map.
931 --
932 -- > findIndex 2 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map
933 -- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0
934 -- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1
935 -- > findIndex 6 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map
936
937 -- See Note: Type of local 'go' function
938 findIndex :: Ord k => k -> Map k a -> Int
939 findIndex = go 0
940 where
941 go :: Ord k => Int -> k -> Map k a -> Int
942 STRICT_1_OF_3(go)
943 STRICT_2_OF_3(go)
944 go _ _ Tip = error "Map.findIndex: element is not in the map"
945 go idx k (Bin _ kx _ l r) = case compare k kx of
946 LT -> go idx k l
947 GT -> go (idx + size l + 1) k r
948 EQ -> idx + size l
949 #if __GLASGOW_HASKELL__ >= 700
950 {-# INLINABLE findIndex #-}
951 #endif
952
953 -- | /O(log n)/. Lookup the /index/ of a key, which is its zero-based index in
954 -- the sequence sorted by keys. The index is a number from /0/ up to, but not
955 -- including, the 'size' of the map.
956 --
957 -- > isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")])) == False
958 -- > fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) == 0
959 -- > fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) == 1
960 -- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")])) == False
961
962 -- See Note: Type of local 'go' function
963 lookupIndex :: Ord k => k -> Map k a -> Maybe Int
964 lookupIndex = go 0
965 where
966 go :: Ord k => Int -> k -> Map k a -> Maybe Int
967 STRICT_1_OF_3(go)
968 STRICT_2_OF_3(go)
969 go _ _ Tip = Nothing
970 go idx k (Bin _ kx _ l r) = case compare k kx of
971 LT -> go idx k l
972 GT -> go (idx + size l + 1) k r
973 EQ -> Just $! idx + size l
974 #if __GLASGOW_HASKELL__ >= 700
975 {-# INLINABLE lookupIndex #-}
976 #endif
977
978 -- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based
979 -- index in the sequence sorted by keys. If the /index/ is out of range (less
980 -- than zero, greater or equal to 'size' of the map), 'error' is called.
981 --
982 -- > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b")
983 -- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a")
984 -- > elemAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
985
986 elemAt :: Int -> Map k a -> (k,a)
987 STRICT_1_OF_2(elemAt)
988 elemAt _ Tip = error "Map.elemAt: index out of range"
989 elemAt i (Bin _ kx x l r)
990 = case compare i sizeL of
991 LT -> elemAt i l
992 GT -> elemAt (i-sizeL-1) r
993 EQ -> (kx,x)
994 where
995 sizeL = size l
996
997 -- | /O(log n)/. Update the element at /index/, i.e. by its zero-based index in
998 -- the sequence sorted by keys. If the /index/ is out of range (less than zero,
999 -- greater or equal to 'size' of the map), 'error' is called.
1000 --
1001 -- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]
1002 -- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]
1003 -- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
1004 -- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range
1005 -- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
1006 -- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
1007 -- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
1008 -- > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range
1009
1010 updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
1011 updateAt f i t = i `seq`
1012 case t of
1013 Tip -> error "Map.updateAt: index out of range"
1014 Bin sx kx x l r -> case compare i sizeL of
1015 LT -> balanceR kx x (updateAt f i l) r
1016 GT -> balanceL kx x l (updateAt f (i-sizeL-1) r)
1017 EQ -> case f kx x of
1018 Just x' -> Bin sx kx x' l r
1019 Nothing -> glue l r
1020 where
1021 sizeL = size l
1022
1023 -- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in
1024 -- the sequence sorted by keys. If the /index/ is out of range (less than zero,
1025 -- greater or equal to 'size' of the map), 'error' is called.
1026 --
1027 -- > deleteAt 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
1028 -- > deleteAt 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
1029 -- > deleteAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
1030 -- > deleteAt (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range
1031
1032 deleteAt :: Int -> Map k a -> Map k a
1033 deleteAt i t = i `seq`
1034 case t of
1035 Tip -> error "Map.deleteAt: index out of range"
1036 Bin _ kx x l r -> case compare i sizeL of
1037 LT -> balanceR kx x (deleteAt i l) r
1038 GT -> balanceL kx x l (deleteAt (i-sizeL-1) r)
1039 EQ -> glue l r
1040 where
1041 sizeL = size l
1042
1043
1044 {--------------------------------------------------------------------
1045 Minimal, Maximal
1046 --------------------------------------------------------------------}
1047 -- | /O(log n)/. The minimal key of the map. Calls 'error' if the map is empty.
1048 --
1049 -- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")
1050 -- > findMin empty Error: empty map has no minimal element
1051
1052 findMin :: Map k a -> (k,a)
1053 findMin (Bin _ kx x Tip _) = (kx,x)
1054 findMin (Bin _ _ _ l _) = findMin l
1055 findMin Tip = error "Map.findMin: empty map has no minimal element"
1056
1057 -- | /O(log n)/. The maximal key of the map. Calls 'error' if the map is empty.
1058 --
1059 -- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")
1060 -- > findMax empty Error: empty map has no maximal element
1061
1062 findMax :: Map k a -> (k,a)
1063 findMax (Bin _ kx x _ Tip) = (kx,x)
1064 findMax (Bin _ _ _ _ r) = findMax r
1065 findMax Tip = error "Map.findMax: empty map has no maximal element"
1066
1067 -- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty.
1068 --
1069 -- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]
1070 -- > deleteMin empty == empty
1071
1072 deleteMin :: Map k a -> Map k a
1073 deleteMin (Bin _ _ _ Tip r) = r
1074 deleteMin (Bin _ kx x l r) = balanceR kx x (deleteMin l) r
1075 deleteMin Tip = Tip
1076
1077 -- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty.
1078 --
1079 -- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]
1080 -- > deleteMax empty == empty
1081
1082 deleteMax :: Map k a -> Map k a
1083 deleteMax (Bin _ _ _ l Tip) = l
1084 deleteMax (Bin _ kx x l r) = balanceL kx x l (deleteMax r)
1085 deleteMax Tip = Tip
1086
1087 -- | /O(log n)/. Update the value at the minimal key.
1088 --
1089 -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]
1090 -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
1091
1092 updateMin :: (a -> Maybe a) -> Map k a -> Map k a
1093 updateMin f m
1094 = updateMinWithKey (\_ x -> f x) m
1095
1096 -- | /O(log n)/. Update the value at the maximal key.
1097 --
1098 -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]
1099 -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
1100
1101 updateMax :: (a -> Maybe a) -> Map k a -> Map k a
1102 updateMax f m
1103 = updateMaxWithKey (\_ x -> f x) m
1104
1105
1106 -- | /O(log n)/. Update the value at the minimal key.
1107 --
1108 -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]
1109 -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
1110
1111 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
1112 updateMinWithKey _ Tip = Tip
1113 updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of
1114 Nothing -> r
1115 Just x' -> Bin sx kx x' Tip r
1116 updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r
1117
1118 -- | /O(log n)/. Update the value at the maximal key.
1119 --
1120 -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]
1121 -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
1122
1123 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
1124 updateMaxWithKey _ Tip = Tip
1125 updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of
1126 Nothing -> l
1127 Just x' -> Bin sx kx x' l Tip
1128 updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r)
1129
1130 -- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and
1131 -- the map stripped of that element, or 'Nothing' if passed an empty map.
1132 --
1133 -- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")
1134 -- > minViewWithKey empty == Nothing
1135
1136 minViewWithKey :: Map k a -> Maybe ((k,a), Map k a)
1137 minViewWithKey Tip = Nothing
1138 minViewWithKey x = Just (deleteFindMin x)
1139
1140 -- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and
1141 -- the map stripped of that element, or 'Nothing' if passed an empty map.
1142 --
1143 -- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")
1144 -- > maxViewWithKey empty == Nothing
1145
1146 maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a)
1147 maxViewWithKey Tip = Nothing
1148 maxViewWithKey x = Just (deleteFindMax x)
1149
1150 -- | /O(log n)/. Retrieves the value associated with minimal key of the
1151 -- map, and the map stripped of that element, or 'Nothing' if passed an
1152 -- empty map.
1153 --
1154 -- > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")
1155 -- > minView empty == Nothing
1156
1157 minView :: Map k a -> Maybe (a, Map k a)
1158 minView Tip = Nothing
1159 minView x = Just (first snd $ deleteFindMin x)
1160
1161 -- | /O(log n)/. Retrieves the value associated with maximal key of the
1162 -- map, and the map stripped of that element, or 'Nothing' if passed an
1163 --
1164 -- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")
1165 -- > maxView empty == Nothing
1166
1167 maxView :: Map k a -> Maybe (a, Map k a)
1168 maxView Tip = Nothing
1169 maxView x = Just (first snd $ deleteFindMax x)
1170
1171 -- Update the 1st component of a tuple (special case of Control.Arrow.first)
1172 first :: (a -> b) -> (a,c) -> (b,c)
1173 first f (x,y) = (f x, y)
1174
1175 {--------------------------------------------------------------------
1176 Union.
1177 --------------------------------------------------------------------}
1178 -- | The union of a list of maps:
1179 -- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
1180 --
1181 -- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
1182 -- > == fromList [(3, "b"), (5, "a"), (7, "C")]
1183 -- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]
1184 -- > == fromList [(3, "B3"), (5, "A3"), (7, "C")]
1185
1186 unions :: Ord k => [Map k a] -> Map k a
1187 unions ts
1188 = foldlStrict union empty ts
1189 #if __GLASGOW_HASKELL__ >= 700
1190 {-# INLINABLE unions #-}
1191 #endif
1192
1193 -- | The union of a list of maps, with a combining operation:
1194 -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
1195 --
1196 -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
1197 -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]
1198
1199 unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
1200 unionsWith f ts
1201 = foldlStrict (unionWith f) empty ts
1202 #if __GLASGOW_HASKELL__ >= 700
1203 {-# INLINABLE unionsWith #-}
1204 #endif
1205
1206 -- | /O(n+m)/.
1207 -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
1208 -- It prefers @t1@ when duplicate keys are encountered,
1209 -- i.e. (@'union' == 'unionWith' 'const'@).
1210 -- The implementation uses the efficient /hedge-union/ algorithm.
1211 --
1212 -- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]
1213
1214 union :: Ord k => Map k a -> Map k a -> Map k a
1215 union Tip t2 = t2
1216 union t1 Tip = t1
1217 union t1 t2 = hedgeUnion NothingS NothingS t1 t2
1218 #if __GLASGOW_HASKELL__ >= 700
1219 {-# INLINABLE union #-}
1220 #endif
1221
1222 -- left-biased hedge union
1223 hedgeUnion :: Ord a => MaybeS a -> MaybeS a -> Map a b -> Map a b -> Map a b
1224 hedgeUnion _ _ t1 Tip = t1
1225 hedgeUnion blo bhi Tip (Bin _ kx x l r) = link kx x (filterGt blo l) (filterLt bhi r)
1226 hedgeUnion _ _ t1 (Bin _ kx x Tip Tip) = insertR kx x t1 -- According to benchmarks, this special case increases
1227 -- performance up to 30%. It does not help in difference or intersection.
1228 hedgeUnion blo bhi (Bin _ kx x l r) t2 = link kx x (hedgeUnion blo bmi l (trim blo bmi t2))
1229 (hedgeUnion bmi bhi r (trim bmi bhi t2))
1230 where bmi = JustS kx
1231 #if __GLASGOW_HASKELL__ >= 700
1232 {-# INLINABLE hedgeUnion #-}
1233 #endif
1234
1235 {--------------------------------------------------------------------
1236 Union with a combining function
1237 --------------------------------------------------------------------}
1238 -- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
1239 --
1240 -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]
1241
1242 unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
1243 unionWith f m1 m2
1244 = unionWithKey (\_ x y -> f x y) m1 m2
1245 #if __GLASGOW_HASKELL__ >= 700
1246 {-# INLINABLE unionWith #-}
1247 #endif
1248
1249 -- | /O(n+m)/.
1250 -- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
1251 --
1252 -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value
1253 -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
1254
1255 unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
1256 unionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just $ f k x1 x2) id id t1 t2
1257 #if __GLASGOW_HASKELL__ >= 700
1258 {-# INLINABLE unionWithKey #-}
1259 #endif
1260
1261 {--------------------------------------------------------------------
1262 Difference
1263 --------------------------------------------------------------------}
1264 -- | /O(n+m)/. Difference of two maps.
1265 -- Return elements of the first map not existing in the second map.
1266 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
1267 --
1268 -- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"
1269
1270 difference :: Ord k => Map k a -> Map k b -> Map k a
1271 difference Tip _ = Tip
1272 difference t1 Tip = t1
1273 difference t1 t2 = hedgeDiff NothingS NothingS t1 t2
1274 #if __GLASGOW_HASKELL__ >= 700
1275 {-# INLINABLE difference #-}
1276 #endif
1277
1278 hedgeDiff :: Ord a => MaybeS a -> MaybeS a -> Map a b -> Map a c -> Map a b
1279 hedgeDiff _ _ Tip _ = Tip
1280 hedgeDiff blo bhi (Bin _ kx x l r) Tip = link kx x (filterGt blo l) (filterLt bhi r)
1281 hedgeDiff blo bhi t (Bin _ kx _ l r) = merge (hedgeDiff blo bmi (trim blo bmi t) l)
1282 (hedgeDiff bmi bhi (trim bmi bhi t) r)
1283 where bmi = JustS kx
1284 #if __GLASGOW_HASKELL__ >= 700
1285 {-# INLINABLE hedgeDiff #-}
1286 #endif
1287
1288 -- | /O(n+m)/. Difference with a combining function.
1289 -- When two equal keys are
1290 -- encountered, the combining function is applied to the values of these keys.
1291 -- If it returns 'Nothing', the element is discarded (proper set difference). If
1292 -- it returns (@'Just' y@), the element is updated with a new value @y@.
1293 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
1294 --
1295 -- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing
1296 -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])
1297 -- > == singleton 3 "b:B"
1298
1299 differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
1300 differenceWith f m1 m2
1301 = differenceWithKey (\_ x y -> f x y) m1 m2
1302 #if __GLASGOW_HASKELL__ >= 700
1303 {-# INLINABLE differenceWith #-}
1304 #endif
1305
1306 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
1307 -- encountered, the combining function is applied to the key and both values.
1308 -- If it returns 'Nothing', the element is discarded (proper set difference). If
1309 -- it returns (@'Just' y@), the element is updated with a new value @y@.
1310 -- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
1311 --
1312 -- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing
1313 -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])
1314 -- > == singleton 3 "3:b|B"
1315
1316 differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
1317 differenceWithKey f t1 t2 = mergeWithKey f id (const Tip) t1 t2
1318 #if __GLASGOW_HASKELL__ >= 700
1319 {-# INLINABLE differenceWithKey #-}
1320 #endif
1321
1322
1323 {--------------------------------------------------------------------
1324 Intersection
1325 --------------------------------------------------------------------}
1326 -- | /O(n+m)/. Intersection of two maps.
1327 -- Return data in the first map for the keys existing in both maps.
1328 -- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
1329 -- The implementation uses an efficient /hedge/ algorithm comparable with
1330 -- /hedge-union/.
1331 --
1332 -- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"
1333
1334 intersection :: Ord k => Map k a -> Map k b -> Map k a
1335 intersection Tip _ = Tip
1336 intersection _ Tip = Tip
1337 intersection t1 t2 = hedgeInt NothingS NothingS t1 t2
1338 #if __GLASGOW_HASKELL__ >= 700
1339 {-# INLINABLE intersection #-}
1340 #endif
1341
1342 hedgeInt :: Ord k => MaybeS k -> MaybeS k -> Map k a -> Map k b -> Map k a
1343 hedgeInt _ _ _ Tip = Tip
1344 hedgeInt _ _ Tip _ = Tip
1345 hedgeInt blo bhi (Bin _ kx x l r) t2 = let l' = hedgeInt blo bmi l (trim blo bmi t2)
1346 r' = hedgeInt bmi bhi r (trim bmi bhi t2)
1347 in if kx `member` t2 then link kx x l' r' else merge l' r'
1348 where bmi = JustS kx
1349 #if __GLASGOW_HASKELL__ >= 700
1350 {-# INLINABLE hedgeInt #-}
1351 #endif
1352
1353 -- | /O(n+m)/. Intersection with a combining function. The implementation uses
1354 -- an efficient /hedge/ algorithm comparable with /hedge-union/.
1355 --
1356 -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
1357
1358 intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
1359 intersectionWith f m1 m2
1360 = intersectionWithKey (\_ x y -> f x y) m1 m2
1361 #if __GLASGOW_HASKELL__ >= 700
1362 {-# INLINABLE intersectionWith #-}
1363 #endif
1364
1365 -- | /O(n+m)/. Intersection with a combining function. The implementation uses
1366 -- an efficient /hedge/ algorithm comparable with /hedge-union/.
1367 --
1368 -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar
1369 -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"
1370
1371
1372 intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
1373 intersectionWithKey f t1 t2 = mergeWithKey (\k x1 x2 -> Just $ f k x1 x2) (const Tip) (const Tip) t1 t2
1374 #if __GLASGOW_HASKELL__ >= 700
1375 {-# INLINABLE intersectionWithKey #-}
1376 #endif
1377
1378
1379 {--------------------------------------------------------------------
1380 MergeWithKey
1381 --------------------------------------------------------------------}
1382
1383 -- | /O(n+m)/. A high-performance universal combining function. This function
1384 -- is used to define 'unionWith', 'unionWithKey', 'differenceWith',
1385 -- 'differenceWithKey', 'intersectionWith', 'intersectionWithKey' and can be
1386 -- used to define other custom combine functions.
1387 --
1388 -- Please make sure you know what is going on when using 'mergeWithKey',
1389 -- otherwise you can be surprised by unexpected code growth or even
1390 -- corruption of the data structure.
1391 --
1392 -- When 'mergeWithKey' is given three arguments, it is inlined to the call
1393 -- site. You should therefore use 'mergeWithKey' only to define your custom
1394 -- combining functions. For example, you could define 'unionWithKey',
1395 -- 'differenceWithKey' and 'intersectionWithKey' as
1396 --
1397 -- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2
1398 -- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2
1399 -- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2
1400 --
1401 -- When calling @'mergeWithKey' combine only1 only2@, a function combining two
1402 -- 'IntMap's is created, such that
1403 --
1404 -- * if a key is present in both maps, it is passed with both corresponding
1405 -- values to the @combine@ function. Depending on the result, the key is either
1406 -- present in the result with specified value, or is left out;
1407 --
1408 -- * a nonempty subtree present only in the first map is passed to @only1@ and
1409 -- the output is added to the result;
1410 --
1411 -- * a nonempty subtree present only in the second map is passed to @only2@ and
1412 -- the output is added to the result.
1413 --
1414 -- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.
1415 -- The values can be modified arbitrarily. Most common variants of @only1@ and
1416 -- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or
1417 -- @'filterWithKey' f@ could be used for any @f@.
1418
1419 mergeWithKey :: Ord k => (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c)
1420 -> Map k a -> Map k b -> Map k c
1421 mergeWithKey f g1 g2 = go
1422 where
1423 go Tip t2 = g2 t2
1424 go t1 Tip = g1 t1
1425 go t1 t2 = hedgeMerge NothingS NothingS t1 t2
1426
1427 hedgeMerge _ _ t1 Tip = g1 t1
1428 hedgeMerge blo bhi Tip (Bin _ kx x l r) = g2 $ link kx x (filterGt blo l) (filterLt bhi r)
1429 hedgeMerge blo bhi (Bin _ kx x l r) t2 = let l' = hedgeMerge blo bmi l (trim blo bmi t2)
1430 (found, trim_t2) = trimLookupLo kx bhi t2
1431 r' = hedgeMerge bmi bhi r trim_t2
1432 in case found of
1433 Nothing -> case g1 (singleton kx x) of
1434 Tip -> merge l' r'
1435 (Bin _ _ x' Tip Tip) -> link kx x' l' r'
1436 _ -> error "mergeWithKey: Given function only1 does not fulfil required conditions (see documentation)"
1437 Just x2 -> case f kx x x2 of
1438 Nothing -> merge l' r'
1439 Just x' -> link kx x' l' r'
1440 where bmi = JustS kx
1441 {-# INLINE mergeWithKey #-}
1442
1443 {--------------------------------------------------------------------
1444 Submap
1445 --------------------------------------------------------------------}
1446 -- | /O(n+m)/.
1447 -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
1448 --
1449 isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
1450 isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2
1451 #if __GLASGOW_HASKELL__ >= 700
1452 {-# INLINABLE isSubmapOf #-}
1453 #endif
1454
1455 {- | /O(n+m)/.
1456 The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
1457 all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
1458 applied to their respective values. For example, the following
1459 expressions are all 'True':
1460
1461 > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
1462 > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
1463 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
1464
1465 But the following are all 'False':
1466
1467 > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
1468 > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
1469 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
1470
1471
1472 -}
1473 isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
1474 isSubmapOfBy f t1 t2
1475 = (size t1 <= size t2) && (submap' f t1 t2)
1476 #if __GLASGOW_HASKELL__ >= 700
1477 {-# INLINABLE isSubmapOfBy #-}
1478 #endif
1479
1480 submap' :: Ord a => (b -> c -> Bool) -> Map a b -> Map a c -> Bool
1481 submap' _ Tip _ = True
1482 submap' _ _ Tip = False
1483 submap' f (Bin _ kx x l r) t
1484 = case found of
1485 Nothing -> False
1486 Just y -> f x y && submap' f l lt && submap' f r gt
1487 where
1488 (lt,found,gt) = splitLookup kx t
1489 #if __GLASGOW_HASKELL__ >= 700
1490 {-# INLINABLE submap' #-}
1491 #endif
1492
1493 -- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
1494 -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
1495 isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
1496 isProperSubmapOf m1 m2
1497 = isProperSubmapOfBy (==) m1 m2
1498 #if __GLASGOW_HASKELL__ >= 700
1499 {-# INLINABLE isProperSubmapOf #-}
1500 #endif
1501
1502 {- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
1503 The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
1504 @m1@ and @m2@ are not equal,
1505 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
1506 applied to their respective values. For example, the following
1507 expressions are all 'True':
1508
1509 > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
1510 > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
1511
1512 But the following are all 'False':
1513
1514 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
1515 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
1516 > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
1517
1518
1519 -}
1520 isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
1521 isProperSubmapOfBy f t1 t2
1522 = (size t1 < size t2) && (submap' f t1 t2)
1523 #if __GLASGOW_HASKELL__ >= 700
1524 {-# INLINABLE isProperSubmapOfBy #-}
1525 #endif
1526
1527 {--------------------------------------------------------------------
1528 Filter and partition
1529 --------------------------------------------------------------------}
1530 -- | /O(n)/. Filter all values that satisfy the predicate.
1531 --
1532 -- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
1533 -- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty
1534 -- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty
1535
1536 filter :: (a -> Bool) -> Map k a -> Map k a
1537 filter p m
1538 = filterWithKey (\_ x -> p x) m
1539
1540 -- | /O(n)/. Filter all keys\/values that satisfy the predicate.
1541 --
1542 -- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
1543
1544 filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a
1545 filterWithKey _ Tip = Tip
1546 filterWithKey p (Bin _ kx x l r)
1547 | p kx x = link kx x (filterWithKey p l) (filterWithKey p r)
1548 | otherwise = merge (filterWithKey p l) (filterWithKey p r)
1549
1550 -- | /O(n)/. Partition the map according to a predicate. The first
1551 -- map contains all elements that satisfy the predicate, the second all
1552 -- elements that fail the predicate. See also 'split'.
1553 --
1554 -- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
1555 -- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
1556 -- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
1557
1558 partition :: (a -> Bool) -> Map k a -> (Map k a,Map k a)
1559 partition p m
1560 = partitionWithKey (\_ x -> p x) m
1561
1562 -- | /O(n)/. Partition the map according to a predicate. The first
1563 -- map contains all elements that satisfy the predicate, the second all
1564 -- elements that fail the predicate. See also 'split'.
1565 --
1566 -- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")
1567 -- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
1568 -- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
1569
1570 partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
1571 partitionWithKey p0 t0 = toPair $ go p0 t0
1572 where
1573 go _ Tip = (Tip :*: Tip)
1574 go p (Bin _ kx x l r)
1575 | p kx x = link kx x l1 r1 :*: merge l2 r2
1576 | otherwise = merge l1 r1 :*: link kx x l2 r2
1577 where
1578 (l1 :*: l2) = go p l
1579 (r1 :*: r2) = go p r
1580
1581 -- | /O(n)/. Map values and collect the 'Just' results.
1582 --
1583 -- > let f x = if x == "a" then Just "new a" else Nothing
1584 -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"
1585
1586 mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b
1587 mapMaybe f = mapMaybeWithKey (\_ x -> f x)
1588
1589 -- | /O(n)/. Map keys\/values and collect the 'Just' results.
1590 --
1591 -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing
1592 -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"
1593
1594 mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b
1595 mapMaybeWithKey _ Tip = Tip
1596 mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of
1597 Just y -> link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)
1598 Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r)
1599
1600 -- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
1601 --
1602 -- > let f a = if a < "c" then Left a else Right a
1603 -- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1604 -- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])
1605 -- >
1606 -- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1607 -- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1608
1609 mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)
1610 mapEither f m
1611 = mapEitherWithKey (\_ x -> f x) m
1612
1613 -- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
1614 --
1615 -- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)
1616 -- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1617 -- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])
1618 -- >
1619 -- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1620 -- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
1621
1622 mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)
1623 mapEitherWithKey f0 t0 = toPair $ go f0 t0
1624 where
1625 go _ Tip = (Tip :*: Tip)
1626 go f (Bin _ kx x l r) = case f kx x of
1627 Left y -> link kx y l1 r1 :*: merge l2 r2
1628 Right z -> merge l1 r1 :*: link kx z l2 r2
1629 where
1630 (l1 :*: l2) = go f l
1631 (r1 :*: r2) = go f r
1632
1633 {--------------------------------------------------------------------
1634 Mapping
1635 --------------------------------------------------------------------}
1636 -- | /O(n)/. Map a function over all values in the map.
1637 --
1638 -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
1639
1640 map :: (a -> b) -> Map k a -> Map k b
1641 map _ Tip = Tip
1642 map f (Bin sx kx x l r) = Bin sx kx (f x) (map f l) (map f r)
1643
1644 -- | /O(n)/. Map a function over all values in the map.
1645 --
1646 -- > let f key x = (show key) ++ ":" ++ x
1647 -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
1648
1649 mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
1650 mapWithKey _ Tip = Tip
1651 mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
1652
1653 -- | /O(n)/.
1654 -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@
1655 -- That is, behaves exactly like a regular 'traverse' except that the traversing
1656 -- function also has access to the key associated with a value.
1657 --
1658 -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])
1659 -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing
1660 traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b)
1661 traverseWithKey f = go
1662 where
1663 go Tip = pure Tip
1664 go (Bin 1 k v _ _) = (\v' -> Bin 1 k v' Tip Tip) <$> f k v
1665 go (Bin s k v l r) = flip (Bin s k) <$> go l <*> f k v <*> go r
1666 {-# INLINE traverseWithKey #-}
1667
1668 -- | /O(n)/. The function 'mapAccum' threads an accumulating
1669 -- argument through the map in ascending order of keys.
1670 --
1671 -- > let f a b = (a ++ b, b ++ "X")
1672 -- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])
1673
1674 mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
1675 mapAccum f a m
1676 = mapAccumWithKey (\a' _ x' -> f a' x') a m
1677
1678 -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
1679 -- argument through the map in ascending order of keys.
1680 --
1681 -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")
1682 -- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])
1683
1684 mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
1685 mapAccumWithKey f a t
1686 = mapAccumL f a t
1687
1688 -- | /O(n)/. The function 'mapAccumL' threads an accumulating
1689 -- argument through the map in ascending order of keys.
1690 mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
1691 mapAccumL _ a Tip = (a,Tip)
1692 mapAccumL f a (Bin sx kx x l r) =
1693 let (a1,l') = mapAccumL f a l
1694 (a2,x') = f a1 kx x
1695 (a3,r') = mapAccumL f a2 r
1696 in (a3,Bin sx kx x' l' r')
1697
1698 -- | /O(n)/. The function 'mapAccumR' threads an accumulating
1699 -- argument through the map in descending order of keys.
1700 mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
1701 mapAccumRWithKey _ a Tip = (a,Tip)
1702 mapAccumRWithKey f a (Bin sx kx x l r) =
1703 let (a1,r') = mapAccumRWithKey f a r
1704 (a2,x') = f a1 kx x
1705 (a3,l') = mapAccumRWithKey f a2 l
1706 in (a3,Bin sx kx x' l' r')
1707
1708 -- | /O(n*log n)/.
1709 -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
1710 --
1711 -- The size of the result may be smaller if @f@ maps two or more distinct
1712 -- keys to the same new key. In this case the value at the greatest of the
1713 -- original keys is retained.
1714 --
1715 -- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")]
1716 -- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"
1717 -- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"
1718
1719 mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
1720 mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []
1721 #if __GLASGOW_HASKELL__ >= 700
1722 {-# INLINABLE mapKeys #-}
1723 #endif
1724
1725 -- | /O(n*log n)/.
1726 -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
1727 --
1728 -- The size of the result may be smaller if @f@ maps two or more distinct
1729 -- keys to the same new key. In this case the associated values will be
1730 -- combined using @c@.
1731 --
1732 -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"
1733 -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"
1734
1735 mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
1736 mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []
1737 #if __GLASGOW_HASKELL__ >= 700
1738 {-# INLINABLE mapKeysWith #-}
1739 #endif
1740
1741
1742 -- | /O(n)/.
1743 -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
1744 -- is strictly monotonic.
1745 -- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.
1746 -- /The precondition is not checked./
1747 -- Semi-formally, we have:
1748 --
1749 -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
1750 -- > ==> mapKeysMonotonic f s == mapKeys f s
1751 -- > where ls = keys s
1752 --
1753 -- This means that @f@ maps distinct original keys to distinct resulting keys.
1754 -- This function has better performance than 'mapKeys'.
1755 --
1756 -- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]
1757 -- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True
1758 -- > valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) == False
1759
1760 mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
1761 mapKeysMonotonic _ Tip = Tip
1762 mapKeysMonotonic f (Bin sz k x l r) =
1763 Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
1764
1765 {--------------------------------------------------------------------
1766 Folds
1767 --------------------------------------------------------------------}
1768
1769 -- | /O(n)/. Fold the values in the map using the given right-associative
1770 -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.
1771 --
1772 -- For example,
1773 --
1774 -- > elems map = foldr (:) [] map
1775 --
1776 -- > let f a len = len + (length a)
1777 -- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4
1778 foldr :: (a -> b -> b) -> b -> Map k a -> b
1779 foldr f z = go z
1780 where
1781 go z' Tip = z'
1782 go z' (Bin _ _ x l r) = go (f x (go z' r)) l
1783 {-# INLINE foldr #-}
1784
1785 -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is
1786 -- evaluated before using the result in the next application. This
1787 -- function is strict in the starting value.
1788 foldr' :: (a -> b -> b) -> b -> Map k a -> b
1789 foldr' f z = go z
1790 where
1791 STRICT_1_OF_2(go)
1792 go z' Tip = z'
1793 go z' (Bin _ _ x l r) = go (f x (go z' r)) l
1794 {-# INLINE foldr' #-}
1795
1796 -- | /O(n)/. Fold the values in the map using the given left-associative
1797 -- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.
1798 --
1799 -- For example,
1800 --
1801 -- > elems = reverse . foldl (flip (:)) []
1802 --
1803 -- > let f len a = len + (length a)
1804 -- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4
1805 foldl :: (a -> b -> a) -> a -> Map k b -> a
1806 foldl f z = go z
1807 where
1808 go z' Tip = z'
1809 go z' (Bin _ _ x l r) = go (f (go z' l) x) r
1810 {-# INLINE foldl #-}
1811
1812 -- | /O(n)/. A strict version of 'foldl'. Each application of the operator is
1813 -- evaluated before using the result in the next application. This
1814 -- function is strict in the starting value.
1815 foldl' :: (a -> b -> a) -> a -> Map k b -> a
1816 foldl' f z = go z
1817 where
1818 STRICT_1_OF_2(go)
1819 go z' Tip = z'
1820 go z' (Bin _ _ x l r) = go (f (go z' l) x) r
1821 {-# INLINE foldl' #-}
1822
1823 -- | /O(n)/. Fold the keys and values in the map using the given right-associative
1824 -- binary operator, such that
1825 -- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
1826 --
1827 -- For example,
1828 --
1829 -- > keys map = foldrWithKey (\k x ks -> k:ks) [] map
1830 --
1831 -- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
1832 -- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"
1833 foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
1834 foldrWithKey f z = go z
1835 where
1836 go z' Tip = z'
1837 go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l
1838 {-# INLINE foldrWithKey #-}
1839
1840 -- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is
1841 -- evaluated before using the result in the next application. This
1842 -- function is strict in the starting value.
1843 foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b
1844 foldrWithKey' f z = go z
1845 where
1846 STRICT_1_OF_2(go)
1847 go z' Tip = z'
1848 go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l
1849 {-# INLINE foldrWithKey' #-}
1850
1851 -- | /O(n)/. Fold the keys and values in the map using the given left-associative
1852 -- binary operator, such that
1853 -- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.
1854 --
1855 -- For example,
1856 --
1857 -- > keys = reverse . foldlWithKey (\ks k x -> k:ks) []
1858 --
1859 -- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
1860 -- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"
1861 foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a
1862 foldlWithKey f z = go z
1863 where
1864 go z' Tip = z'
1865 go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r
1866 {-# INLINE foldlWithKey #-}
1867
1868 -- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is
1869 -- evaluated before using the result in the next application. This
1870 -- function is strict in the starting value.
1871 foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a
1872 foldlWithKey' f z = go z
1873 where
1874 STRICT_1_OF_2(go)
1875 go z' Tip = z'
1876 go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r
1877 {-# INLINE foldlWithKey' #-}
1878
1879 -- | /O(n)/. Fold the keys and values in the map using the given monoid, such that
1880 --
1881 -- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@
1882 --
1883 -- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.
1884 foldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m
1885 foldMapWithKey f = go
1886 where
1887 go Tip = mempty
1888 go (Bin 1 k v _ _) = f k v
1889 go (Bin _ k v l r) = go l `mappend` (f k v `mappend` go r)
1890 {-# INLINE foldMapWithKey #-}
1891
1892 {--------------------------------------------------------------------
1893 List variations
1894 --------------------------------------------------------------------}
1895 -- | /O(n)/.
1896 -- Return all elements of the map in the ascending order of their keys.
1897 -- Subject to list fusion.
1898 --
1899 -- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]
1900 -- > elems empty == []
1901
1902 elems :: Map k a -> [a]
1903 elems = foldr (:) []
1904
1905 -- | /O(n)/. Return all keys of the map in ascending order. Subject to list
1906 -- fusion.
1907 --
1908 -- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]
1909 -- > keys empty == []
1910
1911 keys :: Map k a -> [k]
1912 keys = foldrWithKey (\k _ ks -> k : ks) []
1913
1914 -- | /O(n)/. An alias for 'toAscList'. Return all key\/value pairs in the map
1915 -- in ascending key order. Subject to list fusion.
1916 --
1917 -- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
1918 -- > assocs empty == []
1919
1920 assocs :: Map k a -> [(k,a)]
1921 assocs m
1922 = toAscList m
1923
1924 -- | /O(n)/. The set of all keys of the map.
1925 --
1926 -- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5]
1927 -- > keysSet empty == Data.Set.empty
1928
1929 keysSet :: Map k a -> Set.Set k
1930 keysSet Tip = Set.Tip
1931 keysSet (Bin sz kx _ l r) = Set.Bin sz kx (keysSet l) (keysSet r)
1932
1933 -- | /O(n)/. Build a map from a set of keys and a function which for each key
1934 -- computes its value.
1935 --
1936 -- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]
1937 -- > fromSet undefined Data.Set.empty == empty
1938
1939 fromSet :: (k -> a) -> Set.Set k -> Map k a
1940 fromSet _ Set.Tip = Tip
1941 fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r)
1942
1943 {--------------------------------------------------------------------
1944 Lists
1945 use [foldlStrict] to reduce demand on the control-stack
1946 --------------------------------------------------------------------}
1947 -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
1948 -- If the list contains more than one value for the same key, the last value
1949 -- for the key is retained.
1950 --
1951 -- If the keys of the list are ordered, linear-time implementation is used,
1952 -- with the performance equal to 'fromDistinctAscList'.
1953 --
1954 -- > fromList [] == empty
1955 -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
1956 -- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
1957
1958 -- For some reason, when 'singleton' is used in fromList or in
1959 -- create, it is not inlined, so we inline it manually.
1960 fromList :: Ord k => [(k,a)] -> Map k a
1961 fromList [] = Tip
1962 fromList [(kx, x)] = Bin 1 kx x Tip Tip
1963 fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = fromList' (Bin 1 kx0 x0 Tip Tip) xs0
1964 | otherwise = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
1965 where
1966 not_ordered _ [] = False
1967 not_ordered kx ((ky,_) : _) = kx >= ky
1968 {-# INLINE not_ordered #-}
1969
1970 fromList' t0 xs = foldlStrict ins t0 xs
1971 where ins t (k,x) = insert k x t
1972
1973 STRICT_1_OF_3(go)
1974 go _ t [] = t
1975 go _ t [(kx, x)] = insertMax kx x t
1976 go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs
1977 | otherwise = case create s xss of
1978 (r, ys, []) -> go (s `shiftL` 1) (link kx x l r) ys
1979 (r, _, ys) -> fromList' (link kx x l r) ys
1980
1981 -- The create is returning a triple (tree, xs, ys). Both xs and ys
1982 -- represent not yet processed elements and only one of them can be nonempty.
1983 -- If ys is nonempty, the keys in ys are not ordered with respect to tree
1984 -- and must be inserted using fromList'. Otherwise the keys have been
1985 -- ordered so far.
1986 STRICT_1_OF_2(create)
1987 create _ [] = (Tip, [], [])
1988 create s xs@(xp : xss)
1989 | s == 1 = case xp of (kx, x) | not_ordered kx xss -> (Bin 1 kx x Tip Tip, [], xss)
1990 | otherwise -> (Bin 1 kx x Tip Tip, xss, [])
1991 | otherwise = case create (s `shiftR` 1) xs of
1992 res@(_, [], _) -> res
1993 (l, [(ky, y)], zs) -> (insertMax ky y l, [], zs)
1994 (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)
1995 | otherwise -> case create (s `shiftR` 1) yss of
1996 (r, zs, ws) -> (link ky y l r, zs, ws)
1997 #if __GLASGOW_HASKELL__ >= 700
1998 {-# INLINABLE fromList #-}
1999 #endif
2000
2001 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
2002 --
2003 -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]
2004 -- > fromListWith (++) [] == empty
2005
2006 fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
2007 fromListWith f xs
2008 = fromListWithKey (\_ x y -> f x y) xs
2009 #if __GLASGOW_HASKELL__ >= 700
2010 {-# INLINABLE fromListWith #-}
2011 #endif
2012
2013 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
2014 --
2015 -- > let f k a1 a2 = (show k) ++ a1 ++ a2
2016 -- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]
2017 -- > fromListWithKey f [] == empty
2018
2019 fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
2020 fromListWithKey f xs
2021 = foldlStrict ins empty xs
2022 where
2023 ins t (k,x) = insertWithKey f k x t
2024 #if __GLASGOW_HASKELL__ >= 700
2025 {-# INLINABLE fromListWithKey #-}
2026 #endif
2027
2028 -- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list fusion.
2029 --
2030 -- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
2031 -- > toList empty == []
2032
2033 toList :: Map k a -> [(k,a)]
2034 toList = toAscList
2035
2036 -- | /O(n)/. Convert the map to a list of key\/value pairs where the keys are
2037 -- in ascending order. Subject to list fusion.
2038 --
2039 -- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
2040
2041 toAscList :: Map k a -> [(k,a)]
2042 toAscList = foldrWithKey (\k x xs -> (k,x):xs) []
2043
2044 -- | /O(n)/. Convert the map to a list of key\/value pairs where the keys
2045 -- are in descending order. Subject to list fusion.
2046 --
2047 -- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]
2048
2049 toDescList :: Map k a -> [(k,a)]
2050 toDescList = foldlWithKey (\xs k x -> (k,x):xs) []
2051
2052 -- List fusion for the list generating functions.
2053 #if __GLASGOW_HASKELL__
2054 -- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.
2055 -- They are important to convert unfused methods back, see mapFB in prelude.
2056 foldrFB :: (k -> a -> b -> b) -> b -> Map k a -> b
2057 foldrFB = foldrWithKey
2058 {-# INLINE[0] foldrFB #-}
2059 foldlFB :: (a -> k -> b -> a) -> a -> Map k b -> a
2060 foldlFB = foldlWithKey
2061 {-# INLINE[0] foldlFB #-}
2062
2063 -- Inline assocs and toList, so that we need to fuse only toAscList.
2064 {-# INLINE assocs #-}
2065 {-# INLINE toList #-}
2066
2067 -- The fusion is enabled up to phase 2 included. If it does not succeed,
2068 -- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to
2069 -- elems,keys,to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were
2070 -- used in a list fusion, otherwise it would go away in phase 1), and let compiler
2071 -- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to
2072 -- inline it before phase 0, otherwise the fusion rules would not fire at all.
2073 {-# NOINLINE[0] elems #-}
2074 {-# NOINLINE[0] keys #-}
2075 {-# NOINLINE[0] toAscList #-}
2076 {-# NOINLINE[0] toDescList #-}
2077 {-# RULES "Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}
2078 {-# RULES "Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}
2079 {-# RULES "Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}
2080 {-# RULES "Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}
2081 {-# RULES "Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}
2082 {-# RULES "Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}
2083 {-# RULES "Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}
2084 {-# RULES "Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}
2085 #endif
2086
2087 {--------------------------------------------------------------------
2088 Building trees from ascending/descending lists can be done in linear time.
2089
2090 Note that if [xs] is ascending that:
2091 fromAscList xs == fromList xs
2092 fromAscListWith f xs == fromListWith f xs
2093 --------------------------------------------------------------------}
2094 -- | /O(n)/. Build a map from an ascending list in linear time.
2095 -- /The precondition (input list is ascending) is not checked./
2096 --
2097 -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
2098 -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
2099 -- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True
2100 -- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False
2101
2102 fromAscList :: Eq k => [(k,a)] -> Map k a
2103 fromAscList xs
2104 = fromAscListWithKey (\_ x _ -> x) xs
2105 #if __GLASGOW_HASKELL__ >= 700
2106 {-# INLINABLE fromAscList #-}
2107 #endif
2108
2109 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
2110 -- /The precondition (input list is ascending) is not checked./
2111 --
2112 -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
2113 -- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True
2114 -- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False
2115
2116 fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
2117 fromAscListWith f xs
2118 = fromAscListWithKey (\_ x y -> f x y) xs
2119 #if __GLASGOW_HASKELL__ >= 700
2120 {-# INLINABLE fromAscListWith #-}
2121 #endif
2122
2123 -- | /O(n)/. Build a map from an ascending list in linear time with a
2124 -- combining function for equal keys.
2125 -- /The precondition (input list is ascending) is not checked./
2126 --
2127 -- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
2128 -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]
2129 -- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True
2130 -- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False
2131
2132 fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
2133 fromAscListWithKey f xs
2134 = fromDistinctAscList (combineEq f xs)
2135 where
2136 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
2137 combineEq _ xs'
2138 = case xs' of
2139 [] -> []
2140 [x] -> [x]
2141 (x:xx) -> combineEq' x xx
2142
2143 combineEq' z [] = [z]
2144 combineEq' z@(kz,zz) (x@(kx,xx):xs')
2145 | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs'
2146 | otherwise = z:combineEq' x xs'
2147 #if __GLASGOW_HASKELL__ >= 700
2148 {-# INLINABLE fromAscListWithKey #-}
2149 #endif
2150
2151
2152 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
2153 -- /The precondition is not checked./
2154 --
2155 -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
2156 -- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True
2157 -- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False
2158
2159 -- For some reason, when 'singleton' is used in fromDistinctAscList or in
2160 -- create, it is not inlined, so we inline it manually.
2161 fromDistinctAscList :: [(k,a)] -> Map k a
2162 fromDistinctAscList [] = Tip
2163 fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
2164 where
2165 STRICT_1_OF_3(go)
2166 go _ t [] = t
2167 go s l ((kx, x) : xs) = case create s xs of
2168 (r, ys) -> go (s `shiftL` 1) (link kx x l r) ys
2169
2170 STRICT_1_OF_2(create)
2171 create _ [] = (Tip, [])
2172 create s xs@(x' : xs')
2173 | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip, xs')
2174 | otherwise = case create (s `shiftR` 1) xs of
2175 res@(_, []) -> res
2176 (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of
2177 (r, zs) -> (link ky y l r, zs)
2178
2179
2180 {--------------------------------------------------------------------
2181 Utility functions that return sub-ranges of the original
2182 tree. Some functions take a `Maybe value` as an argument to
2183 allow comparisons against infinite values. These are called `blow`
2184 (Nothing is -\infty) and `bhigh` (here Nothing is +\infty).
2185 We use MaybeS value, which is a Maybe strict in the Just case.
2186
2187 [trim blow bhigh t] A tree that is either empty or where [x > blow]
2188 and [x < bhigh] for the value [x] of the root.
2189 [filterGt blow t] A tree where for all values [k]. [k > blow]
2190 [filterLt bhigh t] A tree where for all values [k]. [k < bhigh]
2191
2192 [split k t] Returns two trees [l] and [r] where all keys
2193 in [l] are <[k] and all keys in [r] are >[k].
2194 [splitLookup k t] Just like [split] but also returns whether [k]
2195 was found in the tree.
2196 --------------------------------------------------------------------}
2197
2198 data MaybeS a = NothingS | JustS !a
2199
2200 {--------------------------------------------------------------------
2201 [trim blo bhi t] trims away all subtrees that surely contain no
2202 values between the range [blo] to [bhi]. The returned tree is either
2203 empty or the key of the root is between @blo@ and @bhi@.
2204 --------------------------------------------------------------------}
2205 trim :: Ord k => MaybeS k -> MaybeS k -> Map k a -> Map k a
2206 trim NothingS NothingS t = t
2207 trim (JustS lk) NothingS t = greater lk t where greater lo (Bin _ k _ _ r) | k <= lo = greater lo r
2208 greater _ t' = t'
2209 trim NothingS (JustS hk) t = lesser hk t where lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l
2210 lesser _ t' = t'
2211 trim (JustS lk) (JustS hk) t = middle lk hk t where middle lo hi (Bin _ k _ _ r) | k <= lo = middle lo hi r
2212 middle lo hi (Bin _ k _ l _) | k >= hi = middle lo hi l
2213 middle _ _ t' = t'
2214 #if __GLASGOW_HASKELL__ >= 700
2215 {-# INLINABLE trim #-}
2216 #endif
2217
2218 -- Helper function for 'mergeWithKey'. The @'trimLookupLo' lk hk t@ performs both
2219 -- @'trim' (JustS lk) hk t@ and @'lookup' lk t@.
2220
2221 -- See Note: Type of local 'go' function
2222 trimLookupLo :: Ord k => k -> MaybeS k -> Map k a -> (Maybe a, Map k a)
2223 trimLookupLo lk0 mhk0 t0 = toPair $ go lk0 mhk0 t0
2224 where
2225 go lk NothingS t = greater lk t
2226 where greater :: Ord k => k -> Map k a -> StrictPair (Maybe a) (Map k a)
2227 greater lo t'@(Bin _ kx x l r) = case compare lo kx of
2228 LT -> lookup lo l :*: t'
2229 EQ -> (Just x :*: r)
2230 GT -> greater lo r
2231 greater _ Tip = (Nothing :*: Tip)
2232 go lk (JustS hk) t = middle lk hk t
2233 where middle :: Ord k => k -> k -> Map k a -> StrictPair (Maybe a) (Map k a)
2234 middle lo hi t'@(Bin _ kx x l r) = case compare lo kx of
2235 LT | kx < hi -> lookup lo l :*: t'
2236 | otherwise -> middle lo hi l
2237 EQ -> Just x :*: lesser hi r
2238 GT -> middle lo hi r
2239 middle _ _ Tip = (Nothing :*: Tip)
2240
2241 lesser :: Ord k => k -> Map k a -> Map k a
2242 lesser hi (Bin _ k _ l _) | k >= hi = lesser hi l
2243 lesser _ t' = t'
2244 #if __GLASGOW_HASKELL__ >= 700
2245 {-# INLINABLE trimLookupLo #-}
2246 #endif
2247
2248
2249 {--------------------------------------------------------------------
2250 [filterGt b t] filter all keys >[b] from tree [t]
2251 [filterLt b t] filter all keys <[b] from tree [t]
2252 --------------------------------------------------------------------}
2253 filterGt :: Ord k => MaybeS k -> Map k v -> Map k v
2254 filterGt NothingS t = t
2255 filterGt (JustS b) t = filter' b t
2256 where filter' _ Tip = Tip
2257 filter' b' (Bin _ kx x l r) =
2258 case compare b' kx of LT -> link kx x (filter' b' l) r
2259 EQ -> r
2260 GT -> filter' b' r
2261 #if __GLASGOW_HASKELL__ >= 700
2262 {-# INLINABLE filterGt #-}
2263 #endif
2264
2265 filterLt :: Ord k => MaybeS k -> Map k v -> Map k v
2266 filterLt NothingS t = t
2267 filterLt (JustS b) t = filter' b t
2268 where filter' _ Tip = Tip
2269 filter' b' (Bin _ kx x l r) =
2270 case compare kx b' of LT -> link kx x l (filter' b' r)
2271 EQ -> l
2272 GT -> filter' b' l
2273 #if __GLASGOW_HASKELL__ >= 700
2274 {-# INLINABLE filterLt #-}
2275 #endif
2276
2277 {--------------------------------------------------------------------
2278 Split
2279 --------------------------------------------------------------------}
2280 -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
2281 -- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.
2282 -- Any key equal to @k@ is found in neither @map1@ nor @map2@.
2283 --
2284 -- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])
2285 -- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")
2286 -- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
2287 -- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)
2288 -- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)
2289
2290 split :: Ord k => k -> Map k a -> (Map k a,Map k a)
2291 split k0 t0 = k0 `seq` toPair $ go k0 t0
2292 where
2293 go k t =
2294 case t of
2295 Tip -> (Tip :*: Tip)
2296 Bin _ kx x l r -> case compare k kx of
2297 LT -> let (lt :*: gt) = go k l in lt :*: link kx x gt r
2298 GT -> let (lt :*: gt) = go k r in link kx x l lt :*: gt
2299 EQ -> (l :*: r)
2300 #if __GLASGOW_HASKELL__ >= 700
2301 {-# INLINABLE split #-}
2302 #endif
2303
2304 -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
2305 -- like 'split' but also returns @'lookup' k map@.
2306 --
2307 -- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])
2308 -- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")
2309 -- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")
2310 -- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)
2311 -- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)
2312
2313 splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
2314 splitLookup k t = k `seq`
2315 case t of
2316 Tip -> (Tip,Nothing,Tip)
2317 Bin _ kx x l r -> case compare k kx of
2318 LT -> let (lt,z,gt) = splitLookup k l
2319 gt' = link kx x gt r
2320 in gt' `seq` (lt,z,gt')
2321 GT -> let (lt,z,gt) = splitLookup k r
2322 lt' = link kx x l lt
2323 in lt' `seq` (lt',z,gt)
2324 EQ -> (l,Just x,r)
2325 #if __GLASGOW_HASKELL__ >= 700
2326 {-# INLINABLE splitLookup #-}
2327 #endif
2328
2329 {--------------------------------------------------------------------
2330 Utility functions that maintain the balance properties of the tree.
2331 All constructors assume that all values in [l] < [k] and all values
2332 in [r] > [k], and that [l] and [r] are valid trees.
2333
2334 In order of sophistication:
2335 [Bin sz k x l r] The type constructor.
2336 [bin k x l r] Maintains the correct size, assumes that both [l]
2337 and [r] are balanced with respect to each other.
2338 [balance k x l r] Restores the balance and size.
2339 Assumes that the original tree was balanced and
2340 that [l] or [r] has changed by at most one element.
2341 [link k x l r] Restores balance and size.
2342
2343 Furthermore, we can construct a new tree from two trees. Both operations
2344 assume that all values in [l] < all values in [r] and that [l] and [r]
2345 are valid:
2346 [glue l r] Glues [l] and [r] together. Assumes that [l] and
2347 [r] are already balanced with respect to each other.
2348 [merge l r] Merges two trees and restores balance.
2349
2350 Note: in contrast to Adam's paper, we use (<=) comparisons instead
2351 of (<) comparisons in [link], [merge] and [balance].
2352 Quickcheck (on [difference]) showed that this was necessary in order
2353 to maintain the invariants. It is quite unsatisfactory that I haven't
2354 been able to find out why this is actually the case! Fortunately, it
2355 doesn't hurt to be a bit more conservative.
2356 --------------------------------------------------------------------}
2357
2358 {--------------------------------------------------------------------
2359 Link
2360 --------------------------------------------------------------------}
2361 link :: k -> a -> Map k a -> Map k a -> Map k a
2362 link kx x Tip r = insertMin kx x r
2363 link kx x l Tip = insertMax kx x l
2364 link kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
2365 | delta*sizeL < sizeR = balanceL kz z (link kx x l lz) rz
2366 | delta*sizeR < sizeL = balanceR ky y ly (link kx x ry r)
2367 | otherwise = bin kx x l r
2368
2369
2370 -- insertMin and insertMax don't perform potentially expensive comparisons.
2371 insertMax,insertMin :: k -> a -> Map k a -> Map k a
2372 insertMax kx x t
2373 = case t of
2374 Tip -> singleton kx x
2375 Bin _ ky y l r
2376 -> balanceR ky y l (insertMax kx x r)
2377
2378 insertMin kx x t
2379 = case t of
2380 Tip -> singleton kx x
2381 Bin _ ky y l r
2382 -> balanceL ky y (insertMin kx x l) r
2383
2384 {--------------------------------------------------------------------
2385 [merge l r]: merges two trees.
2386 --------------------------------------------------------------------}
2387 merge :: Map k a -> Map k a -> Map k a
2388 merge Tip r = r
2389 merge l Tip = l
2390 merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
2391 | delta*sizeL < sizeR = balanceL ky y (merge l ly) ry
2392 | delta*sizeR < sizeL = balanceR kx x lx (merge rx r)
2393 | otherwise = glue l r
2394
2395 {--------------------------------------------------------------------
2396 [glue l r]: glues two trees together.
2397 Assumes that [l] and [r] are already balanced with respect to each other.
2398 --------------------------------------------------------------------}
2399 glue :: Map k a -> Map k a -> Map k a
2400 glue Tip r = r
2401 glue l Tip = l
2402 glue l r
2403 | size l > size r = let ((km,m),l') = deleteFindMax l in balanceR km m l' r
2404 | otherwise = let ((km,m),r') = deleteFindMin r in balanceL km m l r'
2405
2406
2407 -- | /O(log n)/. Delete and find the minimal element.
2408 --
2409 -- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")])
2410 -- > deleteFindMin Error: can not return the minimal element of an empty map
2411
2412 deleteFindMin :: Map k a -> ((k,a),Map k a)
2413 deleteFindMin t
2414 = case t of
2415 Bin _ k x Tip r -> ((k,x),r)
2416 Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balanceR k x l' r)
2417 Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
2418
2419 -- | /O(log n)/. Delete and find the maximal element.
2420 --
2421 -- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])
2422 -- > deleteFindMax empty Error: can not return the maximal element of an empty map
2423
2424 deleteFindMax :: Map k a -> ((k,a),Map k a)
2425 deleteFindMax t
2426 = case t of
2427 Bin _ k x l Tip -> ((k,x),l)
2428 Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balanceL k x l r')
2429 Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
2430
2431
2432 {--------------------------------------------------------------------
2433 [balance l x r] balances two trees with value x.
2434 The sizes of the trees should balance after decreasing the
2435 size of one of them. (a rotation).
2436
2437 [delta] is the maximal relative difference between the sizes of
2438 two trees, it corresponds with the [w] in Adams' paper.
2439 [ratio] is the ratio between an outer and inner sibling of the
2440 heavier subtree in an unbalanced setting. It determines
2441 whether a double or single rotation should be performed
2442 to restore balance. It is corresponds with the inverse
2443 of $\alpha$ in Adam's article.
2444
2445 Note that according to the Adam's paper:
2446 - [delta] should be larger than 4.646 with a [ratio] of 2.
2447 - [delta] should be larger than 3.745 with a [ratio] of 1.534.
2448
2449 But the Adam's paper is erroneous:
2450 - It can be proved that for delta=2 and delta>=5 there does
2451 not exist any ratio that would work.
2452 - Delta=4.5 and ratio=2 does not work.
2453
2454 That leaves two reasonable variants, delta=3 and delta=4,
2455 both with ratio=2.
2456
2457 - A lower [delta] leads to a more 'perfectly' balanced tree.
2458 - A higher [delta] performs less rebalancing.
2459
2460 In the benchmarks, delta=3 is faster on insert operations,
2461 and delta=4 has slightly better deletes. As the insert speedup
2462 is larger, we currently use delta=3.
2463
2464 --------------------------------------------------------------------}
2465 delta,ratio :: Int
2466 delta = 3
2467 ratio = 2
2468
2469 -- The balance function is equivalent to the following:
2470 --
2471 -- balance :: k -> a -> Map k a -> Map k a -> Map k a
2472 -- balance k x l r
2473 -- | sizeL + sizeR <= 1 = Bin sizeX k x l r
2474 -- | sizeR > delta*sizeL = rotateL k x l r
2475 -- | sizeL > delta*sizeR = rotateR k x l r
2476 -- | otherwise = Bin sizeX k x l r
2477 -- where
2478 -- sizeL = size l
2479 -- sizeR = size r
2480 -- sizeX = sizeL + sizeR + 1
2481 --
2482 -- rotateL :: a -> b -> Map a b -> Map a b -> Map a b
2483 -- rotateL k x l r@(Bin _ _ _ ly ry) | size ly < ratio*size ry = singleL k x l r
2484 -- | otherwise = doubleL k x l r
2485 --
2486 -- rotateR :: a -> b -> Map a b -> Map a b -> Map a b
2487 -- rotateR k x l@(Bin _ _ _ ly ry) r | size ry < ratio*size ly = singleR k x l r
2488 -- | otherwise = doubleR k x l r
2489 --
2490 -- singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b
2491 -- singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
2492 -- singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
2493 --
2494 -- doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b
2495 -- 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)
2496 -- 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)
2497 --
2498 -- It is only written in such a way that every node is pattern-matched only once.
2499
2500 balance :: k -> a -> Map k a -> Map k a -> Map k a
2501 balance k x l r = case l of
2502 Tip -> case r of
2503 Tip -> Bin 1 k x Tip Tip
2504 (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r
2505 (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr
2506 (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)
2507 (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))
2508 | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr
2509 | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)
2510
2511 (Bin ls lk lx ll lr) -> case r of
2512 Tip -> case (ll, lr) of
2513 (Tip, Tip) -> Bin 2 k x l Tip
2514 (Tip, (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)
2515 ((Bin _ _ _ _ _), Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)
2516 ((Bin lls _ _ _ _), (Bin lrs lrk lrx lrl lrr))
2517 | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)
2518 | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)
2519 (Bin rs rk rx rl rr)
2520 | rs > delta*ls -> case (rl, rr) of
2521 (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)
2522 | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr
2523 | 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)
2524 (_, _) -> error "Failure in Data.Map.balance"
2525 | ls > delta*rs -> case (ll, lr) of
2526 (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)
2527 | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)
2528 | 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)
2529 (_, _) -> error "Failure in Data.Map.balance"
2530 | otherwise -> Bin (1+ls+rs) k x l r
2531 {-# NOINLINE balance #-}
2532
2533 -- Functions balanceL and balanceR are specialised versions of balance.
2534 -- balanceL only checks whether the left subtree is too big,
2535 -- balanceR only checks whether the right subtree is too big.
2536
2537 -- balanceL is called when left subtree might have been inserted to or when
2538 -- right subtree might have been deleted from.
2539 balanceL :: k -> a -> Map k a -> Map k a -> Map k a
2540 balanceL k x l r = case r of
2541 Tip -> case l of
2542 Tip -> Bin 1 k x Tip Tip
2543 (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip
2544 (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)
2545 (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)
2546 (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))
2547 | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)
2548 | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)
2549
2550 (Bin rs _ _ _ _) -> case l of
2551 Tip -> Bin (1+rs) k x Tip r
2552
2553 (Bin ls lk lx ll lr)
2554 | ls > delta*rs -> case (ll, lr) of
2555 (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)
2556 | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)
2557 | 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)
2558 (_, _) -> error "Failure in Data.Map.balanceL"
2559 | otherwise -> Bin (1+ls+rs) k x l r
2560 {-# NOINLINE balanceL #-}
2561
2562 -- balanceR is called when right subtree might have been inserted to or when
2563 -- left subtree might have been deleted from.
2564 balanceR :: k -> a -> Map k a -> Map k a -> Map k a
2565 balanceR k x l r = case l of
2566 Tip -> case r of
2567 Tip -> Bin 1 k x Tip Tip
2568 (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r
2569 (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr
2570 (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)
2571 (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))
2572 | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr
2573 | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)
2574
2575 (Bin ls _ _ _ _) -> case r of
2576 Tip -> Bin (1+ls) k x l Tip
2577
2578 (Bin rs rk rx rl rr)
2579 | rs > delta*ls -> case (rl, rr) of
2580 (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)
2581 | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr
2582 | 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)
2583 (_, _) -> error "Failure in Data.Map.balanceR"
2584 | otherwise -> Bin (1+ls+rs) k x l r
2585 {-# NOINLINE balanceR #-}
2586
2587
2588 {--------------------------------------------------------------------
2589 The bin constructor maintains the size of the tree
2590 --------------------------------------------------------------------}
2591 bin :: k -> a -> Map k a -> Map k a -> Map k a
2592 bin k x l r
2593 = Bin (size l + size r + 1) k x l r
2594 {-# INLINE bin #-}
2595
2596
2597 {--------------------------------------------------------------------
2598 Eq converts the tree to a list. In a lazy setting, this
2599 actually seems one of the faster methods to compare two trees
2600 and it is certainly the simplest :-)
2601 --------------------------------------------------------------------}
2602 instance (Eq k,Eq a) => Eq (Map k a) where
2603 t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
2604
2605 {--------------------------------------------------------------------
2606 Ord
2607 --------------------------------------------------------------------}
2608
2609 instance (Ord k, Ord v) => Ord (Map k v) where
2610 compare m1 m2 = compare (toAscList m1) (toAscList m2)
2611
2612 {--------------------------------------------------------------------
2613 Functor
2614 --------------------------------------------------------------------}
2615 instance Functor (Map k) where
2616 fmap f m = map f m
2617
2618 instance Traversable (Map k) where
2619 traverse f = traverseWithKey (\_ -> f)
2620 {-# INLINE traverse #-}
2621
2622 instance Foldable.Foldable (Map k) where
2623 fold t = go t
2624 where go Tip = mempty
2625 go (Bin 1 _ v _ _) = v
2626 go (Bin _ _ v l r) = go l `mappend` (v `mappend` go r)
2627 {-# INLINABLE fold #-}
2628 foldr = foldr
2629 {-# INLINE foldr #-}
2630 foldl = foldl
2631 {-# INLINE foldl #-}
2632 foldMap f t = go t
2633 where go Tip = mempty
2634 go (Bin 1 _ v _ _) = f v
2635 go (Bin _ _ v l r) = go l `mappend` (f v `mappend` go r)
2636 {-# INLINE foldMap #-}
2637
2638 instance (NFData k, NFData a) => NFData (Map k a) where
2639 rnf Tip = ()
2640 rnf (Bin _ kx x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r
2641
2642 {--------------------------------------------------------------------
2643 Read
2644 --------------------------------------------------------------------}
2645 instance (Ord k, Read k, Read e) => Read (Map k e) where
2646 #ifdef __GLASGOW_HASKELL__
2647 readPrec = parens $ prec 10 $ do
2648 Ident "fromList" <- lexP
2649 xs <- readPrec
2650 return (fromList xs)
2651
2652 readListPrec = readListPrecDefault
2653 #else
2654 readsPrec p = readParen (p > 10) $ \ r -> do
2655 ("fromList",s) <- lex r
2656 (xs,t) <- reads s
2657 return (fromList xs,t)
2658 #endif
2659
2660 {--------------------------------------------------------------------
2661 Show
2662 --------------------------------------------------------------------}
2663 instance (Show k, Show a) => Show (Map k a) where
2664 showsPrec d m = showParen (d > 10) $
2665 showString "fromList " . shows (toList m)
2666
2667 -- | /O(n)/. Show the tree that implements the map. The tree is shown
2668 -- in a compressed, hanging format. See 'showTreeWith'.
2669 showTree :: (Show k,Show a) => Map k a -> String
2670 showTree m
2671 = showTreeWith showElem True False m
2672 where
2673 showElem k x = show k ++ ":=" ++ show x
2674
2675
2676 {- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows
2677 the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is
2678 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
2679 @wide@ is 'True', an extra wide version is shown.
2680
2681 > Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]
2682 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t
2683 > (4,())
2684 > +--(2,())
2685 > | +--(1,())
2686 > | +--(3,())
2687 > +--(5,())
2688 >
2689 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t
2690 > (4,())
2691 > |
2692 > +--(2,())
2693 > | |
2694 > | +--(1,())
2695 > | |
2696 > | +--(3,())
2697 > |
2698 > +--(5,())
2699 >
2700 > Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t
2701 > +--(5,())
2702 > |
2703 > (4,())
2704 > |
2705 > | +--(3,())
2706 > | |
2707 > +--(2,())
2708 > |
2709 > +--(1,())
2710
2711 -}
2712 showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
2713 showTreeWith showelem hang wide t
2714 | hang = (showsTreeHang showelem wide [] t) ""
2715 | otherwise = (showsTree showelem wide [] [] t) ""
2716
2717 showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
2718 showsTree showelem wide lbars rbars t
2719 = case t of
2720 Tip -> showsBars lbars . showString "|\n"
2721 Bin _ kx x Tip Tip
2722 -> showsBars lbars . showString (showelem kx x) . showString "\n"
2723 Bin _ kx x l r
2724 -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
2725 showWide wide rbars .
2726 showsBars lbars . showString (showelem kx x) . showString "\n" .
2727 showWide wide lbars .
2728 showsTree showelem wide (withEmpty lbars) (withBar lbars) l
2729
2730 showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
2731 showsTreeHang showelem wide bars t
2732 = case t of
2733 Tip -> showsBars bars . showString "|\n"
2734 Bin _ kx x Tip Tip
2735 -> showsBars bars . showString (showelem kx x) . showString "\n"
2736 Bin _ kx x l r
2737 -> showsBars bars . showString (showelem kx x) . showString "\n" .
2738 showWide wide bars .
2739 showsTreeHang showelem wide (withBar bars) l .
2740 showWide wide bars .
2741 showsTreeHang showelem wide (withEmpty bars) r
2742
2743 showWide :: Bool -> [String] -> String -> String
2744 showWide wide bars
2745 | wide = showString (concat (reverse bars)) . showString "|\n"
2746 | otherwise = id
2747
2748 showsBars :: [String] -> ShowS
2749 showsBars bars
2750 = case bars of
2751 [] -> id
2752 _ -> showString (concat (reverse (tail bars))) . showString node
2753
2754 node :: String
2755 node = "+--"
2756
2757 withBar, withEmpty :: [String] -> [String]
2758 withBar bars = "| ":bars
2759 withEmpty bars = " ":bars
2760
2761 {--------------------------------------------------------------------
2762 Typeable
2763 --------------------------------------------------------------------}
2764
2765 #include "Typeable.h"
2766 INSTANCE_TYPEABLE2(Map,mapTc,"Map")
2767
2768 {--------------------------------------------------------------------
2769 Assertions
2770 --------------------------------------------------------------------}
2771 -- | /O(n)/. Test if the internal map structure is valid.
2772 --
2773 -- > valid (fromAscList [(3,"b"), (5,"a")]) == True
2774 -- > valid (fromAscList [(5,"a"), (3,"b")]) == False
2775
2776 valid :: Ord k => Map k a -> Bool
2777 valid t
2778 = balanced t && ordered t && validsize t
2779
2780 ordered :: Ord a => Map a b -> Bool
2781 ordered t
2782 = bounded (const True) (const True) t
2783 where
2784 bounded lo hi t'
2785 = case t' of
2786 Tip -> True
2787 Bin _ kx _ l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
2788
2789 -- | Exported only for "Debug.QuickCheck"
2790 balanced :: Map k a -> Bool
2791 balanced t
2792 = case t of
2793 Tip -> True
2794 Bin _ _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
2795 balanced l && balanced r
2796
2797 validsize :: Map a b -> Bool
2798 validsize t
2799 = (realsize t == Just (size t))
2800 where
2801 realsize t'
2802 = case t' of
2803 Tip -> Just 0
2804 Bin sz _ _ l r -> case (realsize l,realsize r) of
2805 (Just n,Just m) | n+m+1 == sz -> Just sz
2806 _ -> Nothing
2807
2808 {--------------------------------------------------------------------
2809 Utilities
2810 --------------------------------------------------------------------}
2811 foldlStrict :: (a -> b -> a) -> a -> [b] -> a
2812 foldlStrict f = go
2813 where
2814 go z [] = z
2815 go z (x:xs) = let z' = f z x in z' `seq` go z' xs
2816 {-# INLINE foldlStrict #-}
2817
2818
2819 -- | /O(1)/. Decompose a Map into pieces, based on the structure of the underlying
2820 -- tree. No guarantee is made as to the sizes of the pieces: an internal, but
2821 -- deterministic process determines this. This is most useful for consuming a Map in
2822 -- parallel.
2823 splitTree :: Map k b -> [Map k b]
2824 splitTree orig =
2825 case orig of
2826 Tip -> []
2827 Bin 1 k v l r -> [singleton k v, l, r]
2828 {-# INLINE splitTree #-}
2829
2830