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