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