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