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