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