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