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