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