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