08cadcb68fa01240eb47b3ffc9acc649947a20a9
[packages/containers.git] / Data / Map / Strict / Internal.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE BangPatterns #-}
3 #if __GLASGOW_HASKELL__ >= 703
4 {-# LANGUAGE Trustworthy #-}
5 #endif
6
7 {-# OPTIONS_HADDOCK hide #-}
8
9 #include "containers.h"
10
11 -----------------------------------------------------------------------------
12 -- |
13 -- Module : Data.Map.Strict.Internal
14 -- Copyright : (c) Daan Leijen 2002
15 -- (c) Andriy Palamarchuk 2008
16 -- License : BSD-style
17 -- Maintainer : libraries@haskell.org
18 -- Stability : provisional
19 -- Portability : portable
20 --
21 -- = WARNING
22 --
23 -- This module is considered __internal__.
24 --
25 -- The Package Versioning Policy __does not apply__.
26 --
27 -- This contents of this module may change __in any way whatsoever__
28 -- and __without any warning__ between minor versions of this package.
29 --
30 -- Authors importing this module are expected to track development
31 -- closely.
32 --
33 -- = Description
34 --
35 -- An efficient implementation of ordered maps from keys to values
36 -- (dictionaries).
37 --
38 -- API of this module is strict in both the keys and the values.
39 -- If you need value-lazy maps, use "Data.Map.Lazy" instead.
40 -- The 'Map' type is shared between the lazy and strict modules,
41 -- meaning that the same 'Map' value can be passed to functions in
42 -- both modules (although that is rarely needed).
43 --
44 -- These modules are intended to be imported qualified, to avoid name
45 -- clashes with Prelude functions, e.g.
46 --
47 -- > import qualified Data.Map.Strict as Map
48 --
49 -- The implementation of 'Map' is based on /size balanced/ binary trees (or
50 -- trees of /bounded balance/) as described by:
51 --
52 -- * Stephen Adams, \"/Efficient sets: a balancing act/\",
53 -- Journal of Functional Programming 3(4):553-562, October 1993,
54 -- <http://www.swiss.ai.mit.edu/~adams/BB/>.
55 -- * J. Nievergelt and E.M. Reingold,
56 -- \"/Binary search trees of bounded balance/\",
57 -- SIAM journal of computing 2(1), March 1973.
58 --
59 -- Bounds for 'union', 'intersection', and 'difference' are as given
60 -- by
61 --
62 -- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,
63 -- \"/Just Join for Parallel Ordered Sets/\",
64 -- <https://arxiv.org/abs/1602.02120v3>.
65 --
66 -- Note that the implementation is /left-biased/ -- the elements of a
67 -- first argument are always preferred to the second, for example in
68 -- 'union' or 'insert'.
69 --
70 -- /Warning/: The size of the map must not exceed @maxBound::Int@. Violation of
71 -- this condition is not detected and if the size limit is exceeded, its
72 -- behaviour is undefined.
73 --
74 -- Operation comments contain the operation time complexity in
75 -- the Big-O notation (<http://en.wikipedia.org/wiki/Big_O_notation>).
76 --
77 -- Be aware that the 'Functor', 'Traversable' and 'Data' instances
78 -- are the same as for the "Data.Map.Lazy" module, so if they are used
79 -- on strict maps, the resulting maps will be lazy.
80 -----------------------------------------------------------------------------
81
82 -- See the notes at the beginning of Data.Map.Base.
83
84 module Data.Map.Strict.Internal
85 (
86 -- * Strictness properties
87 -- $strictness
88
89 -- * Map type
90 Map(..) -- instance Eq,Show,Read
91
92 -- * Operators
93 , (!), (\\)
94
95 -- * Query
96 , null
97 , size
98 , member
99 , notMember
100 , lookup
101 , findWithDefault
102 , lookupLT
103 , lookupGT
104 , lookupLE
105 , lookupGE
106
107 -- * Construction
108 , empty
109 , singleton
110
111 -- ** Insertion
112 , insert
113 , insertWith
114 , insertWithKey
115 , insertLookupWithKey
116
117 -- ** Delete\/Update
118 , delete
119 , adjust
120 , adjustWithKey
121 , update
122 , updateWithKey
123 , updateLookupWithKey
124 , alter
125 , alterF
126
127 -- * Combine
128
129 -- ** Union
130 , union
131 , unionWith
132 , unionWithKey
133 , unions
134 , unionsWith
135
136 -- ** Difference
137 , difference
138 , differenceWith
139 , differenceWithKey
140
141 -- ** Intersection
142 , intersection
143 , intersectionWith
144 , intersectionWithKey
145
146 -- ** General combining function
147 , SimpleWhenMissing
148 , SimpleWhenMatched
149 , merge
150 , runWhenMatched
151 , runWhenMissing
152
153 -- *** @WhenMatched@ tactics
154 , zipWithMaybeMatched
155 , zipWithMatched
156
157 -- *** @WhenMissing@ tactics
158 , mapMaybeMissing
159 , dropMissing
160 , preserveMissing
161 , mapMissing
162 , filterMissing
163
164 -- ** Applicative general combining function
165 , WhenMissing (..)
166 , WhenMatched (..)
167 , mergeA
168
169 -- *** @WhenMatched@ tactics
170 -- | The tactics described for 'merge' work for
171 -- 'mergeA' as well. Furthermore, the following
172 -- are available.
173 , zipWithMaybeAMatched
174 , zipWithAMatched
175
176 -- *** @WhenMissing@ tactics
177 -- | The tactics described for 'merge' work for
178 -- 'mergeA' as well. Furthermore, the following
179 -- are available.
180 , traverseMaybeMissing
181 , traverseMissing
182 , filterAMissing
183
184 -- *** Covariant maps for tactics
185 , mapWhenMissing
186 , mapWhenMatched
187
188 -- ** Deprecated general combining function
189
190 , mergeWithKey
191
192 -- * Traversal
193 -- ** Map
194 , map
195 , mapWithKey
196 , traverseWithKey
197 , traverseMaybeWithKey
198 , mapAccum
199 , mapAccumWithKey
200 , mapAccumRWithKey
201 , mapKeys
202 , mapKeysWith
203 , mapKeysMonotonic
204
205 -- * Folds
206 , foldr
207 , foldl
208 , foldrWithKey
209 , foldlWithKey
210 , foldMapWithKey
211
212 -- ** Strict folds
213 , foldr'
214 , foldl'
215 , foldrWithKey'
216 , foldlWithKey'
217
218 -- * Conversion
219 , elems
220 , keys
221 , assocs
222 , keysSet
223 , fromSet
224
225 -- ** Lists
226 , toList
227 , fromList
228 , fromListWith
229 , fromListWithKey
230
231 -- ** Ordered lists
232 , toAscList
233 , toDescList
234 , fromAscList
235 , fromAscListWith
236 , fromAscListWithKey
237 , fromDistinctAscList
238 , fromDescList
239 , fromDescListWith
240 , fromDescListWithKey
241 , fromDistinctDescList
242
243 -- * Filter
244 , filter
245 , filterWithKey
246 , restrictKeys
247 , withoutKeys
248 , partition
249 , partitionWithKey
250 , takeWhileAntitone
251 , dropWhileAntitone
252 , spanAntitone
253
254 , mapMaybe
255 , mapMaybeWithKey
256 , mapEither
257 , mapEitherWithKey
258
259 , split
260 , splitLookup
261 , splitRoot
262
263 -- * Submap
264 , isSubmapOf, isSubmapOfBy
265 , isProperSubmapOf, isProperSubmapOfBy
266
267 -- * Indexed
268 , lookupIndex
269 , findIndex
270 , elemAt
271 , updateAt
272 , deleteAt
273 , take
274 , drop
275 , splitAt
276
277 -- * Min\/Max
278 , findMin
279 , findMax
280 , deleteMin
281 , deleteMax
282 , deleteFindMin
283 , deleteFindMax
284 , updateMin
285 , updateMax
286 , updateMinWithKey
287 , updateMaxWithKey
288 , minView
289 , maxView
290 , minViewWithKey
291 , maxViewWithKey
292
293 -- * Debugging
294 , showTree
295 , showTreeWith
296 , valid
297
298 , bin
299 , balanced
300 , link
301 , link2
302 ) where
303
304 import Prelude hiding (lookup,map,filter,foldr,foldl,null,take,drop,splitAt)
305
306 import Data.Map.Base
307 ( Map (..)
308 , AreWeStrict (..)
309 , WhenMissing (..)
310 , WhenMatched (..)
311 , runWhenMatched
312 , runWhenMissing
313 , SimpleWhenMissing
314 , SimpleWhenMatched
315 , preserveMissing
316 , dropMissing
317 , filterMissing
318 , filterAMissing
319 , merge
320 , mergeA
321 , (!)
322 , (\\)
323 , assocs
324 , atKeyImpl
325 #if MIN_VERSION_base(4,8,0)
326 , atKeyPlain
327 #endif
328 , balance
329 , balanceL
330 , balanceR
331 , elemAt
332 , elems
333 , empty
334 , delete
335 , deleteAt
336 , deleteFindMax
337 , deleteFindMin
338 , deleteMin
339 , deleteMax
340 , difference
341 , drop
342 , dropWhileAntitone
343 , filter
344 , filterWithKey
345 , findIndex
346 , findMax
347 , findMin
348 , foldl
349 , foldl'
350 , foldlWithKey
351 , foldlWithKey'
352 , foldMapWithKey
353 , foldr
354 , foldr'
355 , foldrWithKey
356 , foldrWithKey'
357 , glue
358 , insertMax
359 , intersection
360 , isProperSubmapOf
361 , isProperSubmapOfBy
362 , isSubmapOf
363 , isSubmapOfBy
364 , keys
365 , keysSet
366 , link
367 , lookup
368 , lookupGE
369 , lookupGT
370 , lookupIndex
371 , lookupLE
372 , lookupLT
373 , mapKeys
374 , mapKeysMonotonic
375 , maxView
376 , maxViewWithKey
377 , member
378 , link2
379 , minView
380 , minViewWithKey
381 , notMember
382 , null
383 , partition
384 , partitionWithKey
385 , restrictKeys
386 , showTree
387 , showTreeWith
388 , size
389 , spanAntitone
390 , split
391 , splitAt
392 , splitLookup
393 , splitRoot
394 , take
395 , takeWhileAntitone
396 , toList
397 , toAscList
398 , toDescList
399 , union
400 , unions
401 , valid
402 , withoutKeys )
403
404 import Data.Map.Base (bin, balanced)
405
406 import Control.Applicative (Const (..))
407 #if !MIN_VERSION_base(4,8,0)
408 import Control.Applicative (Applicative (..), (<$>))
409 #endif
410 import qualified Data.Set.Base as Set
411 import Data.Utils.StrictFold
412 import Data.Utils.StrictPair
413
414 import Data.Bits (shiftL, shiftR)
415 #if __GLASGOW_HASKELL__ >= 709
416 import Data.Coerce
417 #endif
418
419 #if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0)
420 import Data.Functor.Identity (Identity (..))
421 #endif
422
423
424 -- $strictness
425 --
426 -- This module satisfies the following strictness properties:
427 --
428 -- 1. Key arguments are evaluated to WHNF;
429 --
430 -- 2. Keys and values are evaluated to WHNF before they are stored in
431 -- the map.
432 --
433 -- Here's an example illustrating the first property:
434 --
435 -- > delete undefined m == undefined
436 --
437 -- Here are some examples that illustrate the second property:
438 --
439 -- > map (\ v -> undefined) m == undefined -- m is not empty
440 -- > mapKeys (\ k -> undefined) m == undefined -- m is not empty
441
442 -- [Note: Pointer equality for sharing]
443 --
444 -- We use pointer equality to enhance sharing between the arguments
445 -- of some functions and their results. Notably, we use it
446 -- for insert, delete, union, intersection, and difference. We do
447 -- *not* use it for functions, like insertWith, unionWithKey,
448 -- intersectionWith, etc., that allow the user to modify the elements.
449 -- While we *could* do so, we would only get sharing under fairly
450 -- narrow conditions and at a relatively high cost. It does not seem
451 -- worth the price.
452
453 {--------------------------------------------------------------------
454 Query
455 --------------------------------------------------------------------}
456
457 -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
458 -- the value at key @k@ or returns default value @def@
459 -- when the key is not in the map.
460 --
461 -- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'
462 -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'
463
464 -- See Map.Base.Note: Local 'go' functions and capturing
465 findWithDefault :: Ord k => a -> k -> Map k a -> a
466 findWithDefault def k = k `seq` go
467 where
468 go Tip = def
469 go (Bin _ kx x l r) = case compare k kx of
470 LT -> go l
471 GT -> go r
472 EQ -> x
473 #if __GLASGOW_HASKELL__
474 {-# INLINABLE findWithDefault #-}
475 #else
476 {-# INLINE findWithDefault #-}
477 #endif
478
479 {--------------------------------------------------------------------
480 Construction
481 --------------------------------------------------------------------}
482
483 -- | /O(1)/. A map with a single element.
484 --
485 -- > singleton 1 'a' == fromList [(1, 'a')]
486 -- > size (singleton 1 'a') == 1
487
488 singleton :: k -> a -> Map k a
489 singleton k x = x `seq` Bin 1 k x Tip Tip
490 {-# INLINE singleton #-}
491
492 {--------------------------------------------------------------------
493 Insertion
494 --------------------------------------------------------------------}
495 -- | /O(log n)/. Insert a new key and value in the map.
496 -- If the key is already present in the map, the associated value is
497 -- replaced with the supplied value. 'insert' is equivalent to
498 -- @'insertWith' 'const'@.
499 --
500 -- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]
501 -- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]
502 -- > insert 5 'x' empty == singleton 5 'x'
503
504 -- See Map.Base.Note: Type of local 'go' function
505 insert :: Ord k => k -> a -> Map k a -> Map k a
506 insert = go
507 where
508 go :: Ord k => k -> a -> Map k a -> Map k a
509 go !kx !x Tip = singleton kx x
510 go kx x (Bin sz ky y l r) =
511 case compare kx ky of
512 LT -> balanceL ky y (go kx x l) r
513 GT -> balanceR ky y l (go kx x r)
514 EQ -> Bin sz kx x l r
515 #if __GLASGOW_HASKELL__
516 {-# INLINABLE insert #-}
517 #else
518 {-# INLINE insert #-}
519 #endif
520
521 -- | /O(log n)/. Insert with a function, combining new value and old value.
522 -- @'insertWith' f key value mp@
523 -- will insert the pair (key, value) into @mp@ if key does
524 -- not exist in the map. If the key does exist, the function will
525 -- insert the pair @(key, f new_value old_value)@.
526 --
527 -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]
528 -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
529 -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"
530
531 insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
532 insertWith = go
533 where
534 go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
535 go _ !kx x Tip = singleton kx x
536 go f !kx x (Bin sy ky y l r) =
537 case compare kx ky of
538 LT -> balanceL ky y (go f kx x l) r
539 GT -> balanceR ky y l (go f kx x r)
540 EQ -> let !y' = f x y in Bin sy kx y' l r
541 #if __GLASGOW_HASKELL__
542 {-# INLINABLE insertWith #-}
543 #else
544 {-# INLINE insertWith #-}
545 #endif
546
547 insertWithR :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
548 insertWithR = go
549 where
550 go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
551 go _ !kx x Tip = singleton kx x
552 go f !kx x (Bin sy ky y l r) =
553 case compare kx ky of
554 LT -> balanceL ky y (go f kx x l) r
555 GT -> balanceR ky y l (go f kx x r)
556 EQ -> let !y' = f y x in Bin sy ky y' l r
557 #if __GLASGOW_HASKELL__
558 {-# INLINABLE insertWithR #-}
559 #else
560 {-# INLINE insertWithR #-}
561 #endif
562
563 -- | /O(log n)/. Insert with a function, combining key, new value and old value.
564 -- @'insertWithKey' f key value mp@
565 -- will insert the pair (key, value) into @mp@ if key does
566 -- not exist in the map. If the key does exist, the function will
567 -- insert the pair @(key,f key new_value old_value)@.
568 -- Note that the key passed to f is the same key passed to 'insertWithKey'.
569 --
570 -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
571 -- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]
572 -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
573 -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"
574
575 -- See Map.Base.Note: Type of local 'go' function
576 insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
577 insertWithKey = go
578 where
579 go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
580 -- Forcing `kx` may look redundant, but it's possible `compare` will
581 -- be lazy.
582 go _ !kx x Tip = singleton kx x
583 go f kx x (Bin sy ky y l r) =
584 case compare kx ky of
585 LT -> balanceL ky y (go f kx x l) r
586 GT -> balanceR ky y l (go f kx x r)
587 EQ -> let !x' = f kx x y
588 in Bin sy kx x' l r
589 #if __GLASGOW_HASKELL__
590 {-# INLINABLE insertWithKey #-}
591 #else
592 {-# INLINE insertWithKey #-}
593 #endif
594
595 insertWithKeyR :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
596 insertWithKeyR = go
597 where
598 go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
599 -- Forcing `kx` may look redundant, but it's possible `compare` will
600 -- be lazy.
601 go _ !kx x Tip = singleton kx x
602 go f kx x (Bin sy ky y l r) =
603 case compare kx ky of
604 LT -> balanceL ky y (go f kx x l) r
605 GT -> balanceR ky y l (go f kx x r)
606 EQ -> let !y' = f ky y x
607 in Bin sy ky y' l r
608 #if __GLASGOW_HASKELL__
609 {-# INLINABLE insertWithKeyR #-}
610 #else
611 {-# INLINE insertWithKeyR #-}
612 #endif
613
614 -- | /O(log n)/. Combines insert operation with old value retrieval.
615 -- The expression (@'insertLookupWithKey' f k x map@)
616 -- is a pair where the first element is equal to (@'lookup' k map@)
617 -- and the second element equal to (@'insertWithKey' f k x map@).
618 --
619 -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
620 -- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])
621 -- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])
622 -- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")
623 --
624 -- This is how to define @insertLookup@ using @insertLookupWithKey@:
625 --
626 -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t
627 -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])
628 -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])
629
630 -- See Map.Base.Note: Type of local 'go' function
631 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a
632 -> (Maybe a, Map k a)
633 insertLookupWithKey f0 kx0 x0 t0 = toPair $ go f0 kx0 x0 t0
634 where
635 go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a)
636 go _ !kx x Tip = Nothing :*: singleton kx x
637 go f kx x (Bin sy ky y l r) =
638 case compare kx ky of
639 LT -> let (found :*: l') = go f kx x l
640 in found :*: balanceL ky y l' r
641 GT -> let (found :*: r') = go f kx x r
642 in found :*: balanceR ky y l r'
643 EQ -> let x' = f kx x y
644 in x' `seq` (Just y :*: Bin sy kx x' l r)
645 #if __GLASGOW_HASKELL__
646 {-# INLINABLE insertLookupWithKey #-}
647 #else
648 {-# INLINE insertLookupWithKey #-}
649 #endif
650
651 {--------------------------------------------------------------------
652 Deletion
653 --------------------------------------------------------------------}
654
655 -- | /O(log n)/. Update a value at a specific key with the result of the provided function.
656 -- When the key is not
657 -- a member of the map, the original map is returned.
658 --
659 -- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
660 -- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
661 -- > adjust ("new " ++) 7 empty == empty
662
663 adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
664 adjust f = adjustWithKey (\_ x -> f x)
665 #if __GLASGOW_HASKELL__
666 {-# INLINABLE adjust #-}
667 #else
668 {-# INLINE adjust #-}
669 #endif
670
671 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
672 -- a member of the map, the original map is returned.
673 --
674 -- > let f key x = (show key) ++ ":new " ++ x
675 -- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
676 -- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
677 -- > adjustWithKey f 7 empty == empty
678
679 adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
680 adjustWithKey = go
681 where
682 go :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
683 go _ !_ Tip = Tip
684 go f k (Bin sx kx x l r) =
685 case compare k kx of
686 LT -> Bin sx kx x (go f k l) r
687 GT -> Bin sx kx x l (go f k r)
688 EQ -> Bin sx kx x' l r
689 where !x' = f kx x
690 #if __GLASGOW_HASKELL__
691 {-# INLINABLE adjustWithKey #-}
692 #else
693 {-# INLINE adjustWithKey #-}
694 #endif
695
696 -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
697 -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
698 -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
699 --
700 -- > let f x = if x == "a" then Just "new a" else Nothing
701 -- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
702 -- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
703 -- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
704
705 update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
706 update f = updateWithKey (\_ x -> f x)
707 #if __GLASGOW_HASKELL__
708 {-# INLINABLE update #-}
709 #else
710 {-# INLINE update #-}
711 #endif
712
713 -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
714 -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
715 -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
716 -- to the new value @y@.
717 --
718 -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
719 -- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
720 -- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
721 -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
722
723 -- See Map.Base.Note: Type of local 'go' function
724 updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
725 updateWithKey = go
726 where
727 go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
728 go _ !_ Tip = Tip
729 go f k(Bin sx kx x l r) =
730 case compare k kx of
731 LT -> balanceR kx x (go f k l) r
732 GT -> balanceL kx x l (go f k r)
733 EQ -> case f kx x of
734 Just x' -> x' `seq` Bin sx kx x' l r
735 Nothing -> glue l r
736 #if __GLASGOW_HASKELL__
737 {-# INLINABLE updateWithKey #-}
738 #else
739 {-# INLINE updateWithKey #-}
740 #endif
741
742 -- | /O(log n)/. Lookup and update. See also 'updateWithKey'.
743 -- The function returns changed value, if it is updated.
744 -- Returns the original key value if the map entry is deleted.
745 --
746 -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
747 -- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])
748 -- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])
749 -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
750
751 -- See Map.Base.Note: Type of local 'go' function
752 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
753 updateLookupWithKey f0 k0 t0 = toPair $ go f0 k0 t0
754 where
755 go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a)
756 go _ !_ Tip = (Nothing :*: Tip)
757 go f k (Bin sx kx x l r) =
758 case compare k kx of
759 LT -> let (found :*: l') = go f k l
760 in found :*: balanceR kx x l' r
761 GT -> let (found :*: r') = go f k r
762 in found :*: balanceL kx x l r'
763 EQ -> case f kx x of
764 Just x' -> x' `seq` (Just x' :*: Bin sx kx x' l r)
765 Nothing -> (Just x :*: glue l r)
766 #if __GLASGOW_HASKELL__
767 {-# INLINABLE updateLookupWithKey #-}
768 #else
769 {-# INLINE updateLookupWithKey #-}
770 #endif
771
772 -- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
773 -- 'alter' can be used to insert, delete, or update a value in a 'Map'.
774 -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.
775 --
776 -- > let f _ = Nothing
777 -- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
778 -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
779 -- >
780 -- > let f _ = Just "c"
781 -- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]
782 -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]
783
784 -- See Map.Base.Note: Type of local 'go' function
785 alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
786 alter = go
787 where
788 go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
789 go f !k Tip = case f Nothing of
790 Nothing -> Tip
791 Just x -> singleton k x
792
793 go f k (Bin sx kx x l r) = case compare k kx of
794 LT -> balance kx x (go f k l) r
795 GT -> balance kx x l (go f k r)
796 EQ -> case f (Just x) of
797 Just x' -> x' `seq` Bin sx kx x' l r
798 Nothing -> glue l r
799 #if __GLASGOW_HASKELL__
800 {-# INLINABLE alter #-}
801 #else
802 {-# INLINE alter #-}
803 #endif
804
805 -- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at @k@, or absence thereof.
806 -- 'alterF' can be used to inspect, insert, delete, or update a value in a 'Map'.
807 -- In short: @'lookup' k \<$\> 'alterF' f k m = f ('lookup' k m)@.
808 --
809 -- Example:
810 --
811 -- @
812 -- interactiveAlter :: Int -> Map Int String -> IO (Map Int String)
813 -- interactiveAlter k m = alterF f k m where
814 -- f Nothing -> do
815 -- putStrLn $ show k ++
816 -- " was not found in the map. Would you like to add it?"
817 -- getUserResponse1 :: IO (Maybe String)
818 -- f (Just old) -> do
819 -- putStrLn "The key is currently bound to " ++ show old ++
820 -- ". Would you like to change or delete it?"
821 -- getUserresponse2 :: IO (Maybe String)
822 -- @
823 --
824 -- 'alterF' is the most general operation for working with an individual
825 -- key that may or may not be in a given map. When used with trivial
826 -- functors like 'Identity' and 'Const', it is often slightly slower than
827 -- more specialized combinators like 'lookup' and 'insert'. However, when
828 -- the functor is non-trivial and key comparison is not particularly cheap,
829 -- it is the fastest way.
830 --
831 -- Note on rewrite rules:
832 --
833 -- This module includes GHC rewrite rules to optimize 'alterF' for
834 -- the 'Const' and 'Identity' functors. In general, these rules
835 -- improve performance. The sole exception is that when using
836 -- 'Identity', deleting a key that is already absent takes longer
837 -- than it would without the rules. If you expect this to occur
838 -- a very large fraction of the time, you might consider using a
839 -- private copy of the 'Identity' type.
840 --
841 -- Note: 'alterF' is a flipped version of the 'at' combinator from
842 -- 'Control.Lens.At'.
843 alterF :: (Functor f, Ord k)
844 => (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
845 alterF f k m = atKeyImpl Strict k f m
846
847 #ifndef __GLASGOW_HASKELL__
848 {-# INLINE alterF #-}
849 #else
850 {-# INLINABLE [2] alterF #-}
851
852 -- We can save a little time by recognizing the special case of
853 -- `Control.Applicative.Const` and just doing a lookup.
854 {-# RULES
855 "alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m
856 #-}
857 #if MIN_VERSION_base(4,8,0)
858 -- base 4.8 and above include Data.Functor.Identity, so we can
859 -- save a pretty decent amount of time by handling it specially.
860 {-# RULES
861 "alterF/Identity" forall k f . alterF f k = atKeyIdentity k f
862 #-}
863
864 atKeyIdentity :: Ord k => k -> (Maybe a -> Identity (Maybe a)) -> Map k a -> Identity (Map k a)
865 atKeyIdentity k f t = Identity $ atKeyPlain Strict k (coerce f) t
866 {-# INLINABLE atKeyIdentity #-}
867 #endif
868 #endif
869
870 {--------------------------------------------------------------------
871 Indexing
872 --------------------------------------------------------------------}
873
874 -- | /O(log n)/. Update the element at /index/. Calls 'error' when an
875 -- invalid index is used.
876 --
877 -- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]
878 -- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]
879 -- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
880 -- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range
881 -- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
882 -- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
883 -- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
884 -- > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range
885
886 updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
887 updateAt f i t = i `seq`
888 case t of
889 Tip -> error "Map.updateAt: index out of range"
890 Bin sx kx x l r -> case compare i sizeL of
891 LT -> balanceR kx x (updateAt f i l) r
892 GT -> balanceL kx x l (updateAt f (i-sizeL-1) r)
893 EQ -> case f kx x of
894 Just x' -> x' `seq` Bin sx kx x' l r
895 Nothing -> glue l r
896 where
897 sizeL = size l
898
899 {--------------------------------------------------------------------
900 Minimal, Maximal
901 --------------------------------------------------------------------}
902
903 -- | /O(log n)/. Update the value at the minimal key.
904 --
905 -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]
906 -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
907
908 updateMin :: (a -> Maybe a) -> Map k a -> Map k a
909 updateMin f m
910 = updateMinWithKey (\_ x -> f x) m
911
912 -- | /O(log n)/. Update the value at the maximal key.
913 --
914 -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]
915 -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
916
917 updateMax :: (a -> Maybe a) -> Map k a -> Map k a
918 updateMax f m
919 = updateMaxWithKey (\_ x -> f x) m
920
921
922 -- | /O(log n)/. Update the value at the minimal key.
923 --
924 -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]
925 -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
926
927 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
928 updateMinWithKey _ Tip = Tip
929 updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of
930 Nothing -> r
931 Just x' -> x' `seq` Bin sx kx x' Tip r
932 updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r
933
934 -- | /O(log n)/. Update the value at the maximal key.
935 --
936 -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]
937 -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
938
939 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
940 updateMaxWithKey _ Tip = Tip
941 updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of
942 Nothing -> l
943 Just x' -> x' `seq` Bin sx kx x' l Tip
944 updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r)
945
946 {--------------------------------------------------------------------
947 Union.
948 --------------------------------------------------------------------}
949
950 -- | The union of a list of maps, with a combining operation:
951 -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
952 --
953 -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
954 -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]
955
956 unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a
957 unionsWith f ts
958 = foldlStrict (unionWith f) empty ts
959 #if __GLASGOW_HASKELL__
960 {-# INLINABLE unionsWith #-}
961 #endif
962
963 {--------------------------------------------------------------------
964 Union with a combining function
965 --------------------------------------------------------------------}
966 -- | /O(m*log(n\/m + 1)), m <= n/. Union with a combining function.
967 --
968 -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]
969
970 unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
971 unionWith _f t1 Tip = t1
972 unionWith f t1 (Bin _ k x Tip Tip) = insertWithR f k x t1
973 unionWith f (Bin _ k x Tip Tip) t2 = insertWith f k x t2
974 unionWith _f Tip t2 = t2
975 unionWith f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of
976 (l2, mb, r2) -> link k1 x1' (unionWith f l1 l2) (unionWith f r1 r2)
977 where !x1' = maybe x1 (f x1) mb
978 #if __GLASGOW_HASKELL__
979 {-# INLINABLE unionWith #-}
980 #endif
981
982 -- | /O(m*log(n\/m + 1)), m <= n/.
983 -- Union with a combining function.
984 --
985 -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value
986 -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
987
988 unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
989 unionWithKey _f t1 Tip = t1
990 unionWithKey f t1 (Bin _ k x Tip Tip) = insertWithKeyR f k x t1
991 unionWithKey f (Bin _ k x Tip Tip) t2 = insertWithKey f k x t2
992 unionWithKey _f Tip t2 = t2
993 unionWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of
994 (l2, mb, r2) -> link k1 x1' (unionWithKey f l1 l2) (unionWithKey f r1 r2)
995 where !x1' = maybe x1 (f k1 x1) mb
996 #if __GLASGOW_HASKELL__
997 {-# INLINABLE unionWithKey #-}
998 #endif
999
1000 {--------------------------------------------------------------------
1001 Difference
1002 --------------------------------------------------------------------}
1003
1004 -- | /O(n+m)/. Difference with a combining function.
1005 -- When two equal keys are
1006 -- encountered, the combining function is applied to the values of these keys.
1007 -- If it returns 'Nothing', the element is discarded (proper set difference). If
1008 -- it returns (@'Just' y@), the element is updated with a new value @y@.
1009 --
1010 -- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing
1011 -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])
1012 -- > == singleton 3 "b:B"
1013
1014 differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
1015 differenceWith f = merge preserveMissing dropMissing (zipWithMaybeMatched $ \_ x1 x2 -> f x1 x2)
1016 #if __GLASGOW_HASKELL__
1017 {-# INLINABLE differenceWith #-}
1018 #endif
1019
1020 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
1021 -- encountered, the combining function is applied to the key and both values.
1022 -- If it returns 'Nothing', the element is discarded (proper set difference). If
1023 -- it returns (@'Just' y@), the element is updated with a new value @y@.
1024 --
1025 -- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing
1026 -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])
1027 -- > == singleton 3 "3:b|B"
1028
1029 differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
1030 differenceWithKey f = merge preserveMissing dropMissing (zipWithMaybeMatched f)
1031 #if __GLASGOW_HASKELL__
1032 {-# INLINABLE differenceWithKey #-}
1033 #endif
1034
1035
1036 {--------------------------------------------------------------------
1037 Intersection
1038 --------------------------------------------------------------------}
1039
1040 -- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.
1041 --
1042 -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
1043
1044 intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
1045 intersectionWith _f Tip _ = Tip
1046 intersectionWith _f _ Tip = Tip
1047 intersectionWith f (Bin _ k x1 l1 r1) t2 = case mb of
1048 Just x2 -> let !x1' = f x1 x2 in link k x1' l1l2 r1r2
1049 Nothing -> link2 l1l2 r1r2
1050 where
1051 !(l2, mb, r2) = splitLookup k t2
1052 !l1l2 = intersectionWith f l1 l2
1053 !r1r2 = intersectionWith f r1 r2
1054 #if __GLASGOW_HASKELL__
1055 {-# INLINABLE intersectionWith #-}
1056 #endif
1057
1058 -- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.
1059 --
1060 -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar
1061 -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"
1062
1063 intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
1064 intersectionWithKey _f Tip _ = Tip
1065 intersectionWithKey _f _ Tip = Tip
1066 intersectionWithKey f (Bin _ k x1 l1 r1) t2 = case mb of
1067 Just x2 -> let !x1' = f k x1 x2 in link k x1' l1l2 r1r2
1068 Nothing -> link2 l1l2 r1r2
1069 where
1070 !(l2, mb, r2) = splitLookup k t2
1071 !l1l2 = intersectionWithKey f l1 l2
1072 !r1r2 = intersectionWithKey f r1 r2
1073 #if __GLASGOW_HASKELL__
1074 {-# INLINABLE intersectionWithKey #-}
1075 #endif
1076
1077 -- | Map covariantly over a @'WhenMissing' f k x@.
1078 mapWhenMissing :: Functor f => (a -> b) -> WhenMissing f k x a -> WhenMissing f k x b
1079 mapWhenMissing f q = WhenMissing
1080 { missingSubtree = fmap (map f) . missingSubtree q
1081 , missingKey = \k x -> fmap (forceMaybe . fmap f) $ missingKey q k x}
1082
1083 -- | Map covariantly over a @'WhenMatched' f k x y@.
1084 mapWhenMatched :: Functor f => (a -> b) -> WhenMatched f k x y a -> WhenMatched f k x y b
1085 mapWhenMatched f q = WhenMatched
1086 { matchedKey = \k x y -> fmap (forceMaybe . fmap f) $ runWhenMatched q k x y }
1087
1088 -- | When a key is found in both maps, apply a function to the
1089 -- key and values and maybe use the result in the merged map.
1090 --
1091 -- @
1092 -- zipWithMaybeMatched :: (k -> x -> y -> Maybe z)
1093 -- -> SimpleWhenMatched k x y z
1094 -- @
1095 zipWithMaybeMatched :: Applicative f
1096 => (k -> x -> y -> Maybe z)
1097 -> WhenMatched f k x y z
1098 zipWithMaybeMatched f = WhenMatched $
1099 \k x y -> pure $! forceMaybe $! f k x y
1100 {-# INLINE zipWithMaybeMatched #-}
1101
1102 -- | When a key is found in both maps, apply a function to the
1103 -- key and values, perform the resulting action, and maybe use
1104 -- the result in the merged map.
1105 --
1106 -- This is the fundamental 'WhenMatched' tactic.
1107 zipWithMaybeAMatched :: Applicative f
1108 => (k -> x -> y -> f (Maybe z))
1109 -> WhenMatched f k x y z
1110 zipWithMaybeAMatched f = WhenMatched $
1111 \ k x y -> forceMaybe <$> f k x y
1112 {-# INLINE zipWithMaybeAMatched #-}
1113
1114 -- | When a key is found in both maps, apply a function to the
1115 -- key and values to produce an action and use its result in the merged map.
1116 zipWithAMatched :: Applicative f
1117 => (k -> x -> y -> f z)
1118 -> WhenMatched f k x y z
1119 zipWithAMatched f = WhenMatched $
1120 \ k x y -> (Just $!) <$> f k x y
1121 {-# INLINE zipWithAMatched #-}
1122
1123 -- | When a key is found in both maps, apply a function to the
1124 -- key and values and use the result in the merged map.
1125 --
1126 -- @
1127 -- zipWithMatched :: (k -> x -> y -> z)
1128 -- -> SimpleWhenMatched k x y z
1129 -- @
1130 zipWithMatched :: Applicative f
1131 => (k -> x -> y -> z) -> WhenMatched f k x y z
1132 zipWithMatched f = WhenMatched $
1133 \k x y -> pure $! Just $! f k x y
1134 {-# INLINE zipWithMatched #-}
1135
1136 -- | Map over the entries whose keys are missing from the other map,
1137 -- optionally removing some. This is the most powerful 'SimpleWhenMissing'
1138 -- tactic, but others are usually more efficient.
1139 --
1140 -- @
1141 -- mapMaybeMissing :: (k -> x -> Maybe y) -> SimpleWhenMissing k x y
1142 -- @
1143 --
1144 -- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))
1145 --
1146 -- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations.
1147 mapMaybeMissing :: Applicative f => (k -> x -> Maybe y) -> WhenMissing f k x y
1148 mapMaybeMissing f = WhenMissing
1149 { missingSubtree = \m -> pure $! mapMaybeWithKey f m
1150 , missingKey = \k x -> pure $! forceMaybe $! f k x }
1151 {-# INLINE mapMaybeMissing #-}
1152
1153 -- | Map over the entries whose keys are missing from the other map.
1154 --
1155 -- @
1156 -- mapMissing :: (k -> x -> y) -> SimpleWhenMissing k x y
1157 -- @
1158 --
1159 -- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)
1160 --
1161 -- but @mapMissing@ is somewhat faster.
1162 mapMissing :: Applicative f => (k -> x -> y) -> WhenMissing f k x y
1163 mapMissing f = WhenMissing
1164 { missingSubtree = \m -> pure $! mapWithKey f m
1165 , missingKey = \k x -> pure $! Just $! f k x }
1166 {-# INLINE mapMissing #-}
1167
1168 -- | Traverse over the entries whose keys are missing from the other map,
1169 -- optionally producing values to put in the result.
1170 -- This is the most powerful 'WhenMissing' tactic, but others are usually
1171 -- more efficient.
1172 traverseMaybeMissing :: Applicative f
1173 => (k -> x -> f (Maybe y)) -> WhenMissing f k x y
1174 traverseMaybeMissing f = WhenMissing
1175 { missingSubtree = traverseMaybeWithKey f
1176 , missingKey = \k x -> forceMaybe <$> f k x }
1177 {-# INLINE traverseMaybeMissing #-}
1178
1179 -- | Traverse over the entries whose keys are missing from the other map.
1180 traverseMissing :: Applicative f
1181 => (k -> x -> f y) -> WhenMissing f k x y
1182 traverseMissing f = WhenMissing
1183 { missingSubtree = traverseWithKey f
1184 , missingKey = \k x -> (Just $!) <$> f k x }
1185 {-# INLINE traverseMissing #-}
1186
1187 forceMaybe :: Maybe a -> Maybe a
1188 forceMaybe Nothing = Nothing
1189 forceMaybe m@(Just !_) = m
1190 {-# INLINE forceMaybe #-}
1191
1192 {--------------------------------------------------------------------
1193 MergeWithKey
1194 --------------------------------------------------------------------}
1195
1196 -- | /O(n+m)/. An unsafe universal combining function.
1197 --
1198 -- WARNING: This function can produce corrupt maps and its results
1199 -- may depend on the internal structures of its inputs. Users should
1200 -- prefer 'Data.Map.Strict.Merge.merge' or
1201 -- 'Data.Map.Strict.Merge.mergeA'.
1202 --
1203 -- When 'mergeWithKey' is given three arguments, it is inlined to the call
1204 -- site. You should therefore use 'mergeWithKey' only to define custom
1205 -- combining functions. For example, you could define 'unionWithKey',
1206 -- 'differenceWithKey' and 'intersectionWithKey' as
1207 --
1208 -- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2
1209 -- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2
1210 -- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2
1211 --
1212 -- When calling @'mergeWithKey' combine only1 only2@, a function combining two
1213 -- 'Map's is created, such that
1214 --
1215 -- * if a key is present in both maps, it is passed with both corresponding
1216 -- values to the @combine@ function. Depending on the result, the key is either
1217 -- present in the result with specified value, or is left out;
1218 --
1219 -- * a nonempty subtree present only in the first map is passed to @only1@ and
1220 -- the output is added to the result;
1221 --
1222 -- * a nonempty subtree present only in the second map is passed to @only2@ and
1223 -- the output is added to the result.
1224 --
1225 -- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.
1226 -- The values can be modified arbitrarily. Most common variants of @only1@ and
1227 -- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or
1228 -- @'filterWithKey' f@ could be used for any @f@.
1229
1230 mergeWithKey :: Ord k
1231 => (k -> a -> b -> Maybe c)
1232 -> (Map k a -> Map k c)
1233 -> (Map k b -> Map k c)
1234 -> Map k a -> Map k b -> Map k c
1235 mergeWithKey f g1 g2 = go
1236 where
1237 go Tip t2 = g2 t2
1238 go t1 Tip = g1 t1
1239 go (Bin _ kx x l1 r1) t2 =
1240 case found of
1241 Nothing -> case g1 (singleton kx x) of
1242 Tip -> link2 l' r'
1243 (Bin _ _ x' Tip Tip) -> link kx x' l' r'
1244 _ -> error "mergeWithKey: Given function only1 does not fulfill required conditions (see documentation)"
1245 Just x2 -> case f kx x x2 of
1246 Nothing -> link2 l' r'
1247 Just x' -> link kx x' l' r'
1248 where
1249 (l2, found, r2) = splitLookup kx t2
1250 l' = go l1 l2
1251 r' = go r1 r2
1252 {-# INLINE mergeWithKey #-}
1253
1254 {--------------------------------------------------------------------
1255 Filter and partition
1256 --------------------------------------------------------------------}
1257
1258 -- | /O(n)/. Map values and collect the 'Just' results.
1259 --
1260 -- > let f x = if x == "a" then Just "new a" else Nothing
1261 -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"
1262
1263 mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b
1264 mapMaybe f = mapMaybeWithKey (\_ x -> f x)
1265
1266 -- | /O(n)/. Map keys\/values and collect the 'Just' results.
1267 --
1268 -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing
1269 -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"
1270
1271 mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b
1272 mapMaybeWithKey _ Tip = Tip
1273 mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of
1274 Just y -> y `seq` link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)
1275 Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r)
1276
1277 -- | /O(n)/. Traverse keys\/values and collect the 'Just' results.
1278
1279 traverseMaybeWithKey :: Applicative f
1280 => (k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)
1281 traverseMaybeWithKey = go
1282 where
1283 go _ Tip = pure Tip
1284 go f (Bin _ kx x Tip Tip) = maybe Tip (\ !x' -> Bin 1 kx x' Tip Tip) <$> f kx x
1285 go f (Bin _ kx x l r) = combine <$> go f l <*> f kx x <*> go f r
1286 where
1287 combine !l' mx !r' = case mx of
1288 Nothing -> link2 l' r'
1289 Just !x' -> link kx x' l' r'
1290
1291 -- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
1292 --
1293 -- > let f a = if a < "c" then Left a else Right a
1294 -- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1295 -- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])
1296 -- >
1297 -- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1298 -- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1299
1300 mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)
1301 mapEither f m
1302 = mapEitherWithKey (\_ x -> f x) m
1303
1304 -- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
1305 --
1306 -- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)
1307 -- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1308 -- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])
1309 -- >
1310 -- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
1311 -- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
1312
1313 mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)
1314 mapEitherWithKey f0 t0 = toPair $ go f0 t0
1315 where
1316 go _ Tip = (Tip :*: Tip)
1317 go f (Bin _ kx x l r) = case f kx x of
1318 Left y -> y `seq` (link kx y l1 r1 :*: link2 l2 r2)
1319 Right z -> z `seq` (link2 l1 r1 :*: link kx z l2 r2)
1320 where
1321 (l1 :*: l2) = go f l
1322 (r1 :*: r2) = go f r
1323
1324 {--------------------------------------------------------------------
1325 Mapping
1326 --------------------------------------------------------------------}
1327 -- | /O(n)/. Map a function over all values in the map.
1328 --
1329 -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
1330
1331 map :: (a -> b) -> Map k a -> Map k b
1332 map f = go
1333 where
1334 go Tip = Tip
1335 go (Bin sx kx x l r) = let !x' = f x in Bin sx kx x' (go l) (go r)
1336 -- We use `go` to let `map` inline. This is important if `f` is a constant
1337 -- function.
1338
1339 #ifdef __GLASGOW_HASKELL__
1340 {-# NOINLINE [1] map #-}
1341 {-# RULES
1342 "map/map" forall f g xs . map f (map g xs) = map (f . g) xs
1343 #-}
1344 #endif
1345 #if __GLASGOW_HASKELL__ >= 709
1346 -- Safe coercions were introduced in 7.8, but did not work well with RULES yet.
1347 {-# RULES
1348 "mapSeq/coerce" map coerce = coerce
1349 #-}
1350 #endif
1351
1352 -- | /O(n)/. Map a function over all values in the map.
1353 --
1354 -- > let f key x = (show key) ++ ":" ++ x
1355 -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
1356
1357 mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
1358 mapWithKey _ Tip = Tip
1359 mapWithKey f (Bin sx kx x l r) =
1360 let x' = f kx x
1361 in x' `seq` Bin sx kx x' (mapWithKey f l) (mapWithKey f r)
1362
1363 #ifdef __GLASGOW_HASKELL__
1364 {-# NOINLINE [1] mapWithKey #-}
1365 {-# RULES
1366 "mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =
1367 mapWithKey (\k a -> f k (g k a)) xs
1368 "mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =
1369 mapWithKey (\k a -> f k (g a)) xs
1370 "map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =
1371 mapWithKey (\k a -> f (g k a)) xs
1372 #-}
1373 #endif
1374
1375 -- | /O(n)/.
1376 -- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (\v' -> v' `seq` (k,v')) <$> f k v) ('toList' m)@
1377 -- That is, it behaves much like a regular 'traverse' except that the traversing
1378 -- function also has access to the key associated with a value and the values are
1379 -- forced before they are installed in the result map.
1380 --
1381 -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])
1382 -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing
1383 traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b)
1384 traverseWithKey f = go
1385 where
1386 go Tip = pure Tip
1387 go (Bin 1 k v _ _) = (\ !v' -> Bin 1 k v' Tip Tip) <$> f k v
1388 go (Bin s k v l r) = (\ l' !v' r' -> Bin s k v' l' r') <$> go l <*> f k v <*> go r
1389 {-# INLINE traverseWithKey #-}
1390
1391 -- | /O(n)/. The function 'mapAccum' threads an accumulating
1392 -- argument through the map in ascending order of keys.
1393 --
1394 -- > let f a b = (a ++ b, b ++ "X")
1395 -- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])
1396
1397 mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
1398 mapAccum f a m
1399 = mapAccumWithKey (\a' _ x' -> f a' x') a m
1400
1401 -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
1402 -- argument through the map in ascending order of keys.
1403 --
1404 -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")
1405 -- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])
1406
1407 mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
1408 mapAccumWithKey f a t
1409 = mapAccumL f a t
1410
1411 -- | /O(n)/. The function 'mapAccumL' threads an accumulating
1412 -- argument through the map in ascending order of keys.
1413 mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
1414 mapAccumL _ a Tip = (a,Tip)
1415 mapAccumL f a (Bin sx kx x l r) =
1416 let (a1,l') = mapAccumL f a l
1417 (a2,x') = f a1 kx x
1418 (a3,r') = mapAccumL f a2 r
1419 in x' `seq` (a3,Bin sx kx x' l' r')
1420
1421 -- | /O(n)/. The function 'mapAccumR' threads an accumulating
1422 -- argument through the map in descending order of keys.
1423 mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
1424 mapAccumRWithKey _ a Tip = (a,Tip)
1425 mapAccumRWithKey f a (Bin sx kx x l r) =
1426 let (a1,r') = mapAccumRWithKey f a r
1427 (a2,x') = f a1 kx x
1428 (a3,l') = mapAccumRWithKey f a2 l
1429 in x' `seq` (a3,Bin sx kx x' l' r')
1430
1431 -- | /O(n*log n)/.
1432 -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
1433 --
1434 -- The size of the result may be smaller if @f@ maps two or more distinct
1435 -- keys to the same new key. In this case the associated values will be
1436 -- combined using @c@.
1437 --
1438 -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"
1439 -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"
1440
1441 mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
1442 mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []
1443 #if __GLASGOW_HASKELL__
1444 {-# INLINABLE mapKeysWith #-}
1445 #endif
1446
1447 {--------------------------------------------------------------------
1448 Conversions
1449 --------------------------------------------------------------------}
1450
1451 -- | /O(n)/. Build a map from a set of keys and a function which for each key
1452 -- computes its value.
1453 --
1454 -- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]
1455 -- > fromSet undefined Data.Set.empty == empty
1456
1457 fromSet :: (k -> a) -> Set.Set k -> Map k a
1458 fromSet _ Set.Tip = Tip
1459 fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin sz x v (fromSet f l) (fromSet f r)
1460
1461 {--------------------------------------------------------------------
1462 Lists
1463 use [foldlStrict] to reduce demand on the control-stack
1464 --------------------------------------------------------------------}
1465 -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
1466 -- If the list contains more than one value for the same key, the last value
1467 -- for the key is retained.
1468 --
1469 -- If the keys of the list are ordered, linear-time implementation is used,
1470 -- with the performance equal to 'fromDistinctAscList'.
1471 --
1472 -- > fromList [] == empty
1473 -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
1474 -- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
1475
1476 -- For some reason, when 'singleton' is used in fromList or in
1477 -- create, it is not inlined, so we inline it manually.
1478 fromList :: Ord k => [(k,a)] -> Map k a
1479 fromList [] = Tip
1480 fromList [(kx, x)] = x `seq` Bin 1 kx x Tip Tip
1481 fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = x0 `seq` fromList' (Bin 1 kx0 x0 Tip Tip) xs0
1482 | otherwise = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
1483 where
1484 not_ordered _ [] = False
1485 not_ordered kx ((ky,_) : _) = kx >= ky
1486 {-# INLINE not_ordered #-}
1487
1488 fromList' t0 xs = foldlStrict ins t0 xs
1489 where ins t (k,x) = insert k x t
1490
1491 go !_ t [] = t
1492 go _ t [(kx, x)] = x `seq` insertMax kx x t
1493 go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs
1494 | otherwise = case create s xss of
1495 (r, ys, []) -> x `seq` go (s `shiftL` 1) (link kx x l r) ys
1496 (r, _, ys) -> x `seq` fromList' (link kx x l r) ys
1497
1498 -- The create is returning a triple (tree, xs, ys). Both xs and ys
1499 -- represent not yet processed elements and only one of them can be nonempty.
1500 -- If ys is nonempty, the keys in ys are not ordered with respect to tree
1501 -- and must be inserted using fromList'. Otherwise the keys have been
1502 -- ordered so far.
1503 create !_ [] = (Tip, [], [])
1504 create s xs@(xp : xss)
1505 | s == 1 = case xp of (kx, x) | not_ordered kx xss -> x `seq` (Bin 1 kx x Tip Tip, [], xss)
1506 | otherwise -> x `seq` (Bin 1 kx x Tip Tip, xss, [])
1507 | otherwise = case create (s `shiftR` 1) xs of
1508 res@(_, [], _) -> res
1509 (l, [(ky, y)], zs) -> y `seq` (insertMax ky y l, [], zs)
1510 (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)
1511 | otherwise -> case create (s `shiftR` 1) yss of
1512 (r, zs, ws) -> y `seq` (link ky y l r, zs, ws)
1513 #if __GLASGOW_HASKELL__
1514 {-# INLINABLE fromList #-}
1515 #endif
1516
1517 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
1518 --
1519 -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]
1520 -- > fromListWith (++) [] == empty
1521
1522 fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
1523 fromListWith f xs
1524 = fromListWithKey (\_ x y -> f x y) xs
1525 #if __GLASGOW_HASKELL__
1526 {-# INLINABLE fromListWith #-}
1527 #endif
1528
1529 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
1530 --
1531 -- > let f k a1 a2 = (show k) ++ a1 ++ a2
1532 -- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]
1533 -- > fromListWithKey f [] == empty
1534
1535 fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1536 fromListWithKey f xs
1537 = foldlStrict ins empty xs
1538 where
1539 ins t (k,x) = insertWithKey f k x t
1540 #if __GLASGOW_HASKELL__
1541 {-# INLINABLE fromListWithKey #-}
1542 #endif
1543
1544 {--------------------------------------------------------------------
1545 Building trees from ascending/descending lists can be done in linear time.
1546
1547 Note that if [xs] is ascending then:
1548 fromAscList xs == fromList xs
1549 fromAscListWith f xs == fromListWith f xs
1550
1551 If [xs] is descending then:
1552 fromDescList xs == fromList xs
1553 fromDescListWith f xs == fromListWith f xs
1554 --------------------------------------------------------------------}
1555
1556 -- | /O(n)/. Build a map from an ascending list in linear time.
1557 -- /The precondition (input list is ascending) is not checked./
1558 --
1559 -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
1560 -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
1561 -- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True
1562 -- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False
1563 fromAscList :: Eq k => [(k,a)] -> Map k a
1564 fromAscList xs
1565 = fromAscListWithKey (\_ x _ -> x) xs
1566 #if __GLASGOW_HASKELL__
1567 {-# INLINABLE fromAscList #-}
1568 #endif
1569
1570 -- | /O(n)/. Build a map from a descending list in linear time.
1571 -- /The precondition (input list is descending) is not checked./
1572 --
1573 -- > fromDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]
1574 -- > fromDescList [(5,"a"), (5,"b"), (3,"a")] == fromList [(3, "b"), (5, "b")]
1575 -- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True
1576 -- > valid (fromDescList [(5,"a"), (3,"b"), (5,"b")]) == False
1577 fromDescList :: Eq k => [(k,a)] -> Map k a
1578 fromDescList xs
1579 = fromDescListWithKey (\_ x _ -> x) xs
1580 #if __GLASGOW_HASKELL__
1581 {-# INLINABLE fromDescList #-}
1582 #endif
1583
1584 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
1585 -- /The precondition (input list is ascending) is not checked./
1586 --
1587 -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
1588 -- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True
1589 -- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False
1590
1591 fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
1592 fromAscListWith f xs
1593 = fromAscListWithKey (\_ x y -> f x y) xs
1594 #if __GLASGOW_HASKELL__
1595 {-# INLINABLE fromAscListWith #-}
1596 #endif
1597
1598 -- | /O(n)/. Build a map from a descending list in linear time with a combining function for equal keys.
1599 -- /The precondition (input list is descending) is not checked./
1600 --
1601 -- > fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "ba")]
1602 -- > valid (fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")]) == True
1603 -- > valid (fromDescListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False
1604
1605 fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
1606 fromDescListWith f xs
1607 = fromDescListWithKey (\_ x y -> f x y) xs
1608 #if __GLASGOW_HASKELL__
1609 {-# INLINABLE fromDescListWith #-}
1610 #endif
1611
1612 -- | /O(n)/. Build a map from an ascending list in linear time with a
1613 -- combining function for equal keys.
1614 -- /The precondition (input list is ascending) is not checked./
1615 --
1616 -- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
1617 -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]
1618 -- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True
1619 -- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False
1620
1621 fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1622 fromAscListWithKey f xs
1623 = fromDistinctAscList (combineEq f xs)
1624 where
1625 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
1626 combineEq _ xs'
1627 = case xs' of
1628 [] -> []
1629 [x] -> [x]
1630 (x:xx) -> combineEq' x xx
1631
1632 combineEq' z [] = [z]
1633 combineEq' z@(kz,zz) (x@(kx,xx):xs')
1634 | kx==kz = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs'
1635 | otherwise = z:combineEq' x xs'
1636 #if __GLASGOW_HASKELL__
1637 {-# INLINABLE fromAscListWithKey #-}
1638 #endif
1639
1640 -- | /O(n)/. Build a map from a descending list in linear time with a
1641 -- combining function for equal keys.
1642 -- /The precondition (input list is descending) is not checked./
1643 --
1644 -- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
1645 -- > fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]
1646 -- > valid (fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")]) == True
1647 -- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False
1648
1649 fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
1650 fromDescListWithKey f xs
1651 = fromDistinctDescList (combineEq f xs)
1652 where
1653 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
1654 combineEq _ xs'
1655 = case xs' of
1656 [] -> []
1657 [x] -> [x]
1658 (x:xx) -> combineEq' x xx
1659
1660 combineEq' z [] = [z]
1661 combineEq' z@(kz,zz) (x@(kx,xx):xs')
1662 | kx==kz = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs'
1663 | otherwise = z:combineEq' x xs'
1664 #if __GLASGOW_HASKELL__
1665 {-# INLINABLE fromDescListWithKey #-}
1666 #endif
1667
1668 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
1669 -- /The precondition is not checked./
1670 --
1671 -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
1672 -- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True
1673 -- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False
1674
1675 -- For some reason, when 'singleton' is used in fromDistinctAscList or in
1676 -- create, it is not inlined, so we inline it manually.
1677 fromDistinctAscList :: [(k,a)] -> Map k a
1678 fromDistinctAscList [] = Tip
1679 fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
1680 where
1681 go !_ t [] = t
1682 go s l ((kx, x) : xs) = case create s xs of
1683 (r, ys) -> x `seq` go (s `shiftL` 1) (link kx x l r) ys
1684
1685 create !_ [] = (Tip, [])
1686 create s xs@(x' : xs')
1687 | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip, xs')
1688 | otherwise = case create (s `shiftR` 1) xs of
1689 res@(_, []) -> res
1690 (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of
1691 (r, zs) -> y `seq` (link ky y l r, zs)
1692
1693 -- | /O(n)/. Build a map from a descending list of distinct elements in linear time.
1694 -- /The precondition is not checked./
1695 --
1696 -- > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]
1697 -- > valid (fromDistinctDescList [(5,"a"), (3,"b")]) == True
1698 -- > valid (fromDistinctDescList [(5,"a"), (3,"b"), (3,"a")]) == False
1699
1700 -- For some reason, when 'singleton' is used in fromDistinctDescList or in
1701 -- create, it is not inlined, so we inline it manually.
1702 fromDistinctDescList :: [(k,a)] -> Map k a
1703 fromDistinctDescList [] = Tip
1704 fromDistinctDescList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
1705 where
1706 go !_ t [] = t
1707 go s r ((kx, x) : xs) = case create s xs of
1708 (l, ys) -> x `seq` go (s `shiftL` 1) (link kx x l r) ys
1709
1710 create !_ [] = (Tip, [])
1711 create s xs@(x' : xs')
1712 | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip, xs')
1713 | otherwise = case create (s `shiftR` 1) xs of
1714 res@(_, []) -> res
1715 (r, (ky, y):ys) -> case create (s `shiftR` 1) ys of
1716 (l, zs) -> y `seq` (link ky y l r, zs)