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