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