remove foldlStrict, generalize type of unions, see #520 (#524)
[packages/containers.git] / Data / Map / Internal.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE BangPatterns #-}
3 {-# LANGUAGE PatternGuards #-}
4 #if __GLASGOW_HASKELL__
5 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
6 #endif
7 #if __GLASGOW_HASKELL__ >= 703
8 {-# LANGUAGE Trustworthy #-}
9 #endif
10 #if __GLASGOW_HASKELL__ >= 708
11 {-# LANGUAGE RoleAnnotations #-}
12 {-# LANGUAGE TypeFamilies #-}
13 #define USE_MAGIC_PROXY 1
14 #endif
15
16 #ifdef USE_MAGIC_PROXY
17 {-# LANGUAGE MagicHash #-}
18 #endif
19
20 {-# OPTIONS_HADDOCK not-home #-}
21
22 #include "containers.h"
23
24 #if !(WORD_SIZE_IN_BITS >= 61)
25 #define DEFINE_ALTERF_FALLBACK 1
26 #endif
27
28 -----------------------------------------------------------------------------
29 -- |
30 -- Module : Data.Map.Internal
31 -- Copyright : (c) Daan Leijen 2002
32 -- (c) Andriy Palamarchuk 2008
33 -- License : BSD-style
34 -- Maintainer : libraries@haskell.org
35 -- Portability : portable
36 --
37 -- = WARNING
38 --
39 -- This module is considered __internal__.
40 --
41 -- The Package Versioning Policy __does not apply__.
42 --
43 -- This contents of this module may change __in any way whatsoever__
44 -- and __without any warning__ between minor versions of this package.
45 --
46 -- Authors importing this module are expected to track development
47 -- closely.
48 --
49 -- = Description
50 --
51 -- An efficient implementation of maps from keys to values (dictionaries).
52 --
53 -- Since many function names (but not the type name) clash with
54 -- "Prelude" names, this module is usually imported @qualified@, e.g.
55 --
56 -- > import Data.Map (Map)
57 -- > import qualified Data.Map as Map
58 --
59 -- The implementation of 'Map' is based on /size balanced/ binary trees (or
60 -- trees of /bounded balance/) as described by:
61 --
62 -- * Stephen Adams, \"/Efficient sets: a balancing act/\",
63 -- Journal of Functional Programming 3(4):553-562, October 1993,
64 -- <http://www.swiss.ai.mit.edu/~adams/BB/>.
65 -- * J. Nievergelt and E.M. Reingold,
66 -- \"/Binary search trees of bounded balance/\",
67 -- SIAM journal of computing 2(1), March 1973.
68 --
69 -- Bounds for 'union', 'intersection', and 'difference' are as given
70 -- by
71 --
72 -- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,
73 -- \"/Just Join for Parallel Ordered Sets/\",
74 -- <https://arxiv.org/abs/1602.02120v3>.
75 --
76 -- Note that the implementation is /left-biased/ -- the elements of a
77 -- first argument are always preferred to the second, for example in
78 -- 'union' or 'insert'.
79 --
80 -- Operation comments contain the operation time complexity in
81 -- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.
82 --
83 -- @since 0.5.9
84 -----------------------------------------------------------------------------
85
86 -- [Note: Using INLINABLE]
87 -- ~~~~~~~~~~~~~~~~~~~~~~~
88 -- It is crucial to the performance that the functions specialize on the Ord
89 -- type when possible. GHC 7.0 and higher does this by itself when it sees th
90 -- unfolding of a function -- that is why all public functions are marked
91 -- INLINABLE (that exposes the unfolding).
92
93
94 -- [Note: Using INLINE]
95 -- ~~~~~~~~~~~~~~~~~~~~
96 -- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.
97 -- We mark the functions that just navigate down the tree (lookup, insert,
98 -- delete and similar). That navigation code gets inlined and thus specialized
99 -- when possible. There is a price to pay -- code growth. The code INLINED is
100 -- therefore only the tree navigation, all the real work (rebalancing) is not
101 -- INLINED by using a NOINLINE.
102 --
103 -- All methods marked INLINE have to be nonrecursive -- a 'go' function doing
104 -- the real work is provided.
105
106
107 -- [Note: Type of local 'go' function]
108 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
109 -- If the local 'go' function uses an Ord class, it sometimes heap-allocates
110 -- the Ord dictionary when the 'go' function does not have explicit type.
111 -- In that case we give 'go' explicit type. But this slightly decrease
112 -- performance, as the resulting 'go' function can float out to top level.
113
114
115 -- [Note: Local 'go' functions and capturing]
116 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
117 -- As opposed to Map, when 'go' function captures an argument, increased
118 -- heap-allocation can occur: sometimes in a polymorphic function, the 'go'
119 -- floats out of its enclosing function and then it heap-allocates the
120 -- dictionary and the argument. Maybe it floats out too late and strictness
121 -- analyzer cannot see that these could be passed on stack.
122 --
123
124 -- [Note: Order of constructors]
125 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
126 -- The order of constructors of Map matters when considering performance.
127 -- Currently in GHC 7.0, when type has 2 constructors, a forward conditional
128 -- jump is made when successfully matching second constructor. Successful match
129 -- of first constructor results in the forward jump not taken.
130 -- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip
131 -- improves the benchmark by up to 10% on x86.
132
133 module Data.Map.Internal (
134 -- * Map type
135 Map(..) -- instance Eq,Show,Read
136 , Size
137
138 -- * Operators
139 , (!), (!?), (\\)
140
141 -- * Query
142 , null
143 , size
144 , member
145 , notMember
146 , lookup
147 , findWithDefault
148 , lookupLT
149 , lookupGT
150 , lookupLE
151 , lookupGE
152
153 -- * Construction
154 , empty
155 , singleton
156
157 -- ** Insertion
158 , insert
159 , insertWith
160 , insertWithKey
161 , insertLookupWithKey
162
163 -- ** Delete\/Update
164 , delete
165 , adjust
166 , adjustWithKey
167 , update
168 , updateWithKey
169 , updateLookupWithKey
170 , alter
171 , alterF
172
173 -- * Combine
174
175 -- ** Union
176 , union
177 , unionWith
178 , unionWithKey
179 , unions
180 , unionsWith
181
182 -- ** Difference
183 , difference
184 , differenceWith
185 , differenceWithKey
186
187 -- ** Intersection
188 , intersection
189 , intersectionWith
190 , intersectionWithKey
191
192 -- ** General combining function
193 , SimpleWhenMissing
194 , SimpleWhenMatched
195 , runWhenMatched
196 , runWhenMissing
197 , merge
198 -- *** @WhenMatched@ tactics
199 , zipWithMaybeMatched
200 , zipWithMatched
201 -- *** @WhenMissing@ tactics
202 , mapMaybeMissing
203 , dropMissing
204 , preserveMissing
205 , mapMissing
206 , filterMissing
207
208 -- ** Applicative general combining function
209 , WhenMissing (..)
210 , WhenMatched (..)
211 , mergeA
212
213 -- *** @WhenMatched@ tactics
214 -- | The tactics described for 'merge' work for
215 -- 'mergeA' as well. Furthermore, the following
216 -- are available.
217 , zipWithMaybeAMatched
218 , zipWithAMatched
219
220 -- *** @WhenMissing@ tactics
221 -- | The tactics described for 'merge' work for
222 -- 'mergeA' as well. Furthermore, the following
223 -- are available.
224 , traverseMaybeMissing
225 , traverseMissing
226 , filterAMissing
227
228 -- ** Deprecated general combining function
229
230 , mergeWithKey
231
232 -- * Traversal
233 -- ** Map
234 , map
235 , mapWithKey
236 , traverseWithKey
237 , traverseMaybeWithKey
238 , mapAccum
239 , mapAccumWithKey
240 , mapAccumRWithKey
241 , mapKeys
242 , mapKeysWith
243 , mapKeysMonotonic
244
245 -- * Folds
246 , foldr
247 , foldl
248 , foldrWithKey
249 , foldlWithKey
250 , foldMapWithKey
251
252 -- ** Strict folds
253 , foldr'
254 , foldl'
255 , foldrWithKey'
256 , foldlWithKey'
257
258 -- * Conversion
259 , elems
260 , keys
261 , assocs
262 , keysSet
263 , fromSet
264
265 -- ** Lists
266 , toList
267 , fromList
268 , fromListWith
269 , fromListWithKey
270
271 -- ** Ordered lists
272 , toAscList
273 , toDescList
274 , fromAscList
275 , fromAscListWith
276 , fromAscListWithKey
277 , fromDistinctAscList
278 , fromDescList
279 , fromDescListWith
280 , fromDescListWithKey
281 , fromDistinctDescList
282
283 -- * Filter
284 , filter
285 , filterWithKey
286
287 , takeWhileAntitone
288 , dropWhileAntitone
289 , spanAntitone
290
291 , restrictKeys
292 , withoutKeys
293 , partition
294 , partitionWithKey
295
296 , mapMaybe
297 , mapMaybeWithKey
298 , mapEither
299 , mapEitherWithKey
300
301 , split
302 , splitLookup
303 , splitRoot
304
305 -- * Submap
306 , isSubmapOf, isSubmapOfBy
307 , isProperSubmapOf, isProperSubmapOfBy
308
309 -- * Indexed
310 , lookupIndex
311 , findIndex
312 , elemAt
313 , updateAt
314 , deleteAt
315 , take
316 , drop
317 , splitAt
318
319 -- * Min\/Max
320 , lookupMin
321 , lookupMax
322 , findMin
323 , findMax
324 , deleteMin
325 , deleteMax
326 , deleteFindMin
327 , deleteFindMax
328 , updateMin
329 , updateMax
330 , updateMinWithKey
331 , updateMaxWithKey
332 , minView
333 , maxView
334 , minViewWithKey
335 , maxViewWithKey
336
337 -- Used by the strict version
338 , AreWeStrict (..)
339 , atKeyImpl
340 #if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0)
341 , atKeyPlain
342 #endif
343 , bin
344 , balance
345 , balanceL
346 , balanceR
347 , delta
348 , insertMax
349 , link
350 , link2
351 , glue
352 , MaybeS(..)
353 , Identity(..)
354
355 -- Used by Map.Merge.Lazy
356 , mapWhenMissing
357 , mapWhenMatched
358 , lmapWhenMissing
359 , contramapFirstWhenMatched
360 , contramapSecondWhenMatched
361 , mapGentlyWhenMissing
362 , mapGentlyWhenMatched
363 ) where
364
365 #if MIN_VERSION_base(4,8,0)
366 import Data.Functor.Identity (Identity (..))
367 import Control.Applicative (liftA3)
368 #else
369 import Control.Applicative (Applicative(..), (<$>), liftA3)
370 import Data.Monoid (Monoid(..))
371 import Data.Traversable (Traversable(traverse))
372 #endif
373 #if MIN_VERSION_base(4,9,0)
374 import Data.Functor.Classes
375 import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)
376 #endif
377 import Control.Applicative (Const (..))
378 import Control.DeepSeq (NFData(rnf))
379 import Data.Bits (shiftL, shiftR)
380 import qualified Data.Foldable as Foldable
381 import Data.Foldable (Foldable())
382 import Data.Typeable
383 import Prelude hiding (lookup, map, filter, foldr, foldl, null, splitAt, take, drop)
384
385 import qualified Data.Set.Internal as Set
386 import Data.Set.Internal (Set)
387 import Utils.Containers.Internal.PtrEquality (ptrEq)
388 import Utils.Containers.Internal.StrictPair
389 import Utils.Containers.Internal.StrictMaybe
390 import Utils.Containers.Internal.BitQueue
391 #ifdef DEFINE_ALTERF_FALLBACK
392 import Utils.Containers.Internal.BitUtil (wordSize)
393 #endif
394
395 #if __GLASGOW_HASKELL__
396 import GHC.Exts (build, lazy)
397 #if !MIN_VERSION_base(4,8,0)
398 import Data.Functor ((<$))
399 #endif
400 #ifdef USE_MAGIC_PROXY
401 import GHC.Exts (Proxy#, proxy# )
402 #endif
403 #if __GLASGOW_HASKELL__ >= 708
404 import qualified GHC.Exts as GHCExts
405 #endif
406 import Text.Read hiding (lift)
407 import Data.Data
408 import qualified Control.Category as Category
409 #endif
410 #if __GLASGOW_HASKELL__ >= 708
411 import Data.Coerce
412 #endif
413
414
415 {--------------------------------------------------------------------
416 Operators
417 --------------------------------------------------------------------}
418 infixl 9 !,!?,\\ --
419
420 -- | /O(log n)/. Find the value at a key.
421 -- Calls 'error' when the element can not be found.
422 --
423 -- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map
424 -- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'
425
426 (!) :: Ord k => Map k a -> k -> a
427 (!) m k = find k m
428 #if __GLASGOW_HASKELL__
429 {-# INLINE (!) #-}
430 #endif
431
432 -- | /O(log n)/. Find the value at a key.
433 -- Returns 'Nothing' when the element can not be found.
434 --
435 -- prop> fromList [(5, 'a'), (3, 'b')] !? 1 == Nothing
436 -- prop> fromList [(5, 'a'), (3, 'b')] !? 5 == Just 'a'
437 --
438 -- @since 0.5.9
439
440 (!?) :: Ord k => Map k a -> k -> Maybe a
441 (!?) m k = lookup k m
442 #if __GLASGOW_HASKELL__
443 {-# INLINE (!?) #-}
444 #endif
445
446 -- | Same as 'difference'.
447 (\\) :: Ord k => Map k a -> Map k b -> Map k a
448 m1 \\ m2 = difference m1 m2
449 #if __GLASGOW_HASKELL__
450 {-# INLINE (\\) #-}
451 #endif
452
453 {--------------------------------------------------------------------
454 Size balanced trees.
455 --------------------------------------------------------------------}
456 -- | A Map from keys @k@ to values @a@.
457
458 -- See Note: Order of constructors
459 data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
460 | Tip
461
462 type Size = Int
463
464 #if __GLASGOW_HASKELL__ >= 708
465 type role Map nominal representational
466 #endif
467
468 instance (Ord k) => Monoid (Map k v) where
469 mempty = empty
470 mconcat = unions
471 #if !(MIN_VERSION_base(4,9,0))
472 mappend = union
473 #else
474 mappend = (<>)
475
476 instance (Ord k) => Semigroup (Map k v) where
477 (<>) = union
478 stimes = stimesIdempotentMonoid
479 #endif
480
481 #if __GLASGOW_HASKELL__
482
483 {--------------------------------------------------------------------
484 A Data instance
485 --------------------------------------------------------------------}
486
487 -- This instance preserves data abstraction at the cost of inefficiency.
488 -- We provide limited reflection services for the sake of data abstraction.
489
490 instance (Data k, Data a, Ord k) => Data (Map k a) where
491 gfoldl f z m = z fromList `f` toList m
492 toConstr _ = fromListConstr
493 gunfold k z c = case constrIndex c of
494 1 -> k (z fromList)
495 _ -> error "gunfold"
496 dataTypeOf _ = mapDataType
497 dataCast2 f = gcast2 f
498
499 fromListConstr :: Constr
500 fromListConstr = mkConstr mapDataType "fromList" [] Prefix
501
502 mapDataType :: DataType
503 mapDataType = mkDataType "Data.Map.Internal.Map" [fromListConstr]
504
505 #endif
506
507 {--------------------------------------------------------------------
508 Query
509 --------------------------------------------------------------------}
510 -- | /O(1)/. Is the map empty?
511 --
512 -- > Data.Map.null (empty) == True
513 -- > Data.Map.null (singleton 1 'a') == False
514
515 null :: Map k a -> Bool
516 null Tip = True
517 null (Bin {}) = False
518 {-# INLINE null #-}
519
520 -- | /O(1)/. The number of elements in the map.
521 --
522 -- > size empty == 0
523 -- > size (singleton 1 'a') == 1
524 -- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3
525
526 size :: Map k a -> Int
527 size Tip = 0
528 size (Bin sz _ _ _ _) = sz
529 {-# INLINE size #-}
530
531
532 -- | /O(log n)/. Lookup the value at a key in the map.
533 --
534 -- The function will return the corresponding value as @('Just' value)@,
535 -- or 'Nothing' if the key isn't in the map.
536 --
537 -- An example of using @lookup@:
538 --
539 -- > import Prelude hiding (lookup)
540 -- > import Data.Map
541 -- >
542 -- > employeeDept = fromList([("John","Sales"), ("Bob","IT")])
543 -- > deptCountry = fromList([("IT","USA"), ("Sales","France")])
544 -- > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])
545 -- >
546 -- > employeeCurrency :: String -> Maybe String
547 -- > employeeCurrency name = do
548 -- > dept <- lookup name employeeDept
549 -- > country <- lookup dept deptCountry
550 -- > lookup country countryCurrency
551 -- >
552 -- > main = do
553 -- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John"))
554 -- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete"))
555 --
556 -- The output of this program:
557 --
558 -- > John's currency: Just "Euro"
559 -- > Pete's currency: Nothing
560 lookup :: Ord k => k -> Map k a -> Maybe a
561 lookup = go
562 where
563 go !_ Tip = Nothing
564 go k (Bin _ kx x l r) = case compare k kx of
565 LT -> go k l
566 GT -> go k r
567 EQ -> Just x
568 #if __GLASGOW_HASKELL__
569 {-# INLINABLE lookup #-}
570 #else
571 {-# INLINE lookup #-}
572 #endif
573
574 -- | /O(log n)/. Is the key a member of the map? See also 'notMember'.
575 --
576 -- > member 5 (fromList [(5,'a'), (3,'b')]) == True
577 -- > member 1 (fromList [(5,'a'), (3,'b')]) == False
578 member :: Ord k => k -> Map k a -> Bool
579 member = go
580 where
581 go !_ Tip = False
582 go k (Bin _ kx _ l r) = case compare k kx of
583 LT -> go k l
584 GT -> go k r
585 EQ -> True
586 #if __GLASGOW_HASKELL__
587 {-# INLINABLE member #-}
588 #else
589 {-# INLINE member #-}
590 #endif
591
592 -- | /O(log n)/. Is the key not a member of the map? See also 'member'.
593 --
594 -- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False
595 -- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True
596
597 notMember :: Ord k => k -> Map k a -> Bool
598 notMember k m = not $ member k m
599 #if __GLASGOW_HASKELL__
600 {-# INLINABLE notMember #-}
601 #else
602 {-# INLINE notMember #-}
603 #endif
604
605 -- | /O(log n)/. Find the value at a key.
606 -- Calls 'error' when the element can not be found.
607 find :: Ord k => k -> Map k a -> a
608 find = go
609 where
610 go !_ Tip = error "Map.!: given key is not an element in the map"
611 go k (Bin _ kx x l r) = case compare k kx of
612 LT -> go k l
613 GT -> go k r
614 EQ -> x
615 #if __GLASGOW_HASKELL__
616 {-# INLINABLE find #-}
617 #else
618 {-# INLINE find #-}
619 #endif
620
621 -- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns
622 -- the value at key @k@ or returns default value @def@
623 -- when the key is not in the map.
624 --
625 -- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'
626 -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'
627 findWithDefault :: Ord k => a -> k -> Map k a -> a
628 findWithDefault = go
629 where
630 go def !_ Tip = def
631 go def k (Bin _ kx x l r) = case compare k kx of
632 LT -> go def k l
633 GT -> go def k r
634 EQ -> x
635 #if __GLASGOW_HASKELL__
636 {-# INLINABLE findWithDefault #-}
637 #else
638 {-# INLINE findWithDefault #-}
639 #endif
640
641 -- | /O(log n)/. Find largest key smaller than the given one and return the
642 -- corresponding (key, value) pair.
643 --
644 -- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing
645 -- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
646 lookupLT :: Ord k => k -> Map k v -> Maybe (k, v)
647 lookupLT = goNothing
648 where
649 goNothing !_ Tip = Nothing
650 goNothing k (Bin _ kx x l r) | k <= kx = goNothing k l
651 | otherwise = goJust k kx x r
652
653 goJust !_ kx' x' Tip = Just (kx', x')
654 goJust k kx' x' (Bin _ kx x l r) | k <= kx = goJust k kx' x' l
655 | otherwise = goJust k kx x r
656 #if __GLASGOW_HASKELL__
657 {-# INLINABLE lookupLT #-}
658 #else
659 {-# INLINE lookupLT #-}
660 #endif
661
662 -- | /O(log n)/. Find smallest key greater than the given one and return the
663 -- corresponding (key, value) pair.
664 --
665 -- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
666 -- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing
667 lookupGT :: Ord k => k -> Map k v -> Maybe (k, v)
668 lookupGT = goNothing
669 where
670 goNothing !_ Tip = Nothing
671 goNothing k (Bin _ kx x l r) | k < kx = goJust k kx x l
672 | otherwise = goNothing k r
673
674 goJust !_ kx' x' Tip = Just (kx', x')
675 goJust k kx' x' (Bin _ kx x l r) | k < kx = goJust k kx x l
676 | otherwise = goJust k kx' x' r
677 #if __GLASGOW_HASKELL__
678 {-# INLINABLE lookupGT #-}
679 #else
680 {-# INLINE lookupGT #-}
681 #endif
682
683 -- | /O(log n)/. Find largest key smaller or equal to the given one and return
684 -- the corresponding (key, value) pair.
685 --
686 -- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing
687 -- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
688 -- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
689 lookupLE :: Ord k => k -> Map k v -> Maybe (k, v)
690 lookupLE = goNothing
691 where
692 goNothing !_ Tip = Nothing
693 goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goNothing k l
694 EQ -> Just (kx, x)
695 GT -> goJust k kx x r
696
697 goJust !_ kx' x' Tip = Just (kx', x')
698 goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx' x' l
699 EQ -> Just (kx, x)
700 GT -> goJust k kx x r
701 #if __GLASGOW_HASKELL__
702 {-# INLINABLE lookupLE #-}
703 #else
704 {-# INLINE lookupLE #-}
705 #endif
706
707 -- | /O(log n)/. Find smallest key greater or equal to the given one and return
708 -- the corresponding (key, value) pair.
709 --
710 -- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')
711 -- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')
712 -- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing
713 lookupGE :: Ord k => k -> Map k v -> Maybe (k, v)
714 lookupGE = goNothing
715 where
716 goNothing !_ Tip = Nothing
717 goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l
718 EQ -> Just (kx, x)
719 GT -> goNothing k r
720
721 goJust !_ kx' x' Tip = Just (kx', x')
722 goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l
723 EQ -> Just (kx, x)
724 GT -> goJust k kx' x' r
725 #if __GLASGOW_HASKELL__
726 {-# INLINABLE lookupGE #-}
727 #else
728 {-# INLINE lookupGE #-}
729 #endif
730
731 {--------------------------------------------------------------------
732 Construction
733 --------------------------------------------------------------------}
734 -- | /O(1)/. The empty map.
735 --
736 -- > empty == fromList []
737 -- > size empty == 0
738
739 empty :: Map k a
740 empty = Tip
741 {-# INLINE empty #-}
742
743 -- | /O(1)/. A map with a single element.
744 --
745 -- > singleton 1 'a' == fromList [(1, 'a')]
746 -- > size (singleton 1 'a') == 1
747
748 singleton :: k -> a -> Map k a
749 singleton k x = Bin 1 k x Tip Tip
750 {-# INLINE singleton #-}
751
752 {--------------------------------------------------------------------
753 Insertion
754 --------------------------------------------------------------------}
755 -- | /O(log n)/. Insert a new key and value in the map.
756 -- If the key is already present in the map, the associated value is
757 -- replaced with the supplied value. 'insert' is equivalent to
758 -- @'insertWith' 'const'@.
759 --
760 -- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]
761 -- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]
762 -- > insert 5 'x' empty == singleton 5 'x'
763
764 -- See Note: Type of local 'go' function
765 -- See Note: Avoiding worker/wrapper
766 insert :: Ord k => k -> a -> Map k a -> Map k a
767 insert kx0 = go kx0 kx0
768 where
769 -- Unlike insertR, we only get sharing here
770 -- when the inserted value is at the same address
771 -- as the present value. We try anyway; this condition
772 -- seems particularly likely to occur in 'union'.
773 go :: Ord k => k -> k -> a -> Map k a -> Map k a
774 go orig !_ x Tip = singleton (lazy orig) x
775 go orig !kx x t@(Bin sz ky y l r) =
776 case compare kx ky of
777 LT | l' `ptrEq` l -> t
778 | otherwise -> balanceL ky y l' r
779 where !l' = go orig kx x l
780 GT | r' `ptrEq` r -> t
781 | otherwise -> balanceR ky y l r'
782 where !r' = go orig kx x r
783 EQ | x `ptrEq` y && (lazy orig `seq` (orig `ptrEq` ky)) -> t
784 | otherwise -> Bin sz (lazy orig) x l r
785 #if __GLASGOW_HASKELL__
786 {-# INLINABLE insert #-}
787 #else
788 {-# INLINE insert #-}
789 #endif
790
791 #ifndef __GLASGOW_HASKELL__
792 lazy :: a -> a
793 lazy a = a
794 #endif
795
796 -- [Note: Avoiding worker/wrapper]
797 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
798 -- 'insert' has to go to great lengths to get pointer equality right and
799 -- to prevent unnecessary allocation. The trouble is that GHC *really* wants
800 -- to unbox the key and throw away the boxed one. This is bad for us, because
801 -- we want to compare the pointer of the box we are given to the one already
802 -- present if they compare EQ. It's also bad for us because it leads to the
803 -- key being *reboxed* if it's actually stored in the map. Ugh! So we pass the
804 -- 'go' function *two copies* of the key we're given. One of them we use for
805 -- comparisons; the other we keep in our pocket. To prevent worker/wrapper from
806 -- messing with the copy in our pocket, we sprinkle about calls to the magical
807 -- function 'lazy'. This is all horrible, but it seems to work okay.
808
809
810 -- Insert a new key and value in the map if it is not already present.
811 -- Used by `union`.
812
813 -- See Note: Type of local 'go' function
814 -- See Note: Avoiding worker/wrapper
815 insertR :: Ord k => k -> a -> Map k a -> Map k a
816 insertR kx0 = go kx0 kx0
817 where
818 go :: Ord k => k -> k -> a -> Map k a -> Map k a
819 go orig !_ x Tip = singleton (lazy orig) x
820 go orig !kx x t@(Bin _ ky y l r) =
821 case compare kx ky of
822 LT | l' `ptrEq` l -> t
823 | otherwise -> balanceL ky y l' r
824 where !l' = go orig kx x l
825 GT | r' `ptrEq` r -> t
826 | otherwise -> balanceR ky y l r'
827 where !r' = go orig kx x r
828 EQ -> t
829 #if __GLASGOW_HASKELL__
830 {-# INLINABLE insertR #-}
831 #else
832 {-# INLINE insertR #-}
833 #endif
834
835 -- | /O(log n)/. Insert with a function, combining new value and old value.
836 -- @'insertWith' f key value mp@
837 -- will insert the pair (key, value) into @mp@ if key does
838 -- not exist in the map. If the key does exist, the function will
839 -- insert the pair @(key, f new_value old_value)@.
840 --
841 -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]
842 -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
843 -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"
844
845 insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
846 insertWith = go
847 where
848 -- We have no hope of making pointer equality tricks work
849 -- here, because lazy insertWith *always* changes the tree,
850 -- either adding a new entry or replacing an element with a
851 -- thunk.
852 go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
853 go _ !kx x Tip = singleton kx x
854 go f !kx x (Bin sy ky y l r) =
855 case compare kx ky of
856 LT -> balanceL ky y (go f kx x l) r
857 GT -> balanceR ky y l (go f kx x r)
858 EQ -> Bin sy kx (f x y) l r
859
860 #if __GLASGOW_HASKELL__
861 {-# INLINABLE insertWith #-}
862 #else
863 {-# INLINE insertWith #-}
864 #endif
865
866 -- | A helper function for 'unionWith'. When the key is already in
867 -- the map, the key is left alone, not replaced. The combining
868 -- function is flipped--it is applied to the old value and then the
869 -- new value.
870
871 insertWithR :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
872 insertWithR = go
873 where
874 go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
875 go _ !kx x Tip = singleton kx x
876 go f !kx x (Bin sy ky y l r) =
877 case compare kx ky of
878 LT -> balanceL ky y (go f kx x l) r
879 GT -> balanceR ky y l (go f kx x r)
880 EQ -> Bin sy ky (f y x) l r
881 #if __GLASGOW_HASKELL__
882 {-# INLINABLE insertWithR #-}
883 #else
884 {-# INLINE insertWithR #-}
885 #endif
886
887 -- | /O(log n)/. Insert with a function, combining key, new value and old value.
888 -- @'insertWithKey' f key value mp@
889 -- will insert the pair (key, value) into @mp@ if key does
890 -- not exist in the map. If the key does exist, the function will
891 -- insert the pair @(key,f key new_value old_value)@.
892 -- Note that the key passed to f is the same key passed to 'insertWithKey'.
893 --
894 -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
895 -- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]
896 -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
897 -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"
898
899 -- See Note: Type of local 'go' function
900 insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
901 insertWithKey = go
902 where
903 go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
904 go _ !kx x Tip = singleton kx x
905 go f kx x (Bin sy ky y l r) =
906 case compare kx ky of
907 LT -> balanceL ky y (go f kx x l) r
908 GT -> balanceR ky y l (go f kx x r)
909 EQ -> Bin sy kx (f kx x y) l r
910 #if __GLASGOW_HASKELL__
911 {-# INLINABLE insertWithKey #-}
912 #else
913 {-# INLINE insertWithKey #-}
914 #endif
915
916 -- | A helper function for 'unionWithKey'. When the key is already in
917 -- the map, the key is left alone, not replaced. The combining
918 -- function is flipped--it is applied to the old value and then the
919 -- new value.
920 insertWithKeyR :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
921 insertWithKeyR = go
922 where
923 go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
924 go _ !kx x Tip = singleton kx x
925 go f kx x (Bin sy ky y l r) =
926 case compare kx ky of
927 LT -> balanceL ky y (go f kx x l) r
928 GT -> balanceR ky y l (go f kx x r)
929 EQ -> Bin sy ky (f ky y x) l r
930 #if __GLASGOW_HASKELL__
931 {-# INLINABLE insertWithKeyR #-}
932 #else
933 {-# INLINE insertWithKeyR #-}
934 #endif
935
936 -- | /O(log n)/. Combines insert operation with old value retrieval.
937 -- The expression (@'insertLookupWithKey' f k x map@)
938 -- is a pair where the first element is equal to (@'lookup' k map@)
939 -- and the second element equal to (@'insertWithKey' f k x map@).
940 --
941 -- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value
942 -- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])
943 -- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])
944 -- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")
945 --
946 -- This is how to define @insertLookup@ using @insertLookupWithKey@:
947 --
948 -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t
949 -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])
950 -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])
951
952 -- See Note: Type of local 'go' function
953 insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a
954 -> (Maybe a, Map k a)
955 insertLookupWithKey f0 k0 x0 = toPair . go f0 k0 x0
956 where
957 go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a)
958 go _ !kx x Tip = (Nothing :*: singleton kx x)
959 go f kx x (Bin sy ky y l r) =
960 case compare kx ky of
961 LT -> let !(found :*: l') = go f kx x l
962 !t' = balanceL ky y l' r
963 in (found :*: t')
964 GT -> let !(found :*: r') = go f kx x r
965 !t' = balanceR ky y l r'
966 in (found :*: t')
967 EQ -> (Just y :*: Bin sy kx (f kx x y) l r)
968 #if __GLASGOW_HASKELL__
969 {-# INLINABLE insertLookupWithKey #-}
970 #else
971 {-# INLINE insertLookupWithKey #-}
972 #endif
973
974 {--------------------------------------------------------------------
975 Deletion
976 --------------------------------------------------------------------}
977 -- | /O(log n)/. Delete a key and its value from the map. When the key is not
978 -- a member of the map, the original map is returned.
979 --
980 -- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
981 -- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
982 -- > delete 5 empty == empty
983
984 -- See Note: Type of local 'go' function
985 delete :: Ord k => k -> Map k a -> Map k a
986 delete = go
987 where
988 go :: Ord k => k -> Map k a -> Map k a
989 go !_ Tip = Tip
990 go k t@(Bin _ kx x l r) =
991 case compare k kx of
992 LT | l' `ptrEq` l -> t
993 | otherwise -> balanceR kx x l' r
994 where !l' = go k l
995 GT | r' `ptrEq` r -> t
996 | otherwise -> balanceL kx x l r'
997 where !r' = go k r
998 EQ -> glue l r
999 #if __GLASGOW_HASKELL__
1000 {-# INLINABLE delete #-}
1001 #else
1002 {-# INLINE delete #-}
1003 #endif
1004
1005 -- | /O(log n)/. Update a value at a specific key with the result of the provided function.
1006 -- When the key is not
1007 -- a member of the map, the original map is returned.
1008 --
1009 -- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
1010 -- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
1011 -- > adjust ("new " ++) 7 empty == empty
1012
1013 adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
1014 adjust f = adjustWithKey (\_ x -> f x)
1015 #if __GLASGOW_HASKELL__
1016 {-# INLINABLE adjust #-}
1017 #else
1018 {-# INLINE adjust #-}
1019 #endif
1020
1021 -- | /O(log n)/. Adjust a value at a specific key. When the key is not
1022 -- a member of the map, the original map is returned.
1023 --
1024 -- > let f key x = (show key) ++ ":new " ++ x
1025 -- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
1026 -- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
1027 -- > adjustWithKey f 7 empty == empty
1028
1029 adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
1030 adjustWithKey = go
1031 where
1032 go :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
1033 go _ !_ Tip = Tip
1034 go f k (Bin sx kx x l r) =
1035 case compare k kx of
1036 LT -> Bin sx kx x (go f k l) r
1037 GT -> Bin sx kx x l (go f k r)
1038 EQ -> Bin sx kx (f kx x) l r
1039 #if __GLASGOW_HASKELL__
1040 {-# INLINABLE adjustWithKey #-}
1041 #else
1042 {-# INLINE adjustWithKey #-}
1043 #endif
1044
1045 -- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@
1046 -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
1047 -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
1048 --
1049 -- > let f x = if x == "a" then Just "new a" else Nothing
1050 -- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
1051 -- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
1052 -- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
1053
1054 update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
1055 update f = updateWithKey (\_ x -> f x)
1056 #if __GLASGOW_HASKELL__
1057 {-# INLINABLE update #-}
1058 #else
1059 {-# INLINE update #-}
1060 #endif
1061
1062 -- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the
1063 -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',
1064 -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound
1065 -- to the new value @y@.
1066 --
1067 -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
1068 -- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
1069 -- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
1070 -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
1071
1072 -- See Note: Type of local 'go' function
1073 updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
1074 updateWithKey = go
1075 where
1076 go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
1077 go _ !_ Tip = Tip
1078 go f k(Bin sx kx x l r) =
1079 case compare k kx of
1080 LT -> balanceR kx x (go f k l) r
1081 GT -> balanceL kx x l (go f k r)
1082 EQ -> case f kx x of
1083 Just x' -> Bin sx kx x' l r
1084 Nothing -> glue l r
1085 #if __GLASGOW_HASKELL__
1086 {-# INLINABLE updateWithKey #-}
1087 #else
1088 {-# INLINE updateWithKey #-}
1089 #endif
1090
1091 -- | /O(log n)/. Lookup and update. See also 'updateWithKey'.
1092 -- The function returns changed value, if it is updated.
1093 -- Returns the original key value if the map entry is deleted.
1094 --
1095 -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing
1096 -- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])
1097 -- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])
1098 -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
1099
1100 -- See Note: Type of local 'go' function
1101 updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
1102 updateLookupWithKey f0 k0 = toPair . go f0 k0
1103 where
1104 go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a)
1105 go _ !_ Tip = (Nothing :*: Tip)
1106 go f k (Bin sx kx x l r) =
1107 case compare k kx of
1108 LT -> let !(found :*: l') = go f k l
1109 !t' = balanceR kx x l' r
1110 in (found :*: t')
1111 GT -> let !(found :*: r') = go f k r
1112 !t' = balanceL kx x l r'
1113 in (found :*: t')
1114 EQ -> case f kx x of
1115 Just x' -> (Just x' :*: Bin sx kx x' l r)
1116 Nothing -> let !glued = glue l r
1117 in (Just x :*: glued)
1118 #if __GLASGOW_HASKELL__
1119 {-# INLINABLE updateLookupWithKey #-}
1120 #else
1121 {-# INLINE updateLookupWithKey #-}
1122 #endif
1123
1124 -- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
1125 -- 'alter' can be used to insert, delete, or update a value in a 'Map'.
1126 -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.
1127 --
1128 -- > let f _ = Nothing
1129 -- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
1130 -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
1131 -- >
1132 -- > let f _ = Just "c"
1133 -- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]
1134 -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]
1135
1136 -- See Note: Type of local 'go' function
1137 alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
1138 alter = go
1139 where
1140 go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a
1141 go f !k Tip = case f Nothing of
1142 Nothing -> Tip
1143 Just x -> singleton k x
1144
1145 go f k (Bin sx kx x l r) = case compare k kx of
1146 LT -> balance kx x (go f k l) r
1147 GT -> balance kx x l (go f k r)
1148 EQ -> case f (Just x) of
1149 Just x' -> Bin sx kx x' l r
1150 Nothing -> glue l r
1151 #if __GLASGOW_HASKELL__
1152 {-# INLINABLE alter #-}
1153 #else
1154 {-# INLINE alter #-}
1155 #endif
1156
1157 -- Used to choose the appropriate alterF implementation.
1158 data AreWeStrict = Strict | Lazy
1159
1160 -- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at
1161 -- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete,
1162 -- or update a value in a 'Map'. In short: @'lookup' k \<$\> 'alterF' f k m = f
1163 -- ('lookup' k m)@.
1164 --
1165 -- Example:
1166 --
1167 -- @
1168 -- interactiveAlter :: Int -> Map Int String -> IO (Map Int String)
1169 -- interactiveAlter k m = alterF f k m where
1170 -- f Nothing -> do
1171 -- putStrLn $ show k ++
1172 -- " was not found in the map. Would you like to add it?"
1173 -- getUserResponse1 :: IO (Maybe String)
1174 -- f (Just old) -> do
1175 -- putStrLn "The key is currently bound to " ++ show old ++
1176 -- ". Would you like to change or delete it?"
1177 -- getUserresponse2 :: IO (Maybe String)
1178 -- @
1179 --
1180 -- 'alterF' is the most general operation for working with an individual
1181 -- key that may or may not be in a given map. When used with trivial
1182 -- functors like 'Identity' and 'Const', it is often slightly slower than
1183 -- more specialized combinators like 'lookup' and 'insert'. However, when
1184 -- the functor is non-trivial and key comparison is not particularly cheap,
1185 -- it is the fastest way.
1186 --
1187 -- Note on rewrite rules:
1188 --
1189 -- This module includes GHC rewrite rules to optimize 'alterF' for
1190 -- the 'Const' and 'Identity' functors. In general, these rules
1191 -- improve performance. The sole exception is that when using
1192 -- 'Identity', deleting a key that is already absent takes longer
1193 -- than it would without the rules. If you expect this to occur
1194 -- a very large fraction of the time, you might consider using a
1195 -- private copy of the 'Identity' type.
1196 --
1197 -- Note: 'alterF' is a flipped version of the 'at' combinator from
1198 -- 'Control.Lens.At'.
1199 --
1200 -- @since 0.5.8
1201 alterF :: (Functor f, Ord k)
1202 => (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
1203 alterF f k m = atKeyImpl Lazy k f m
1204
1205 #ifndef __GLASGOW_HASKELL__
1206 {-# INLINE alterF #-}
1207 #else
1208 {-# INLINABLE [2] alterF #-}
1209
1210 -- We can save a little time by recognizing the special case of
1211 -- `Control.Applicative.Const` and just doing a lookup.
1212 {-# RULES
1213 "alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m
1214 #-}
1215
1216 #if MIN_VERSION_base(4,8,0)
1217 -- base 4.8 and above include Data.Functor.Identity, so we can
1218 -- save a pretty decent amount of time by handling it specially.
1219 {-# RULES
1220 "alterF/Identity" forall k f . alterF f k = atKeyIdentity k f
1221 #-}
1222 #endif
1223 #endif
1224
1225 atKeyImpl :: (Functor f, Ord k) =>
1226 AreWeStrict -> k -> (Maybe a -> f (Maybe a)) -> Map k a -> f (Map k a)
1227 #ifdef DEFINE_ALTERF_FALLBACK
1228 atKeyImpl strict !k f m
1229 -- It doesn't seem sensible to worry about overflowing the queue
1230 -- if the word size is 61 or more. If I calculate it correctly,
1231 -- that would take a map with nearly a quadrillion entries.
1232 | wordSize < 61 && size m >= alterFCutoff = alterFFallback strict k f m
1233 #endif
1234 atKeyImpl strict !k f m = case lookupTrace k m of
1235 TraceResult mv q -> (<$> f mv) $ \ fres ->
1236 case fres of
1237 Nothing -> case mv of
1238 Nothing -> m
1239 Just old -> deleteAlong old q m
1240 Just new -> case strict of
1241 Strict -> new `seq` case mv of
1242 Nothing -> insertAlong q k new m
1243 Just _ -> replaceAlong q new m
1244 Lazy -> case mv of
1245 Nothing -> insertAlong q k new m
1246 Just _ -> replaceAlong q new m
1247
1248 {-# INLINE atKeyImpl #-}
1249
1250 #ifdef DEFINE_ALTERF_FALLBACK
1251 alterFCutoff :: Int
1252 #if WORD_SIZE_IN_BITS == 32
1253 alterFCutoff = 55744454
1254 #else
1255 alterFCutoff = case wordSize of
1256 30 -> 17637893
1257 31 -> 31356255
1258 32 -> 55744454
1259 x -> (4^(x*2-2)) `quot` (3^(x*2-2)) -- Unlikely
1260 #endif
1261 #endif
1262
1263 data TraceResult a = TraceResult (Maybe a) {-# UNPACK #-} !BitQueue
1264
1265 -- Look up a key and return a result indicating whether it was found
1266 -- and what path was taken.
1267 lookupTrace :: Ord k => k -> Map k a -> TraceResult a
1268 lookupTrace = go emptyQB
1269 where
1270 go :: Ord k => BitQueueB -> k -> Map k a -> TraceResult a
1271 go !q !_ Tip = TraceResult Nothing (buildQ q)
1272 go q k (Bin _ kx x l r) = case compare k kx of
1273 LT -> (go $! q `snocQB` False) k l
1274 GT -> (go $! q `snocQB` True) k r
1275 EQ -> TraceResult (Just x) (buildQ q)
1276
1277 -- GHC 7.8 doesn't manage to unbox the queue properly
1278 -- unless we explicitly inline this function. This stuff
1279 -- is a bit touchy, unfortunately.
1280 #if __GLASGOW_HASKELL__ >= 710
1281 {-# INLINABLE lookupTrace #-}
1282 #else
1283 {-# INLINE lookupTrace #-}
1284 #endif
1285
1286 -- Insert at a location (which will always be a leaf)
1287 -- described by the path passed in.
1288 insertAlong :: BitQueue -> k -> a -> Map k a -> Map k a
1289 insertAlong !_ kx x Tip = singleton kx x
1290 insertAlong q kx x (Bin sz ky y l r) =
1291 case unconsQ q of
1292 Just (False, tl) -> balanceL ky y (insertAlong tl kx x l) r
1293 Just (True,tl) -> balanceR ky y l (insertAlong tl kx x r)
1294 Nothing -> Bin sz kx x l r -- Shouldn't happen
1295
1296 -- Delete from a location (which will always be a node)
1297 -- described by the path passed in.
1298 --
1299 -- This is fairly horrifying! We don't actually have any
1300 -- use for the old value we're deleting. But if GHC sees
1301 -- that, then it will allocate a thunk representing the
1302 -- Map with the key deleted before we have any reason to
1303 -- believe we'll actually want that. This transformation
1304 -- enhances sharing, but we don't care enough about that.
1305 -- So deleteAlong needs to take the old value, and we need
1306 -- to convince GHC somehow that it actually uses it. We
1307 -- can't NOINLINE deleteAlong, because that would prevent
1308 -- the BitQueue from being unboxed. So instead we pass the
1309 -- old value to a NOINLINE constant function and then
1310 -- convince GHC that we use the result throughout the
1311 -- computation. Doing the obvious thing and just passing
1312 -- the value itself through the recursion costs 3-4% time,
1313 -- so instead we convert the value to a magical zero-width
1314 -- proxy that's ultimately erased.
1315 deleteAlong :: any -> BitQueue -> Map k a -> Map k a
1316 deleteAlong old !q0 !m = go (bogus old) q0 m where
1317 #ifdef USE_MAGIC_PROXY
1318 go :: Proxy# () -> BitQueue -> Map k a -> Map k a
1319 #else
1320 go :: any -> BitQueue -> Map k a -> Map k a
1321 #endif
1322 go !_ !_ Tip = Tip
1323 go foom q (Bin _ ky y l r) =
1324 case unconsQ q of
1325 Just (False, tl) -> balanceR ky y (go foom tl l) r
1326 Just (True, tl) -> balanceL ky y l (go foom tl r)
1327 Nothing -> glue l r
1328
1329 #ifdef USE_MAGIC_PROXY
1330 {-# NOINLINE bogus #-}
1331 bogus :: a -> Proxy# ()
1332 bogus _ = proxy#
1333 #else
1334 -- No point hiding in this case.
1335 {-# INLINE bogus #-}
1336 bogus :: a -> a
1337 bogus a = a
1338 #endif
1339
1340 -- Replace the value found in the node described
1341 -- by the given path with a new one.
1342 replaceAlong :: BitQueue -> a -> Map k a -> Map k a
1343 replaceAlong !_ _ Tip = Tip -- Should not happen
1344 replaceAlong q x (Bin sz ky y l r) =
1345 case unconsQ q of
1346 Just (False, tl) -> Bin sz ky y (replaceAlong tl x l) r
1347 Just (True,tl) -> Bin sz ky y l (replaceAlong tl x r)
1348 Nothing -> Bin sz ky x l r
1349
1350 #if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0)
1351 atKeyIdentity :: Ord k => k -> (Maybe a -> Identity (Maybe a)) -> Map k a -> Identity (Map k a)
1352 atKeyIdentity k f t = Identity $ atKeyPlain Lazy k (coerce f) t
1353 {-# INLINABLE atKeyIdentity #-}
1354
1355 atKeyPlain :: Ord k => AreWeStrict -> k -> (Maybe a -> Maybe a) -> Map k a -> Map k a
1356 atKeyPlain strict k0 f0 t = case go k0 f0 t of
1357 AltSmaller t' -> t'
1358 AltBigger t' -> t'
1359 AltAdj t' -> t'
1360 AltSame -> t
1361 where
1362 go :: Ord k => k -> (Maybe a -> Maybe a) -> Map k a -> Altered k a
1363 go !k f Tip = case f Nothing of
1364 Nothing -> AltSame
1365 Just x -> case strict of
1366 Lazy -> AltBigger $ singleton k x
1367 Strict -> x `seq` (AltBigger $ singleton k x)
1368
1369 go k f (Bin sx kx x l r) = case compare k kx of
1370 LT -> case go k f l of
1371 AltSmaller l' -> AltSmaller $ balanceR kx x l' r
1372 AltBigger l' -> AltBigger $ balanceL kx x l' r
1373 AltAdj l' -> AltAdj $ Bin sx kx x l' r
1374 AltSame -> AltSame
1375 GT -> case go k f r of
1376 AltSmaller r' -> AltSmaller $ balanceL kx x l r'
1377 AltBigger r' -> AltBigger $ balanceR kx x l r'
1378 AltAdj r' -> AltAdj $ Bin sx kx x l r'
1379 AltSame -> AltSame
1380 EQ -> case f (Just x) of
1381 Just x' -> case strict of
1382 Lazy -> AltAdj $ Bin sx kx x' l r
1383 Strict -> x' `seq` (AltAdj $ Bin sx kx x' l r)
1384 Nothing -> AltSmaller $ glue l r
1385 {-# INLINE atKeyPlain #-}
1386
1387 data Altered k a = AltSmaller !(Map k a) | AltBigger !(Map k a) | AltAdj !(Map k a) | AltSame
1388 #endif
1389
1390 #ifdef DEFINE_ALTERF_FALLBACK
1391 -- When the map is too large to use a bit queue, we fall back to
1392 -- this much slower version which uses a more "natural" implementation
1393 -- improved with Yoneda to avoid repeated fmaps. This works okayish for
1394 -- some operations, but it's pretty lousy for lookups.
1395 alterFFallback :: (Functor f, Ord k)
1396 => AreWeStrict -> k -> (Maybe a -> f (Maybe a)) -> Map k a -> f (Map k a)
1397 alterFFallback Lazy k f t = alterFYoneda k (\m q -> q <$> f m) t id
1398 alterFFallback Strict k f t = alterFYoneda k (\m q -> q . forceMaybe <$> f m) t id
1399 where
1400 forceMaybe Nothing = Nothing
1401 forceMaybe may@(Just !_) = may
1402 {-# NOINLINE alterFFallback #-}
1403
1404 alterFYoneda :: Ord k =>
1405 k -> (Maybe a -> (Maybe a -> b) -> f b) -> Map k a -> (Map k a -> b) -> f b
1406 alterFYoneda = go
1407 where
1408 go :: Ord k =>
1409 k -> (Maybe a -> (Maybe a -> b) -> f b) -> Map k a -> (Map k a -> b) -> f b
1410 go !k f Tip g = f Nothing $ \ mx -> case mx of
1411 Nothing -> g Tip
1412 Just x -> g (singleton k x)
1413 go k f (Bin sx kx x l r) g = case compare k kx of
1414 LT -> go k f l (\m -> g (balance kx x m r))
1415 GT -> go k f r (\m -> g (balance kx x l m))
1416 EQ -> f (Just x) $ \ mx' -> case mx' of
1417 Just x' -> g (Bin sx kx x' l r)
1418 Nothing -> g (glue l r)
1419 {-# INLINE alterFYoneda #-}
1420 #endif
1421
1422 {--------------------------------------------------------------------
1423 Indexing
1424 --------------------------------------------------------------------}
1425 -- | /O(log n)/. Return the /index/ of a key, which is its zero-based index in
1426 -- the sequence sorted by keys. The index is a number from /0/ up to, but not
1427 -- including, the 'size' of the map. Calls 'error' when the key is not
1428 -- a 'member' of the map.
1429 --
1430 -- > findIndex 2 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map
1431 -- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0
1432 -- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1
1433 -- > findIndex 6 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map
1434
1435 -- See Note: Type of local 'go' function
1436 findIndex :: Ord k => k -> Map k a -> Int
1437 findIndex = go 0
1438 where
1439 go :: Ord k => Int -> k -> Map k a -> Int
1440 go !_ !_ Tip = error "Map.findIndex: element is not in the map"
1441 go idx k (Bin _ kx _ l r) = case compare k kx of
1442 LT -> go idx k l
1443 GT -> go (idx + size l + 1) k r
1444 EQ -> idx + size l
1445 #if __GLASGOW_HASKELL__
1446 {-# INLINABLE findIndex #-}
1447 #endif
1448
1449 -- | /O(log n)/. Lookup the /index/ of a key, which is its zero-based index in
1450 -- the sequence sorted by keys. The index is a number from /0/ up to, but not
1451 -- including, the 'size' of the map.
1452 --
1453 -- > isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")])) == False
1454 -- > fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) == 0
1455 -- > fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) == 1
1456 -- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")])) == False
1457
1458 -- See Note: Type of local 'go' function
1459 lookupIndex :: Ord k => k -> Map k a -> Maybe Int
1460 lookupIndex = go 0
1461 where
1462 go :: Ord k => Int -> k -> Map k a -> Maybe Int
1463 go !_ !_ Tip = Nothing
1464 go idx k (Bin _ kx _ l r) = case compare k kx of
1465 LT -> go idx k l
1466 GT -> go (idx + size l + 1) k r
1467 EQ -> Just $! idx + size l
1468 #if __GLASGOW_HASKELL__
1469 {-# INLINABLE lookupIndex #-}
1470 #endif
1471
1472 -- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based
1473 -- index in the sequence sorted by keys. If the /index/ is out of range (less
1474 -- than zero, greater or equal to 'size' of the map), 'error' is called.
1475 --
1476 -- > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b")
1477 -- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a")
1478 -- > elemAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
1479
1480 elemAt :: Int -> Map k a -> (k,a)
1481 elemAt !_ Tip = error "Map.elemAt: index out of range"
1482 elemAt i (Bin _ kx x l r)
1483 = case compare i sizeL of
1484 LT -> elemAt i l
1485 GT -> elemAt (i-sizeL-1) r
1486 EQ -> (kx,x)
1487 where
1488 sizeL = size l
1489
1490 -- | Take a given number of entries in key order, beginning
1491 -- with the smallest keys.
1492 --
1493 -- @
1494 -- take n = 'fromDistinctAscList' . 'Prelude.take' n . 'toAscList'
1495 -- @
1496 --
1497 -- @since 0.5.8
1498
1499 take :: Int -> Map k a -> Map k a
1500 take i m | i >= size m = m
1501 take i0 m0 = go i0 m0
1502 where
1503 go i !_ | i <= 0 = Tip
1504 go !_ Tip = Tip
1505 go i (Bin _ kx x l r) =
1506 case compare i sizeL of
1507 LT -> go i l
1508 GT -> link kx x l (go (i - sizeL - 1) r)
1509 EQ -> l
1510 where sizeL = size l
1511
1512 -- | Drop a given number of entries in key order, beginning
1513 -- with the smallest keys.
1514 --
1515 -- @
1516 -- drop n = 'fromDistinctAscList' . 'Prelude.drop' n . 'toAscList'
1517 -- @
1518 --
1519 -- @since 0.5.8
1520 drop :: Int -> Map k a -> Map k a
1521 drop i m | i >= size m = Tip
1522 drop i0 m0 = go i0 m0
1523 where
1524 go i m | i <= 0 = m
1525 go !_ Tip = Tip
1526 go i (Bin _ kx x l r) =
1527 case compare i sizeL of
1528 LT -> link kx x (go i l) r
1529 GT -> go (i - sizeL - 1) r
1530 EQ -> insertMin kx x r
1531 where sizeL = size l
1532
1533 -- | /O(log n)/. Split a map at a particular index.
1534 --
1535 -- @
1536 -- splitAt !n !xs = ('take' n xs, 'drop' n xs)
1537 -- @
1538 --
1539 -- @since 0.5.8
1540 splitAt :: Int -> Map k a -> (Map k a, Map k a)
1541 splitAt i0 m0
1542 | i0 >= size m0 = (m0, Tip)
1543 | otherwise = toPair $ go i0 m0
1544 where
1545 go i m | i <= 0 = Tip :*: m
1546 go !_ Tip = Tip :*: Tip
1547 go i (Bin _ kx x l r)
1548 = case compare i sizeL of
1549 LT -> case go i l of
1550 ll :*: lr -> ll :*: link kx x lr r
1551 GT -> case go (i - sizeL - 1) r of
1552 rl :*: rr -> link kx x l rl :*: rr
1553 EQ -> l :*: insertMin kx x r
1554 where sizeL = size l
1555
1556 -- | /O(log n)/. Update the element at /index/, i.e. by its zero-based index in
1557 -- the sequence sorted by keys. If the /index/ is out of range (less than zero,
1558 -- greater or equal to 'size' of the map), 'error' is called.
1559 --
1560 -- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]
1561 -- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]
1562 -- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
1563 -- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range
1564 -- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
1565 -- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
1566 -- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
1567 -- > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range
1568
1569 updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
1570 updateAt f !i t =
1571 case t of
1572 Tip -> error "Map.updateAt: index out of range"
1573 Bin sx kx x l r -> case compare i sizeL of
1574 LT -> balanceR kx x (updateAt f i l) r
1575 GT -> balanceL kx x l (updateAt f (i-sizeL-1) r)
1576 EQ -> case f kx x of
1577 Just x' -> Bin sx kx x' l r
1578 Nothing -> glue l r
1579 where
1580 sizeL = size l
1581
1582 -- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in
1583 -- the sequence sorted by keys. If the /index/ is out of range (less than zero,
1584 -- greater or equal to 'size' of the map), 'error' is called.
1585 --
1586 -- > deleteAt 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
1587 -- > deleteAt 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
1588 -- > deleteAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range
1589 -- > deleteAt (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range
1590
1591 deleteAt :: Int -> Map k a -> Map k a
1592 deleteAt !i t =
1593 case t of
1594 Tip -> error "Map.deleteAt: index out of range"
1595 Bin _ kx x l r -> case compare i sizeL of
1596 LT -> balanceR kx x (deleteAt i l) r
1597 GT -> balanceL kx x l (deleteAt (i-sizeL-1) r)
1598 EQ -> glue l r
1599 where
1600 sizeL = size l
1601
1602
1603 {--------------------------------------------------------------------
1604 Minimal, Maximal
1605 --------------------------------------------------------------------}
1606
1607 lookupMinSure :: k -> a -> Map k a -> (k, a)
1608 lookupMinSure k a Tip = (k, a)
1609 lookupMinSure _ _ (Bin _ k a l _) = lookupMinSure k a l
1610
1611 -- | /O(log n)/. The minimal key of the map. Returns 'Nothing' if the map is empty.
1612 --
1613 -- > lookupMin (fromList [(5,"a"), (3,"b")]) == Just (3,"b")
1614 -- > findMin empty = Nothing
1615 --
1616 -- @since 0.5.9
1617
1618 lookupMin :: Map k a -> Maybe (k,a)
1619 lookupMin Tip = Nothing
1620 lookupMin (Bin _ k x l _) = Just $! lookupMinSure k x l
1621
1622 -- | /O(log n)/. The minimal key of the map. Calls 'error' if the map is empty.
1623 --
1624 -- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")
1625 -- > findMin empty Error: empty map has no minimal element
1626
1627 findMin :: Map k a -> (k,a)
1628 findMin t
1629 | Just r <- lookupMin t = r
1630 | otherwise = error "Map.findMin: empty map has no minimal element"
1631
1632 -- | /O(log n)/. The maximal key of the map. Calls 'error' if the map is empty.
1633 --
1634 -- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")
1635 -- > findMax empty Error: empty map has no maximal element
1636
1637 lookupMaxSure :: k -> a -> Map k a -> (k, a)
1638 lookupMaxSure k a Tip = (k, a)
1639 lookupMaxSure _ _ (Bin _ k a _ r) = lookupMaxSure k a r
1640
1641 -- | /O(log n)/. The maximal key of the map. Returns 'Nothing' if the map is empty.
1642 --
1643 -- > lookupMax (fromList [(5,"a"), (3,"b")]) == Just (5,"a")
1644 -- > lookupMax empty = Nothing
1645 --
1646 -- @since 0.5.9
1647
1648 lookupMax :: Map k a -> Maybe (k, a)
1649 lookupMax Tip = Nothing
1650 lookupMax (Bin _ k x _ r) = Just $! lookupMaxSure k x r
1651
1652 findMax :: Map k a -> (k,a)
1653 findMax t
1654 | Just r <- lookupMax t = r
1655 | otherwise = error "Map.findMax: empty map has no maximal element"
1656
1657 -- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty.
1658 --
1659 -- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]
1660 -- > deleteMin empty == empty
1661
1662 deleteMin :: Map k a -> Map k a
1663 deleteMin (Bin _ _ _ Tip r) = r
1664 deleteMin (Bin _ kx x l r) = balanceR kx x (deleteMin l) r
1665 deleteMin Tip = Tip
1666
1667 -- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty.
1668 --
1669 -- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]
1670 -- > deleteMax empty == empty
1671
1672 deleteMax :: Map k a -> Map k a
1673 deleteMax (Bin _ _ _ l Tip) = l
1674 deleteMax (Bin _ kx x l r) = balanceL kx x l (deleteMax r)
1675 deleteMax Tip = Tip
1676
1677 -- | /O(log n)/. Update the value at the minimal key.
1678 --
1679 -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]
1680 -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
1681
1682 updateMin :: (a -> Maybe a) -> Map k a -> Map k a
1683 updateMin f m
1684 = updateMinWithKey (\_ x -> f x) m
1685
1686 -- | /O(log n)/. Update the value at the maximal key.
1687 --
1688 -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]
1689 -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
1690
1691 updateMax :: (a -> Maybe a) -> Map k a -> Map k a
1692 updateMax f m
1693 = updateMaxWithKey (\_ x -> f x) m
1694
1695
1696 -- | /O(log n)/. Update the value at the minimal key.
1697 --
1698 -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]
1699 -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
1700
1701 updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
1702 updateMinWithKey _ Tip = Tip
1703 updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of
1704 Nothing -> r
1705 Just x' -> Bin sx kx x' Tip r
1706 updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r
1707
1708 -- | /O(log n)/. Update the value at the maximal key.
1709 --
1710 -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]
1711 -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
1712
1713 updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
1714 updateMaxWithKey _ Tip = Tip
1715 updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of
1716 Nothing -> l
1717 Just x' -> Bin sx kx x' l Tip
1718 updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r)
1719
1720 -- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and
1721 -- the map stripped of that element, or 'Nothing' if passed an empty map.
1722 --
1723 -- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")
1724 -- > minViewWithKey empty == Nothing
1725
1726 minViewWithKey :: Map k a -> Maybe ((k,a), Map k a)
1727 minViewWithKey Tip = Nothing
1728 minViewWithKey (Bin _ k x l r) = Just $
1729 case minViewSure k x l r of
1730 MinView km xm t -> ((km, xm), t)
1731 -- We inline this to give GHC the best possible chance of getting
1732 -- rid of the Maybe and pair constructors, as well as the thunk under
1733 -- the Just.
1734 {-# INLINE minViewWithKey #-}
1735
1736 -- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and
1737 -- the map stripped of that element, or 'Nothing' if passed an empty map.
1738 --
1739 -- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")
1740 -- > maxViewWithKey empty == Nothing
1741
1742 maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a)
1743 maxViewWithKey Tip = Nothing
1744 maxViewWithKey (Bin _ k x l r) = Just $
1745 case maxViewSure k x l r of
1746 MaxView km xm t -> ((km, xm), t)
1747 -- See note on inlining at minViewWithKey
1748 {-# INLINE maxViewWithKey #-}
1749
1750 -- | /O(log n)/. Retrieves the value associated with minimal key of the
1751 -- map, and the map stripped of that element, or 'Nothing' if passed an
1752 -- empty map.
1753 --
1754 -- > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")
1755 -- > minView empty == Nothing
1756
1757 minView :: Map k a -> Maybe (a, Map k a)
1758 minView t = case minViewWithKey t of
1759 Nothing -> Nothing
1760 Just ~((_, x), t') -> Just (x, t')
1761
1762 -- | /O(log n)/. Retrieves the value associated with maximal key of the
1763 -- map, and the map stripped of that element, or 'Nothing' if passed an
1764 -- empty map.
1765 --
1766 -- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")
1767 -- > maxView empty == Nothing
1768
1769 maxView :: Map k a -> Maybe (a, Map k a)
1770 maxView t = case maxViewWithKey t of
1771 Nothing -> Nothing
1772 Just ~((_, x), t') -> Just (x, t')
1773
1774 {--------------------------------------------------------------------
1775 Union.
1776 --------------------------------------------------------------------}
1777 -- | The union of a list of maps:
1778 -- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).
1779 --
1780 -- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
1781 -- > == fromList [(3, "b"), (5, "a"), (7, "C")]
1782 -- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]
1783 -- > == fromList [(3, "B3"), (5, "A3"), (7, "C")]
1784
1785 unions :: (Foldable f, Ord k) => f (Map k a) -> Map k a
1786 unions ts
1787 = Foldable.foldl' union empty ts
1788 #if __GLASGOW_HASKELL__
1789 {-# INLINABLE unions #-}
1790 #endif
1791
1792 -- | The union of a list of maps, with a combining operation:
1793 -- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).
1794 --
1795 -- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]
1796 -- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]
1797
1798 unionsWith :: (Foldable f, Ord k) => (a->a->a) -> f (Map k a) -> Map k a
1799 unionsWith f ts
1800 = Foldable.foldl' (unionWith f) empty ts
1801 #if __GLASGOW_HASKELL__
1802 {-# INLINABLE unionsWith #-}
1803 #endif
1804
1805 -- | /O(m*log(n\/m + 1)), m <= n/.
1806 -- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.
1807 -- It prefers @t1@ when duplicate keys are encountered,
1808 -- i.e. (@'union' == 'unionWith' 'const'@).
1809 --
1810 -- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]
1811
1812 union :: Ord k => Map k a -> Map k a -> Map k a
1813 union t1 Tip = t1
1814 union t1 (Bin _ k x Tip Tip) = insertR k x t1
1815 union (Bin _ k x Tip Tip) t2 = insert k x t2
1816 union Tip t2 = t2
1817 union t1@(Bin _ k1 x1 l1 r1) t2 = case split k1 t2 of
1818 (l2, r2) | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1
1819 | otherwise -> link k1 x1 l1l2 r1r2
1820 where !l1l2 = union l1 l2
1821 !r1r2 = union r1 r2
1822 #if __GLASGOW_HASKELL__
1823 {-# INLINABLE union #-}
1824 #endif
1825
1826 {--------------------------------------------------------------------
1827 Union with a combining function
1828 --------------------------------------------------------------------}
1829 -- | /O(m*log(n\/m + 1)), m <= n/. Union with a combining function.
1830 --
1831 -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]
1832
1833 unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
1834 -- QuickCheck says pointer equality never happens here.
1835 unionWith _f t1 Tip = t1
1836 unionWith f t1 (Bin _ k x Tip Tip) = insertWithR f k x t1
1837 unionWith f (Bin _ k x Tip Tip) t2 = insertWith f k x t2
1838 unionWith _f Tip t2 = t2
1839 unionWith f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of
1840 (l2, mb, r2) -> case mb of
1841 Nothing -> link k1 x1 l1l2 r1r2
1842 Just x2 -> link k1 (f x1 x2) l1l2 r1r2
1843 where !l1l2 = unionWith f l1 l2
1844 !r1r2 = unionWith f r1 r2
1845 #if __GLASGOW_HASKELL__
1846 {-# INLINABLE unionWith #-}
1847 #endif
1848
1849 -- | /O(m*log(n\/m + 1)), m <= n/.
1850 -- Union with a combining function.
1851 --
1852 -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value
1853 -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
1854
1855 unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
1856 unionWithKey _f t1 Tip = t1
1857 unionWithKey f t1 (Bin _ k x Tip Tip) = insertWithKeyR f k x t1
1858 unionWithKey f (Bin _ k x Tip Tip) t2 = insertWithKey f k x t2
1859 unionWithKey _f Tip t2 = t2
1860 unionWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of
1861 (l2, mb, r2) -> case mb of
1862 Nothing -> link k1 x1 l1l2 r1r2
1863 Just x2 -> link k1 (f k1 x1 x2) l1l2 r1r2
1864 where !l1l2 = unionWithKey f l1 l2
1865 !r1r2 = unionWithKey f r1 r2
1866 #if __GLASGOW_HASKELL__
1867 {-# INLINABLE unionWithKey #-}
1868 #endif
1869
1870 {--------------------------------------------------------------------
1871 Difference
1872 --------------------------------------------------------------------}
1873
1874 -- We don't currently attempt to use any pointer equality tricks for
1875 -- 'difference'. To do so, we'd have to match on the first argument
1876 -- and split the second. Unfortunately, the proof of the time bound
1877 -- relies on doing it the way we do, and it's not clear whether that
1878 -- bound holds the other way.
1879
1880 -- | /O(m*log(n\/m + 1)), m <= n/. Difference of two maps.
1881 -- Return elements of the first map not existing in the second map.
1882 --
1883 -- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"
1884
1885 difference :: Ord k => Map k a -> Map k b -> Map k a
1886 difference Tip _ = Tip
1887 difference t1 Tip = t1
1888 difference t1 (Bin _ k _ l2 r2) = case split k t1 of
1889 (l1, r1)
1890 | size l1l2 + size r1r2 == size t1 -> t1
1891 | otherwise -> link2 l1l2 r1r2
1892 where
1893 !l1l2 = difference l1 l2
1894 !r1r2 = difference r1 r2
1895 #if __GLASGOW_HASKELL__
1896 {-# INLINABLE difference #-}
1897 #endif
1898
1899 -- | /O(m*log(n\/m + 1)), m <= n/. Remove all keys in a 'Set' from a 'Map'.
1900 --
1901 -- @
1902 -- m `'withoutKeys'` s = 'filterWithKey' (\k _ -> k `'Set.notMember'` s) m
1903 -- m `'withoutKeys'` s = m `'difference'` 'fromSet' (const ()) s
1904 -- @
1905 --
1906 -- @since 0.5.8
1907
1908 withoutKeys :: Ord k => Map k a -> Set k -> Map k a
1909 withoutKeys Tip _ = Tip
1910 withoutKeys m Set.Tip = m
1911 withoutKeys m (Set.Bin _ k ls rs) = case splitMember k m of
1912 (lm, b, rm)
1913 | not b && lm' `ptrEq` lm && rm' `ptrEq` rm -> m
1914 | otherwise -> link2 lm' rm'
1915 where
1916 !lm' = withoutKeys lm ls
1917 !rm' = withoutKeys rm rs
1918 #if __GLASGOW_HASKELL__
1919 {-# INLINABLE withoutKeys #-}
1920 #endif
1921
1922 -- | /O(n+m)/. Difference with a combining function.
1923 -- When two equal keys are
1924 -- encountered, the combining function is applied to the values of these keys.
1925 -- If it returns 'Nothing', the element is discarded (proper set difference). If
1926 -- it returns (@'Just' y@), the element is updated with a new value @y@.
1927 --
1928 -- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing
1929 -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])
1930 -- > == singleton 3 "b:B"
1931 differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
1932 differenceWith f = merge preserveMissing dropMissing $
1933 zipWithMaybeMatched (\_ x y -> f x y)
1934 #if __GLASGOW_HASKELL__
1935 {-# INLINABLE differenceWith #-}
1936 #endif
1937
1938 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
1939 -- encountered, the combining function is applied to the key and both values.
1940 -- If it returns 'Nothing', the element is discarded (proper set difference). If
1941 -- it returns (@'Just' y@), the element is updated with a new value @y@.
1942 --
1943 -- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing
1944 -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])
1945 -- > == singleton 3 "3:b|B"
1946
1947 differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
1948 differenceWithKey f =
1949 merge preserveMissing dropMissing (zipWithMaybeMatched f)
1950 #if __GLASGOW_HASKELL__
1951 {-# INLINABLE differenceWithKey #-}
1952 #endif
1953
1954
1955 {--------------------------------------------------------------------
1956 Intersection
1957 --------------------------------------------------------------------}
1958 -- | /O(m*log(n\/m + 1)), m <= n/. Intersection of two maps.
1959 -- Return data in the first map for the keys existing in both maps.
1960 -- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
1961 --
1962 -- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"
1963
1964 intersection :: Ord k => Map k a -> Map k b -> Map k a
1965 intersection Tip _ = Tip
1966 intersection _ Tip = Tip
1967 intersection t1@(Bin _ k x l1 r1) t2
1968 | mb = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1
1969 then t1
1970 else link k x l1l2 r1r2
1971 | otherwise = link2 l1l2 r1r2
1972 where
1973 !(l2, mb, r2) = splitMember k t2
1974 !l1l2 = intersection l1 l2
1975 !r1r2 = intersection r1 r2
1976 #if __GLASGOW_HASKELL__
1977 {-# INLINABLE intersection #-}
1978 #endif
1979
1980 -- | /O(m*log(n\/m + 1)), m <= n/. Restrict a 'Map' to only those keys
1981 -- found in a 'Set'.
1982 --
1983 -- @
1984 -- m `'restrictKeys'` s = 'filterWithKey' (\k _ -> k `'Set.member'` s) m
1985 -- m `'restrictKeys'` s = m `'intersect' 'fromSet' (const ()) s
1986 -- @
1987 --
1988 -- @since 0.5.8
1989 restrictKeys :: Ord k => Map k a -> Set k -> Map k a
1990 restrictKeys Tip _ = Tip
1991 restrictKeys _ Set.Tip = Tip
1992 restrictKeys m@(Bin _ k x l1 r1) s
1993 | b = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1
1994 then m
1995 else link k x l1l2 r1r2
1996 | otherwise = link2 l1l2 r1r2
1997 where
1998 !(l2, b, r2) = Set.splitMember k s
1999 !l1l2 = restrictKeys l1 l2
2000 !r1r2 = restrictKeys r1 r2
2001 #if __GLASGOW_HASKELL__
2002 {-# INLINABLE restrictKeys #-}
2003 #endif
2004
2005 -- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.
2006 --
2007 -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
2008
2009 intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c
2010 -- We have no hope of pointer equality tricks here because every single
2011 -- element in the result will be a thunk.
2012 intersectionWith _f Tip _ = Tip
2013 intersectionWith _f _ Tip = Tip
2014 intersectionWith f (Bin _ k x1 l1 r1) t2 = case mb of
2015 Just x2 -> link k (f x1 x2) l1l2 r1r2
2016 Nothing -> link2 l1l2 r1r2
2017 where
2018 !(l2, mb, r2) = splitLookup k t2
2019 !l1l2 = intersectionWith f l1 l2
2020 !r1r2 = intersectionWith f r1 r2
2021 #if __GLASGOW_HASKELL__
2022 {-# INLINABLE intersectionWith #-}
2023 #endif
2024
2025 -- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.
2026 --
2027 -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar
2028 -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"
2029
2030 intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
2031 intersectionWithKey _f Tip _ = Tip
2032 intersectionWithKey _f _ Tip = Tip
2033 intersectionWithKey f (Bin _ k x1 l1 r1) t2 = case mb of
2034 Just x2 -> link k (f k x1 x2) l1l2 r1r2
2035 Nothing -> link2 l1l2 r1r2
2036 where
2037 !(l2, mb, r2) = splitLookup k t2
2038 !l1l2 = intersectionWithKey f l1 l2
2039 !r1r2 = intersectionWithKey f r1 r2
2040 #if __GLASGOW_HASKELL__
2041 {-# INLINABLE intersectionWithKey #-}
2042 #endif
2043
2044 #if !MIN_VERSION_base (4,8,0)
2045 -- | The identity type.
2046 newtype Identity a = Identity { runIdentity :: a }
2047 #if __GLASGOW_HASKELL__ == 708
2048 instance Functor Identity where
2049 fmap = coerce
2050 instance Applicative Identity where
2051 (<*>) = coerce
2052 pure = Identity
2053 #else
2054 instance Functor Identity where
2055 fmap f (Identity a) = Identity (f a)
2056 instance Applicative Identity where
2057 Identity f <*> Identity x = Identity (f x)
2058 pure = Identity
2059 #endif
2060 #endif
2061
2062 -- | A tactic for dealing with keys present in one map but not the other in
2063 -- 'merge' or 'mergeA'.
2064 --
2065 -- A tactic of type @ WhenMissing f k x z @ is an abstract representation
2066 -- of a function of type @ k -> x -> f (Maybe z) @.
2067 --
2068 -- @since 0.5.9
2069
2070 data WhenMissing f k x y = WhenMissing
2071 { missingSubtree :: Map k x -> f (Map k y)
2072 , missingKey :: k -> x -> f (Maybe y)}
2073
2074 -- | @since 0.5.9
2075 instance (Applicative f, Monad f) => Functor (WhenMissing f k x) where
2076 fmap = mapWhenMissing
2077 {-# INLINE fmap #-}
2078
2079 -- | @since 0.5.9
2080 instance (Applicative f, Monad f)
2081 => Category.Category (WhenMissing f k) where
2082 id = preserveMissing
2083 f . g = traverseMaybeMissing $
2084 \ k x -> missingKey g k x >>= \y ->
2085 case y of
2086 Nothing -> pure Nothing
2087 Just q -> missingKey f k q
2088 {-# INLINE id #-}
2089 {-# INLINE (.) #-}
2090
2091 -- | Equivalent to @ ReaderT k (ReaderT x (MaybeT f)) @.
2092 --
2093 -- @since 0.5.9
2094 instance (Applicative f, Monad f) => Applicative (WhenMissing f k x) where
2095 pure x = mapMissing (\ _ _ -> x)
2096 f <*> g = traverseMaybeMissing $ \k x -> do
2097 res1 <- missingKey f k x
2098 case res1 of
2099 Nothing -> pure Nothing
2100 Just r -> (pure $!) . fmap r =<< missingKey g k x
2101 {-# INLINE pure #-}
2102 {-# INLINE (<*>) #-}
2103
2104 -- | Equivalent to @ ReaderT k (ReaderT x (MaybeT f)) @.
2105 --
2106 -- @since 0.5.9
2107 instance (Applicative f, Monad f) => Monad (WhenMissing f k x) where
2108 #if !MIN_VERSION_base(4,8,0)
2109 return = pure
2110 #endif
2111 m >>= f = traverseMaybeMissing $ \k x -> do
2112 res1 <- missingKey m k x
2113 case res1 of
2114 Nothing -> pure Nothing
2115 Just r -> missingKey (f r) k x
2116 {-# INLINE (>>=) #-}
2117
2118 -- | Map covariantly over a @'WhenMissing' f k x@.
2119 --
2120 -- @since 0.5.9
2121 mapWhenMissing :: (Applicative f, Monad f)
2122 => (a -> b)
2123 -> WhenMissing f k x a -> WhenMissing f k x b
2124 mapWhenMissing f t = WhenMissing
2125 { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'
2126 , missingKey = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }
2127 {-# INLINE mapWhenMissing #-}
2128
2129 -- | Map covariantly over a @'WhenMissing' f k x@, using only a 'Functor f'
2130 -- constraint.
2131 mapGentlyWhenMissing :: Functor f
2132 => (a -> b)
2133 -> WhenMissing f k x a -> WhenMissing f k x b
2134 mapGentlyWhenMissing f t = WhenMissing
2135 { missingSubtree = \m -> fmap f <$> missingSubtree t m
2136 , missingKey = \k x -> fmap f <$> missingKey t k x }
2137 {-# INLINE mapGentlyWhenMissing #-}
2138
2139 -- | Map covariantly over a @'WhenMatched' f k x@, using only a 'Functor f'
2140 -- constraint.
2141 mapGentlyWhenMatched :: Functor f
2142 => (a -> b)
2143 -> WhenMatched f k x y a -> WhenMatched f k x y b
2144 mapGentlyWhenMatched f t = zipWithMaybeAMatched $
2145 \k x y -> fmap f <$> runWhenMatched t k x y
2146 {-# INLINE mapGentlyWhenMatched #-}
2147
2148 -- | Map contravariantly over a @'WhenMissing' f k _ x@.
2149 --
2150 -- @since 0.5.9
2151 lmapWhenMissing :: (b -> a) -> WhenMissing f k a x -> WhenMissing f k b x
2152 lmapWhenMissing f t = WhenMissing
2153 { missingSubtree = \m -> missingSubtree t (fmap f m)
2154 , missingKey = \k x -> missingKey t k (f x) }
2155 {-# INLINE lmapWhenMissing #-}
2156
2157 -- | Map contravariantly over a @'WhenMatched' f k _ y z@.
2158 --
2159 -- @since 0.5.9
2160 contramapFirstWhenMatched :: (b -> a)
2161 -> WhenMatched f k a y z
2162 -> WhenMatched f k b y z
2163 contramapFirstWhenMatched f t = WhenMatched $
2164 \k x y -> runWhenMatched t k (f x) y
2165 {-# INLINE contramapFirstWhenMatched #-}
2166
2167 -- | Map contravariantly over a @'WhenMatched' f k x _ z@.
2168 --
2169 -- @since 0.5.9
2170 contramapSecondWhenMatched :: (b -> a)
2171 -> WhenMatched f k x a z
2172 -> WhenMatched f k x b z
2173 contramapSecondWhenMatched f t = WhenMatched $
2174 \k x y -> runWhenMatched t k x (f y)
2175 {-# INLINE contramapSecondWhenMatched #-}
2176
2177 -- | A tactic for dealing with keys present in one map but not the other in
2178 -- 'merge'.
2179 --
2180 -- A tactic of type @ SimpleWhenMissing k x z @ is an abstract representation
2181 -- of a function of type @ k -> x -> Maybe z @.
2182 --
2183 -- @since 0.5.9
2184 type SimpleWhenMissing = WhenMissing Identity
2185
2186 -- | A tactic for dealing with keys present in both
2187 -- maps in 'merge' or 'mergeA'.
2188 --
2189 -- A tactic of type @ WhenMatched f k x y z @ is an abstract representation
2190 -- of a function of type @ k -> x -> y -> f (Maybe z) @.
2191 --
2192 -- @since 0.5.9
2193 newtype WhenMatched f k x y z = WhenMatched
2194 { matchedKey :: k -> x -> y -> f (Maybe z) }
2195
2196 -- | Along with zipWithMaybeAMatched, witnesses the isomorphism between
2197 -- @WhenMatched f k x y z@ and @k -> x -> y -> f (Maybe z)@.
2198 --
2199 -- @since 0.5.9
2200 runWhenMatched :: WhenMatched f k x y z -> k -> x -> y -> f (Maybe z)
2201 runWhenMatched = matchedKey
2202 {-# INLINE runWhenMatched #-}
2203
2204 -- | Along with traverseMaybeMissing, witnesses the isomorphism between
2205 -- @WhenMissing f k x y@ and @k -> x -> f (Maybe y)@.
2206 --
2207 -- @since 0.5.9
2208 runWhenMissing :: WhenMissing f k x y -> k -> x -> f (Maybe y)
2209 runWhenMissing = missingKey
2210 {-# INLINE runWhenMissing #-}
2211
2212 -- | @since 0.5.9
2213 instance Functor f => Functor (WhenMatched f k x y) where
2214 fmap = mapWhenMatched
2215 {-# INLINE fmap #-}
2216
2217 -- | @since 0.5.9
2218 instance (Monad f, Applicative f) => Category.Category (WhenMatched f k x) where
2219 id = zipWithMatched (\_ _ y -> y)
2220 f . g = zipWithMaybeAMatched $
2221 \k x y -> do
2222 res <- runWhenMatched g k x y
2223 case res of
2224 Nothing -> pure Nothing
2225 Just r -> runWhenMatched f k x r
2226 {-# INLINE id #-}
2227 {-# INLINE (.) #-}
2228
2229 -- | Equivalent to @ ReaderT k (ReaderT x (ReaderT y (MaybeT f))) @
2230 --
2231 -- @since 0.5.9
2232 instance (Monad f, Applicative f) => Applicative (WhenMatched f k x y) where
2233 pure x = zipWithMatched (\_ _ _ -> x)
2234 fs <*> xs = zipWithMaybeAMatched $ \k x y -> do
2235 res <- runWhenMatched fs k x y
2236 case res of
2237 Nothing -> pure Nothing
2238 Just r -> (pure $!) . fmap r =<< runWhenMatched xs k x y
2239 {-# INLINE pure #-}
2240 {-# INLINE (<*>) #-}
2241
2242 -- | Equivalent to @ ReaderT k (ReaderT x (ReaderT y (MaybeT f))) @
2243 --
2244 -- @since 0.5.9
2245 instance (Monad f, Applicative f) => Monad (WhenMatched f k x y) where
2246 #if !MIN_VERSION_base(4,8,0)
2247 return = pure
2248 #endif
2249 m >>= f = zipWithMaybeAMatched $ \k x y -> do
2250 res <- runWhenMatched m k x y
2251 case res of
2252 Nothing -> pure Nothing
2253 Just r -> runWhenMatched (f r) k x y
2254 {-# INLINE (>>=) #-}
2255
2256 -- | Map covariantly over a @'WhenMatched' f k x y@.
2257 --
2258 -- @since 0.5.9
2259 mapWhenMatched :: Functor f
2260 => (a -> b)
2261 -> WhenMatched f k x y a
2262 -> WhenMatched f k x y b
2263 mapWhenMatched f (WhenMatched g) = WhenMatched $ \k x y -> fmap (fmap f) (g k x y)
2264 {-# INLINE mapWhenMatched #-}
2265
2266 -- | A tactic for dealing with keys present in both maps in 'merge'.
2267 --
2268 -- A tactic of type @ SimpleWhenMatched k x y z @ is an abstract representation
2269 -- of a function of type @ k -> x -> y -> Maybe z @.
2270 --
2271 -- @since 0.5.9
2272 type SimpleWhenMatched = WhenMatched Identity
2273
2274 -- | When a key is found in both maps, apply a function to the
2275 -- key and values and use the result in the merged map.
2276 --
2277 -- @
2278 -- zipWithMatched :: (k -> x -> y -> z)
2279 -- -> SimpleWhenMatched k x y z
2280 -- @
2281 --
2282 -- @since 0.5.9
2283 zipWithMatched :: Applicative f
2284 => (k -> x -> y -> z)
2285 -> WhenMatched f k x y z
2286 zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y
2287 {-# INLINE zipWithMatched #-}
2288
2289 -- | When a key is found in both maps, apply a function to the
2290 -- key and values to produce an action and use its result in the merged map.
2291 --
2292 -- @since 0.5.9
2293 zipWithAMatched :: Applicative f
2294 => (k -> x -> y -> f z)
2295 -> WhenMatched f k x y z
2296 zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y
2297 {-# INLINE zipWithAMatched #-}
2298
2299 -- | When a key is found in both maps, apply a function to the
2300 -- key and values and maybe use the result in the merged map.
2301 --
2302 -- @
2303 -- zipWithMaybeMatched :: (k -> x -> y -> Maybe z)
2304 -- -> SimpleWhenMatched k x y z
2305 -- @
2306 --
2307 -- @since 0.5.9
2308 zipWithMaybeMatched :: Applicative f
2309 => (k -> x -> y -> Maybe z)
2310 -> WhenMatched f k x y z
2311 zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y
2312 {-# INLINE zipWithMaybeMatched #-}
2313
2314 -- | When a key is found in both maps, apply a function to the
2315 -- key and values, perform the resulting action, and maybe use
2316 -- the result in the merged map.
2317 --
2318 -- This is the fundamental 'WhenMatched' tactic.
2319 --
2320 -- @since 0.5.9
2321 zipWithMaybeAMatched :: (k -> x -> y -> f (Maybe z))
2322 -> WhenMatched f k x y z
2323 zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y
2324 {-# INLINE zipWithMaybeAMatched #-}
2325
2326 -- | Drop all the entries whose keys are missing from the other
2327 -- map.
2328 --
2329 -- @
2330 -- dropMissing :: SimpleWhenMissing k x y
2331 -- @
2332 --
2333 -- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)
2334 --
2335 -- but @dropMissing@ is much faster.
2336 --
2337 -- @since 0.5.9
2338 dropMissing :: Applicative f => WhenMissing f k x y
2339 dropMissing = WhenMissing
2340 { missingSubtree = const (pure Tip)
2341 , missingKey = \_ _ -> pure Nothing }
2342 {-# INLINE dropMissing #-}
2343
2344 -- | Preserve, unchanged, the entries whose keys are missing from
2345 -- the other map.
2346 --
2347 -- @
2348 -- preserveMissing :: SimpleWhenMissing k x x
2349 -- @
2350 --
2351 -- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)
2352 --
2353 -- but @preserveMissing@ is much faster.
2354 --
2355 -- @since 0.5.9
2356 preserveMissing :: Applicative f => WhenMissing f k x x
2357 preserveMissing = WhenMissing
2358 { missingSubtree = pure
2359 , missingKey = \_ v -> pure (Just v) }
2360 {-# INLINE preserveMissing #-}
2361
2362 -- | Map over the entries whose keys are missing from the other map.
2363 --
2364 -- @
2365 -- mapMissing :: (k -> x -> y) -> SimpleWhenMissing k x y
2366 -- @
2367 --
2368 -- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)
2369 --
2370 -- but @mapMissing@ is somewhat faster.
2371 --
2372 -- @since 0.5.9
2373 mapMissing :: Applicative f => (k -> x -> y) -> WhenMissing f k x y
2374 mapMissing f = WhenMissing
2375 { missingSubtree = \m -> pure $! mapWithKey f m
2376 , missingKey = \ k x -> pure $ Just (f k x) }
2377 {-# INLINE mapMissing #-}
2378
2379 -- | Map over the entries whose keys are missing from the other map,
2380 -- optionally removing some. This is the most powerful 'SimpleWhenMissing'
2381 -- tactic, but others are usually more efficient.
2382 --
2383 -- @
2384 -- mapMaybeMissing :: (k -> x -> Maybe y) -> SimpleWhenMissing k x y
2385 -- @
2386 --
2387 -- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))
2388 --
2389 -- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations.
2390 --
2391 -- @since 0.5.9
2392 mapMaybeMissing :: Applicative f => (k -> x -> Maybe y) -> WhenMissing f k x y
2393 mapMaybeMissing f = WhenMissing
2394 { missingSubtree = \m -> pure $! mapMaybeWithKey f m
2395 , missingKey = \k x -> pure $! f k x }
2396 {-# INLINE mapMaybeMissing #-}
2397
2398 -- | Filter the entries whose keys are missing from the other map.
2399 --
2400 -- @
2401 -- filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing k x x
2402 -- @
2403 --
2404 -- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x
2405 --
2406 -- but this should be a little faster.
2407 --
2408 -- @since 0.5.9
2409 filterMissing :: Applicative f
2410 => (k -> x -> Bool) -> WhenMissing f k x x
2411 filterMissing f = WhenMissing
2412 { missingSubtree = \m -> pure $! filterWithKey f m
2413 , missingKey = \k x -> pure $! if f k x then Just x else Nothing }
2414 {-# INLINE filterMissing #-}
2415
2416 -- | Filter the entries whose keys are missing from the other map
2417 -- using some 'Applicative' action.
2418 --
2419 -- @
2420 -- filterAMissing f = Merge.Lazy.traverseMaybeMissing $
2421 -- \k x -> (\b -> guard b *> Just x) <$> f k x
2422 -- @
2423 --
2424 -- but this should be a little faster.
2425 --
2426 -- @since 0.5.9
2427 filterAMissing :: Applicative f
2428 => (k -> x -> f Bool) -> WhenMissing f k x x
2429 filterAMissing f = WhenMissing
2430 { missingSubtree = \m -> filterWithKeyA f m
2431 , missingKey = \k x -> bool Nothing (Just x) <$> f k x }
2432 {-# INLINE filterAMissing #-}
2433
2434 -- | This wasn't in Data.Bool until 4.7.0, so we define it here
2435 bool :: a -> a -> Bool -> a
2436 bool f _ False = f
2437 bool _ t True = t
2438
2439 -- | Traverse over the entries whose keys are missing from the other map.
2440 --
2441 -- @since 0.5.9
2442 traverseMissing :: Applicative f
2443 => (k -> x -> f y) -> WhenMissing f k x y
2444 traverseMissing f = WhenMissing
2445 { missingSubtree = traverseWithKey f
2446 , missingKey = \k x -> Just <$> f k x }
2447 {-# INLINE traverseMissing #-}
2448
2449 -- | Traverse over the entries whose keys are missing from the other map,
2450 -- optionally producing values to put in the result.
2451 -- This is the most powerful 'WhenMissing' tactic, but others are usually
2452 -- more efficient.
2453 --
2454 -- @since 0.5.9
2455 traverseMaybeMissing :: Applicative f
2456 => (k -> x -> f (Maybe y)) -> WhenMissing f k x y
2457 traverseMaybeMissing f = WhenMissing
2458 { missingSubtree = traverseMaybeWithKey f
2459 , missingKey = f }
2460 {-# INLINE traverseMaybeMissing #-}
2461
2462 -- | Merge two maps.
2463 --
2464 -- @merge@ takes two 'WhenMissing' tactics, a 'WhenMatched'
2465 -- tactic and two maps. It uses the tactics to merge the maps.
2466 -- Its behavior is best understood via its fundamental tactics,
2467 -- 'mapMaybeMissing' and 'zipWithMaybeMatched'.
2468 --
2469 -- Consider
2470 --
2471 -- @
2472 -- merge (mapMaybeMissing g1)
2473 -- (mapMaybeMissing g2)
2474 -- (zipWithMaybeMatched f)
2475 -- m1 m2
2476 -- @
2477 --
2478 -- Take, for example,
2479 --
2480 -- @
2481 -- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')]
2482 -- m2 = [(1, "one"), (2, "two"), (4, "three")]
2483 -- @
2484 --
2485 -- @merge@ will first ''align'' these maps by key:
2486 --
2487 -- @
2488 -- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')]
2489 -- m2 = [(1, "one"), (2, "two"), (4, "three")]
2490 -- @
2491 --
2492 -- It will then pass the individual entries and pairs of entries
2493 -- to @g1@, @g2@, or @f@ as appropriate:
2494 --
2495 -- @
2496 -- maybes = [g1 0 'a', f 1 'b' "one", g2 2 "two", g1 3 'c', f 4 'd' "three"]
2497 -- @
2498 --
2499 -- This produces a 'Maybe' for each key:
2500 --
2501 -- @
2502 -- keys = 0 1 2 3 4
2503 -- results = [Nothing, Just True, Just False, Nothing, Just True]
2504 -- @
2505 --
2506 -- Finally, the @Just@ results are collected into a map:
2507 --
2508 -- @
2509 -- return value = [(1, True), (2, False), (4, True)]
2510 -- @
2511 --
2512 -- The other tactics below are optimizations or simplifications of
2513 -- 'mapMaybeMissing' for special cases. Most importantly,
2514 --
2515 -- * 'dropMissing' drops all the keys.
2516 -- * 'preserveMissing' leaves all the entries alone.
2517 --
2518 -- When 'merge' is given three arguments, it is inlined at the call
2519 -- site. To prevent excessive inlining, you should typically use 'merge'
2520 -- to define your custom combining functions.
2521 --
2522 --
2523 -- Examples:
2524 --
2525 -- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)
2526 -- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)
2527 -- prop> differenceWith f = merge diffPreserve diffDrop f
2528 -- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing)
2529 -- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g)
2530 --
2531 -- @since 0.5.9
2532 merge :: Ord k
2533 => SimpleWhenMissing k a c -- ^ What to do with keys in @m1@ but not @m2@
2534 -> SimpleWhenMissing k b c -- ^ What to do with keys in @m2@ but not @m1@
2535 -> SimpleWhenMatched k a b c -- ^ What to do with keys in both @m1@ and @m2@
2536 -> Map k a -- ^ Map @m1@
2537 -> Map k b -- ^ Map @m2@
2538 -> Map k c
2539 merge g1 g2 f m1 m2 = runIdentity $
2540 mergeA g1 g2 f m1 m2
2541 {-# INLINE merge #-}
2542
2543 -- | An applicative version of 'merge'.
2544 --
2545 -- @mergeA@ takes two 'WhenMissing' tactics, a 'WhenMatched'
2546 -- tactic and two maps. It uses the tactics to merge the maps.
2547 -- Its behavior is best understood via its fundamental tactics,
2548 -- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.
2549 --
2550 -- Consider
2551 --
2552 -- @
2553 -- mergeA (traverseMaybeMissing g1)
2554 -- (traverseMaybeMissing g2)
2555 -- (zipWithMaybeAMatched f)
2556 -- m1 m2
2557 -- @
2558 --
2559 -- Take, for example,
2560 --
2561 -- @
2562 -- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')]
2563 -- m2 = [(1, "one"), (2, "two"), (4, "three")]
2564 -- @
2565 --
2566 -- @mergeA@ will first ''align'' these maps by key:
2567 --
2568 -- @
2569 -- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')]
2570 -- m2 = [(1, "one"), (2, "two"), (4, "three")]
2571 -- @
2572 --
2573 -- It will then pass the individual entries and pairs of entries
2574 -- to @g1@, @g2@, or @f@ as appropriate:
2575 --
2576 -- @
2577 -- actions = [g1 0 'a', f 1 'b' "one", g2 2 "two", g1 3 'c', f 4 'd' "three"]
2578 -- @
2579 --
2580 -- Next, it will perform the actions in the @actions@ list in order from
2581 -- left to right.
2582 --
2583 -- @
2584 -- keys = 0 1 2 3 4
2585 -- results = [Nothing, Just True, Just False, Nothing, Just True]
2586 -- @
2587 --
2588 -- Finally, the @Just@ results are collected into a map:
2589 --
2590 -- @
2591 -- return value = [(1, True), (2, False), (4, True)]
2592 -- @
2593 --
2594 -- The other tactics below are optimizations or simplifications of
2595 -- 'traverseMaybeMissing' for special cases. Most importantly,
2596 --
2597 -- * 'dropMissing' drops all the keys.
2598 -- * 'preserveMissing' leaves all the entries alone.
2599 -- * 'mapMaybeMissing' does not use the 'Applicative' context.
2600 --
2601 -- When 'mergeA' is given three arguments, it is inlined at the call
2602 -- site. To prevent excessive inlining, you should generally only use
2603 -- 'mergeA' to define custom combining functions.
2604 --
2605 -- @since 0.5.9
2606 mergeA
2607 :: (Applicative f, Ord k)
2608 => WhenMissing f k a c -- ^ What to do with keys in @m1@ but not @m2@
2609 -> WhenMissing f k b c -- ^ What to do with keys in @m2@ but not @m1@
2610 -> WhenMatched f k a b c -- ^ What to do with keys in both @m1@ and @m2@
2611 -> Map k a -- ^ Map @m1@
2612 -> Map k b -- ^ Map @m2@
2613 -> f (Map k c)
2614 mergeA
2615 WhenMissing{missingSubtree = g1t, missingKey = g1k}
2616 WhenMissing{missingSubtree = g2t}
2617 (WhenMatched f) = go
2618 where
2619 go t1 Tip = g1t t1
2620 go Tip t2 = g2t t2
2621 go (Bin _ kx x1 l1 r1) t2 = case splitLookup kx t2 of
2622 (l2, mx2, r2) -> case mx2 of
2623 Nothing -> liftA3 (\l' mx' r' -> maybe link2 (link kx) mx' l' r')
2624 l1l2 (g1k kx x1) r1r2
2625 Just x2 -> liftA3 (\l' mx' r' -> maybe link2 (link kx) mx' l' r')
2626 l1l2 (f kx x1 x2) r1r2
2627 where
2628 !l1l2 = go l1 l2
2629 !r1r2 = go r1 r2
2630 {-# INLINE mergeA #-}
2631
2632
2633 {--------------------------------------------------------------------
2634 MergeWithKey
2635 --------------------------------------------------------------------}
2636
2637 -- | /O(n+m)/. An unsafe general combining function.
2638 --
2639 -- WARNING: This function can produce corrupt maps and its results
2640 -- may depend on the internal structures of its inputs. Users should
2641 -- prefer 'merge' or 'mergeA'.
2642 --
2643 -- When 'mergeWithKey' is given three arguments, it is inlined to the call
2644 -- site. You should therefore use 'mergeWithKey' only to define custom
2645 -- combining functions. For example, you could define 'unionWithKey',
2646 -- 'differenceWithKey' and 'intersectionWithKey' as
2647 --
2648 -- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2
2649 -- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2
2650 -- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2
2651 --
2652 -- When calling @'mergeWithKey' combine only1 only2@, a function combining two
2653 -- 'Map's is created, such that
2654 --
2655 -- * if a key is present in both maps, it is passed with both corresponding
2656 -- values to the @combine@ function. Depending on the result, the key is either
2657 -- present in the result with specified value, or is left out;
2658 --
2659 -- * a nonempty subtree present only in the first map is passed to @only1@ and
2660 -- the output is added to the result;
2661 --
2662 -- * a nonempty subtree present only in the second map is passed to @only2@ and
2663 -- the output is added to the result.
2664 --
2665 -- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.
2666 -- The values can be modified arbitrarily. Most common variants of @only1@ and
2667 -- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@,
2668 -- @'filterWithKey' f@, or @'mapMaybeWithKey' f@ could be used for any @f@.
2669
2670 mergeWithKey :: Ord k
2671 => (k -> a -> b -> Maybe c)
2672 -> (Map k a -> Map k c)
2673 -> (Map k b -> Map k c)
2674 -> Map k a -> Map k b -> Map k c
2675 mergeWithKey f g1 g2 = go
2676 where
2677 go Tip t2 = g2 t2
2678 go t1 Tip = g1 t1
2679 go (Bin _ kx x l1 r1) t2 =
2680 case found of
2681 Nothing -> case g1 (singleton kx x) of
2682 Tip -> link2 l' r'
2683 (Bin _ _ x' Tip Tip) -> link kx x' l' r'
2684 _ -> error "mergeWithKey: Given function only1 does not fulfill required conditions (see documentation)"
2685 Just x2 -> case f kx x x2 of
2686 Nothing -> link2 l' r'
2687 Just x' -> link kx x' l' r'
2688 where
2689 (l2, found, r2) = splitLookup kx t2
2690 l' = go l1 l2
2691 r' = go r1 r2
2692 {-# INLINE mergeWithKey #-}
2693
2694 {--------------------------------------------------------------------
2695 Submap
2696 --------------------------------------------------------------------}
2697 -- | /O(m*log(n\/m + 1)), m <= n/.
2698 -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
2699 --
2700 isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
2701 isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2
2702 #if __GLASGOW_HASKELL__
2703 {-# INLINABLE isSubmapOf #-}
2704 #endif
2705
2706 {- | /O(m*log(n\/m + 1)), m <= n/.
2707 The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if
2708 all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when
2709 applied to their respective values. For example, the following
2710 expressions are all 'True':
2711
2712 > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
2713 > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
2714 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
2715
2716 But the following are all 'False':
2717
2718 > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
2719 > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
2720 > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
2721
2722
2723 -}
2724 isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool
2725 isSubmapOfBy f t1 t2
2726 = (size t1 <= size t2) && (submap' f t1 t2)
2727 #if __GLASGOW_HASKELL__
2728 {-# INLINABLE isSubmapOfBy #-}
2729 #endif
2730
2731 submap' :: Ord a => (b -> c -> Bool) -> Map a b -> Map a c -> Bool
2732 submap' _ Tip _ = True
2733 submap' _ _ Tip = False
2734 submap' f (Bin _ kx x l r) t
2735 = case found of
2736 Nothing -> False
2737 Just y -> f x y && submap' f l lt && submap' f r gt
2738 where
2739 (lt,found,gt) = splitLookup kx t
2740 #if __GLASGOW_HASKELL__
2741 {-# INLINABLE submap' #-}
2742 #endif
2743
2744 -- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal).
2745 -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
2746 isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
2747 isProperSubmapOf m1 m2
2748 = isProperSubmapOfBy (==) m1 m2
2749 #if __GLASGOW_HASKELL__
2750 {-# INLINABLE isProperSubmapOf #-}
2751 #endif
2752
2753 {- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal).
2754 The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
2755 @m1@ and @m2@ are not equal,
2756 all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
2757 applied to their respective values. For example, the following
2758 expressions are all 'True':
2759
2760 > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
2761 > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
2762
2763 But the following are all 'False':
2764
2765 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
2766 > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
2767 > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
2768
2769
2770 -}
2771 isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool
2772 isProperSubmapOfBy f t1 t2
2773 = (size t1 < size t2) && (submap' f t1 t2)
2774 #if __GLASGOW_HASKELL__
2775 {-# INLINABLE isProperSubmapOfBy #-}
2776 #endif
2777
2778 {--------------------------------------------------------------------
2779 Filter and partition
2780 --------------------------------------------------------------------}
2781 -- | /O(n)/. Filter all values that satisfy the predicate.
2782 --
2783 -- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
2784 -- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty
2785 -- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty
2786
2787 filter :: (a -> Bool) -> Map k a -> Map k a
2788 filter p m
2789 = filterWithKey (\_ x -> p x) m
2790
2791 -- | /O(n)/. Filter all keys\/values that satisfy the predicate.
2792 --
2793 -- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
2794
2795 filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a
2796 filterWithKey _ Tip = Tip
2797 filterWithKey p t@(Bin _ kx x l r)
2798 | p kx x = if pl `ptrEq` l && pr `ptrEq` r
2799 then t
2800 else link kx x pl pr
2801 | otherwise = link2 pl pr
2802 where !pl = filterWithKey p l
2803 !pr = filterWithKey p r
2804
2805 -- | /O(n)/. Filter keys and values using an 'Applicative'
2806 -- predicate.
2807 filterWithKeyA :: Applicative f => (k -> a -> f Bool) -> Map k a -> f (Map k a)
2808 filterWithKeyA _ Tip = pure Tip
2809 filterWithKeyA p t@(Bin _ kx x l r) =
2810 liftA3 combine (p kx x) (filterWithKeyA p l) (filterWithKeyA p r)
2811 where
2812 combine True pl pr
2813 | pl `ptrEq` l && pr `ptrEq` r = t
2814 | otherwise = link kx x pl pr
2815 combine False pl pr = link2 pl pr
2816
2817 -- | /O(log n)/. Take while a predicate on the keys holds.
2818 -- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,
2819 -- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.
2820 --
2821 -- @
2822 -- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList'
2823 -- takeWhileAntitone p = 'filterWithKey' (\k _ -> p k)
2824 -- @
2825 --
2826 -- @since 0.5.8
2827
2828 takeWhileAntitone :: (k -> Bool) -> Map k a -> Map k a
2829 takeWhileAntitone _ Tip = Tip
2830 takeWhileAntitone p (Bin _ kx x l r)
2831 | p kx = link kx x l (takeWhileAntitone p r)
2832 | otherwise = takeWhileAntitone p l
2833
2834 -- | /O(log n)/. Drop while a predicate on the keys holds.
2835 -- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,
2836 -- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.
2837 --
2838 -- @
2839 -- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList'
2840 -- dropWhileAntitone p = 'filterWithKey' (\k -> not (p k))
2841 -- @
2842 --
2843 -- @since 0.5.8
2844
2845 dropWhileAntitone :: (k -> Bool) -> Map k a -> Map k a
2846 dropWhileAntitone _ Tip = Tip
2847 dropWhileAntitone p (Bin _ kx x l r)
2848 | p kx = dropWhileAntitone p r
2849 | otherwise = link kx x (dropWhileAntitone p l) r
2850
2851 -- | /O(log n)/. Divide a map at the point where a predicate on the keys stops holding.
2852 -- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,
2853 -- @j \< k ==\> p j \>= p k@.
2854 --
2855 -- @
2856 -- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)
2857 -- spanAntitone p xs = partition p xs
2858 -- @
2859 --
2860 -- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map
2861 -- at some /unspecified/ point where the predicate switches from holding to not
2862 -- holding (where the predicate is seen to hold before the first key and to fail
2863 -- after the last key).
2864 --
2865 -- @since 0.5.8
2866
2867 spanAntitone :: (k -> Bool) -> Map k a -> (Map k a, Map k a)
2868 spanAntitone p0 m = toPair (go p0 m)
2869 where
2870 go _ Tip = Tip :*: Tip
2871 go p (Bin _ kx x l r)
2872 | p kx = let u :*: v = go p r in link kx x l u :*: v
2873 | otherwise = let u :*: v = go p l in u :*: link kx x v r
2874
2875 -- | /O(n)/. Partition the map according to a predicate. The first
2876 -- map contains all elements that satisfy the predicate, the second all
2877 -- elements that fail the predicate. See also 'split'.
2878 --
2879 -- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
2880 -- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
2881 -- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
2882
2883 partition :: (a -> Bool) -> Map k a -> (Map k a,Map k a)
2884 partition p m
2885 = partitionWithKey (\_ x -> p x) m
2886
2887 -- | /O(n)/. Partition the map according to a predicate. The first
2888 -- map contains all elements that satisfy the predicate, the second all
2889 -- elements that fail the predicate. See also 'split'.
2890 --
2891 -- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")
2892 -- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
2893 -- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
2894
2895 partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
2896 partitionWithKey p0 t0 = toPair $ go p0 t0
2897 where
2898 go _ Tip = (Tip :*: Tip)
2899 go p t@(Bin _ kx x l r)
2900 | p kx x = (if l1 `ptrEq` l && r1 `ptrEq` r
2901 then t
2902 else link kx x l1 r1) :*: link2 l2 r2
2903 | otherwise = link2 l1 r1 :*:
2904 (if l2 `ptrEq` l && r2 `ptrEq` r
2905 then t
2906 else link kx x l2 r2)
2907 where
2908 (l1 :*: l2) = go p l
2909 (r1 :*: r2) = go p r
2910
2911 -- | /O(n)/. Map values and collect the 'Just' results.
2912 --
2913 -- > let f x = if x == "a" then Just "new a" else Nothing
2914 -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"
2915
2916 mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b
2917 mapMaybe f = mapMaybeWithKey (\_ x -> f x)
2918
2919 -- | /O(n)/. Map keys\/values and collect the 'Just' results.
2920 --
2921 -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing
2922 -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"
2923
2924 mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b
2925 mapMaybeWithKey _ Tip = Tip
2926 mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of
2927 Just y -> link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)
2928 Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r)
2929
2930 -- | /O(n)/. Traverse keys\/values and collect the 'Just' results.
2931 --
2932 -- @since 0.5.8
2933 traverseMaybeWithKey :: Applicative f
2934 => (k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)
2935 traverseMaybeWithKey = go
2936 where
2937 go _ Tip = pure Tip
2938 go f (Bin _ kx x Tip Tip) = maybe Tip (\x' -> Bin 1 kx x' Tip Tip) <$> f kx x
2939 go f (Bin _ kx x l r) = liftA3 combine (go f l) (f kx x) (go f r)
2940 where
2941 combine !l' mx !r' = case mx of
2942 Nothing -> link2 l' r'
2943 Just x' -> link kx x' l' r'
2944
2945 -- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
2946 --
2947 -- > let f a = if a < "c" then Left a else Right a
2948 -- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
2949 -- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])
2950 -- >
2951 -- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
2952 -- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
2953
2954 mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)
2955 mapEither f m
2956 = mapEitherWithKey (\_ x -> f x) m
2957
2958 -- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
2959 --
2960 -- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)
2961 -- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
2962 -- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])
2963 -- >
2964 -- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
2965 -- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
2966
2967 mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)
2968 mapEitherWithKey f0 t0 = toPair $ go f0 t0
2969 where
2970 go _ Tip = (Tip :*: Tip)
2971 go f (Bin _ kx x l r) = case f kx x of
2972 Left y -> link kx y l1 r1 :*: link2 l2 r2
2973 Right z -> link2 l1 r1 :*: link kx z l2 r2
2974 where
2975 (l1 :*: l2) = go f l
2976 (r1 :*: r2) = go f r
2977
2978 {--------------------------------------------------------------------
2979 Mapping
2980 --------------------------------------------------------------------}
2981 -- | /O(n)/. Map a function over all values in the map.
2982 --
2983 -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
2984
2985 map :: (a -> b) -> Map k a -> Map k b
2986 map f = go where
2987 go Tip = Tip
2988 go (Bin sx kx x l r) = Bin sx kx (f x) (go l) (go r)
2989 -- We use a `go` function to allow `map` to inline. This makes
2990 -- a big difference if someone uses `map (const x) m` instead
2991 -- of `x <$ m`; it doesn't seem to do any harm.
2992
2993 #ifdef __GLASGOW_HASKELL__
2994 {-# NOINLINE [1] map #-}
2995 {-# RULES
2996 "map/map" forall f g xs . map f (map g xs) = map (f . g) xs
2997 #-}
2998 #endif
2999 #if __GLASGOW_HASKELL__ >= 709
3000 -- Safe coercions were introduced in 7.8, but did not work well with RULES yet.
3001 {-# RULES
3002 "map/coerce" map coerce = coerce
3003 #-}
3004 #endif
3005
3006 -- | /O(n)/. Map a function over all values in the map.
3007 --
3008 -- > let f key x = (show key) ++ ":" ++ x
3009 -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
3010
3011 mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
3012 mapWithKey _ Tip = Tip
3013 mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
3014
3015 #ifdef __GLASGOW_HASKELL__
3016 {-# NOINLINE [1] mapWithKey #-}
3017 {-# RULES
3018 "mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =
3019 mapWithKey (\k a -> f k (g k a)) xs
3020 "mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =
3021 mapWithKey (\k a -> f k (g a)) xs
3022 "map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =
3023 mapWithKey (\k a -> f (g k a)) xs
3024 #-}
3025 #endif
3026
3027 -- | /O(n)/.
3028 -- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@
3029 -- That is, behaves exactly like a regular 'traverse' except that the traversing
3030 -- function also has access to the key associated with a value.
3031 --
3032 -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])
3033 -- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing
3034 traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b)
3035 traverseWithKey f = go
3036 where
3037 go Tip = pure Tip
3038 go (Bin 1 k v _ _) = (\v' -> Bin 1 k v' Tip Tip) <$> f k v
3039 go (Bin s k v l r) = liftA3 (flip (Bin s k)) (go l) (f k v) (go r)
3040 {-# INLINE traverseWithKey #-}
3041
3042 -- | /O(n)/. The function 'mapAccum' threads an accumulating
3043 -- argument through the map in ascending order of keys.
3044 --
3045 -- > let f a b = (a ++ b, b ++ "X")
3046 -- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])
3047
3048 mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
3049 mapAccum f a m
3050 = mapAccumWithKey (\a' _ x' -> f a' x') a m
3051
3052 -- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating
3053 -- argument through the map in ascending order of keys.
3054 --
3055 -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")
3056 -- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])
3057
3058 mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
3059 mapAccumWithKey f a t
3060 = mapAccumL f a t
3061
3062 -- | /O(n)/. The function 'mapAccumL' threads an accumulating
3063 -- argument through the map in ascending order of keys.
3064 mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
3065 mapAccumL _ a Tip = (a,Tip)
3066 mapAccumL f a (Bin sx kx x l r) =
3067 let (a1,l') = mapAccumL f a l
3068 (a2,x') = f a1 kx x
3069 (a3,r') = mapAccumL f a2 r
3070 in (a3,Bin sx kx x' l' r')
3071
3072 -- | /O(n)/. The function 'mapAccumR' threads an accumulating
3073 -- argument through the map in descending order of keys.
3074 mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
3075 mapAccumRWithKey _ a Tip = (a,Tip)
3076 mapAccumRWithKey f a (Bin sx kx x l r) =
3077 let (a1,r') = mapAccumRWithKey f a r
3078 (a2,x') = f a1 kx x
3079 (a3,l') = mapAccumRWithKey f a2 l
3080 in (a3,Bin sx kx x' l' r')
3081
3082 -- | /O(n*log n)/.
3083 -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
3084 --
3085 -- The size of the result may be smaller if @f@ maps two or more distinct
3086 -- keys to the same new key. In this case the value at the greatest of the
3087 -- original keys is retained.
3088 --
3089 -- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")]
3090 -- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"
3091 -- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"
3092
3093 mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a
3094 mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []
3095 #if __GLASGOW_HASKELL__
3096 {-# INLINABLE mapKeys #-}
3097 #endif
3098
3099 -- | /O(n*log n)/.
3100 -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.
3101 --
3102 -- The size of the result may be smaller if @f@ maps two or more distinct
3103 -- keys to the same new key. In this case the associated values will be
3104 -- combined using @c@. The value at the greater of the two original keys
3105 -- is used as the first argument to @c@.
3106 --
3107 -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"
3108 -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"
3109
3110 mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a
3111 mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []
3112 #if __GLASGOW_HASKELL__
3113 {-# INLINABLE mapKeysWith #-}
3114 #endif
3115
3116
3117 -- | /O(n)/.
3118 -- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@
3119 -- is strictly monotonic.
3120 -- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.
3121 -- /The precondition is not checked./
3122 -- Semi-formally, we have:
3123 --
3124 -- > and [x < y ==> f x < f y | x <- ls, y <- ls]
3125 -- > ==> mapKeysMonotonic f s == mapKeys f s
3126 -- > where ls = keys s
3127 --
3128 -- This means that @f@ maps distinct original keys to distinct resulting keys.
3129 -- This function has better performance than 'mapKeys'.
3130 --
3131 -- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]
3132 -- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True
3133 -- > valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) == False
3134
3135 mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a
3136 mapKeysMonotonic _ Tip = Tip
3137 mapKeysMonotonic f (Bin sz k x l r) =
3138 Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)
3139
3140 {--------------------------------------------------------------------
3141 Folds
3142 --------------------------------------------------------------------}
3143
3144 -- | /O(n)/. Fold the values in the map using the given right-associative
3145 -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.
3146 --
3147 -- For example,
3148 --
3149 -- > elems map = foldr (:) [] map
3150 --
3151 -- > let f a len = len + (length a)
3152 -- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4
3153 foldr :: (a -> b -> b) -> b -> Map k a -> b
3154 foldr f z = go z
3155 where
3156 go z' Tip = z'
3157 go z' (Bin _ _ x l r) = go (f x (go z' r)) l
3158 {-# INLINE foldr #-}
3159
3160 -- | /O(n)/. A strict version of 'foldr'. Each application of the operator is
3161 -- evaluated before using the result in the next application. This
3162 -- function is strict in the starting value.
3163 foldr' :: (a -> b -> b) -> b -> Map k a -> b
3164 foldr' f z = go z
3165 where
3166 go !z' Tip = z'
3167 go z' (Bin _ _ x l r) = go (f x (go z' r)) l
3168 {-# INLINE foldr' #-}
3169
3170 -- | /O(n)/. Fold the values in the map using the given left-associative
3171 -- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.
3172 --
3173 -- For example,
3174 --
3175 -- > elems = reverse . foldl (flip (:)) []
3176 --
3177 -- > let f len a = len + (length a)
3178 -- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4
3179 foldl :: (a -> b -> a) -> a -> Map k b -> a
3180 foldl f z = go z
3181 where
3182 go z' Tip = z'
3183 go z' (Bin _ _ x l r) = go (f (go z' l) x) r
3184 {-# INLINE foldl #-}
3185
3186 -- | /O(n)/. A strict version of 'foldl'. Each application of the operator is
3187 -- evaluated before using the result in the next application. This
3188 -- function is strict in the starting value.
3189 foldl' :: (a -> b -> a) -> a -> Map k b -> a
3190 foldl' f z = go z
3191 where
3192 go !z' Tip = z'
3193 go z' (Bin _ _ x l r) = go (f (go z' l) x) r
3194 {-# INLINE foldl' #-}
3195
3196 -- | /O(n)/. Fold the keys and values in the map using the given right-associative
3197 -- binary operator, such that
3198 -- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
3199 --
3200 -- For example,
3201 --
3202 -- > keys map = foldrWithKey (\k x ks -> k:ks) [] map
3203 --
3204 -- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
3205 -- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"
3206 foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
3207 foldrWithKey f z = go z
3208 where
3209 go z' Tip = z'
3210 go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l
3211 {-# INLINE foldrWithKey #-}
3212
3213 -- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is
3214 -- evaluated before using the result in the next application. This
3215 -- function is strict in the starting value.
3216 foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b
3217 foldrWithKey' f z = go z
3218 where
3219 go !z' Tip = z'
3220 go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l
3221 {-# INLINE foldrWithKey' #-}
3222
3223 -- | /O(n)/. Fold the keys and values in the map using the given left-associative
3224 -- binary operator, such that
3225 -- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.
3226 --
3227 -- For example,
3228 --
3229 -- > keys = reverse . foldlWithKey (\ks k x -> k:ks) []
3230 --
3231 -- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
3232 -- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"
3233 foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a
3234 foldlWithKey f z = go z
3235 where
3236 go z' Tip = z'
3237 go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r
3238 {-# INLINE foldlWithKey #-}
3239
3240 -- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is
3241 -- evaluated before using the result in the next application. This
3242 -- function is strict in the starting value.
3243 foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a
3244 foldlWithKey' f z = go z
3245 where
3246 go !z' Tip = z'
3247 go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r
3248 {-# INLINE foldlWithKey' #-}
3249
3250 -- | /O(n)/. Fold the keys and values in the map using the given monoid, such that
3251 --
3252 -- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@
3253 --
3254 -- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.
3255 --
3256 -- @since 0.5.4
3257 foldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m
3258 foldMapWithKey f = go
3259 where
3260 go Tip = mempty
3261 go (Bin 1 k v _ _) = f k v
3262 go (Bin _ k v l r) = go l `mappend` (f k v `mappend` go r)
3263 {-# INLINE foldMapWithKey #-}
3264
3265 {--------------------------------------------------------------------
3266 List variations
3267 --------------------------------------------------------------------}
3268 -- | /O(n)/.
3269 -- Return all elements of the map in the ascending order of their keys.
3270 -- Subject to list fusion.
3271 --
3272 -- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]
3273 -- > elems empty == []
3274
3275 elems :: Map k a -> [a]
3276 elems = foldr (:) []
3277
3278 -- | /O(n)/. Return all keys of the map in ascending order. Subject to list
3279 -- fusion.
3280 --
3281 -- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]
3282 -- > keys empty == []
3283
3284 keys :: Map k a -> [k]
3285 keys = foldrWithKey (\k _ ks -> k : ks) []
3286
3287 -- | /O(n)/. An alias for 'toAscList'. Return all key\/value pairs in the map
3288 -- in ascending key order. Subject to list fusion.
3289 --
3290 -- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
3291 -- > assocs empty == []
3292
3293 assocs :: Map k a -> [(k,a)]
3294 assocs m
3295 = toAscList m
3296
3297 -- | /O(n)/. The set of all keys of the map.
3298 --
3299 -- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5]
3300 -- > keysSet empty == Data.Set.empty
3301
3302 keysSet :: Map k a -> Set.Set k
3303 keysSet Tip = Set.Tip
3304 keysSet (Bin sz kx _ l r) = Set.Bin sz kx (keysSet l) (keysSet r)
3305
3306 -- | /O(n)/. Build a map from a set of keys and a function which for each key
3307 -- computes its value.
3308 --
3309 -- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]
3310 -- > fromSet undefined Data.Set.empty == empty
3311
3312 fromSet :: (k -> a) -> Set.Set k -> Map k a
3313 fromSet _ Set.Tip = Tip
3314 fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r)
3315
3316 {--------------------------------------------------------------------
3317 Lists
3318 use [foldlStrict] to reduce demand on the control-stack
3319 --------------------------------------------------------------------}
3320 #if __GLASGOW_HASKELL__ >= 708
3321 -- | @since 0.5.6.2
3322 instance (Ord k) => GHCExts.IsList (Map k v) where
3323 type Item (Map k v) = (k,v)
3324 fromList = fromList
3325 toList = toList
3326 #endif
3327
3328 -- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
3329 -- If the list contains more than one value for the same key, the last value
3330 -- for the key is retained.
3331 --
3332 -- If the keys of the list are ordered, linear-time implementation is used,
3333 -- with the performance equal to 'fromDistinctAscList'.
3334 --
3335 -- > fromList [] == empty
3336 -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
3337 -- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
3338
3339 -- For some reason, when 'singleton' is used in fromList or in
3340 -- create, it is not inlined, so we inline it manually.
3341 fromList :: Ord k => [(k,a)] -> Map k a
3342 fromList [] = Tip
3343 fromList [(kx, x)] = Bin 1 kx x Tip Tip
3344 fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = fromList' (Bin 1 kx0 x0 Tip Tip) xs0
3345 | otherwise = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
3346 where
3347 not_ordered _ [] = False
3348 not_ordered kx ((ky,_) : _) = kx >= ky
3349 {-# INLINE not_ordered #-}
3350
3351 fromList' t0 xs = Foldable.foldl' ins t0 xs
3352 where ins t (k,x) = insert k x t
3353
3354 go !_ t [] = t
3355 go _ t [(kx, x)] = insertMax kx x t
3356 go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs
3357 | otherwise = case create s xss of
3358 (r, ys, []) -> go (s `shiftL` 1) (link kx x l r) ys
3359 (r, _, ys) -> fromList' (link kx x l r) ys
3360
3361 -- The create is returning a triple (tree, xs, ys). Both xs and ys
3362 -- represent not yet processed elements and only one of them can be nonempty.
3363 -- If ys is nonempty, the keys in ys are not ordered with respect to tree
3364 -- and must be inserted using fromList'. Otherwise the keys have been
3365 -- ordered so far.
3366 create !_ [] = (Tip, [], [])
3367 create s xs@(xp : xss)
3368 | s == 1 = case xp of (kx, x) | not_ordered kx xss -> (Bin 1 kx x Tip Tip, [], xss)
3369 | otherwise -> (Bin 1 kx x Tip Tip, xss, [])
3370 | otherwise = case create (s `shiftR` 1) xs of
3371 res@(_, [], _) -> res
3372 (l, [(ky, y)], zs) -> (insertMax ky y l, [], zs)
3373 (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)
3374 | otherwise -> case create (s `shiftR` 1) yss of
3375 (r, zs, ws) -> (link ky y l r, zs, ws)
3376 #if __GLASGOW_HASKELL__
3377 {-# INLINABLE fromList #-}
3378 #endif
3379
3380 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
3381 --
3382 -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]
3383 -- > fromListWith (++) [] == empty
3384
3385 fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a
3386 fromListWith f xs
3387 = fromListWithKey (\_ x y -> f x y) xs
3388 #if __GLASGOW_HASKELL__
3389 {-# INLINABLE fromListWith #-}
3390 #endif
3391
3392 -- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
3393 --
3394 -- > let f k a1 a2 = (show k) ++ a1 ++ a2
3395 -- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]
3396 -- > fromListWithKey f [] == empty
3397
3398 fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
3399 fromListWithKey f xs
3400 = Foldable.foldl' ins empty xs
3401 where
3402 ins t (k,x) = insertWithKey f k x t
3403 #if __GLASGOW_HASKELL__
3404 {-# INLINABLE fromListWithKey #-}
3405 #endif
3406
3407 -- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list fusion.
3408 --
3409 -- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
3410 -- > toList empty == []
3411
3412 toList :: Map k a -> [(k,a)]
3413 toList = toAscList
3414
3415 -- | /O(n)/. Convert the map to a list of key\/value pairs where the keys are
3416 -- in ascending order. Subject to list fusion.
3417 --
3418 -- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
3419
3420 toAscList :: Map k a -> [(k,a)]
3421 toAscList = foldrWithKey (\k x xs -> (k,x):xs) []
3422
3423 -- | /O(n)/. Convert the map to a list of key\/value pairs where the keys
3424 -- are in descending order. Subject to list fusion.
3425 --
3426 -- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]
3427
3428 toDescList :: Map k a -> [(k,a)]
3429 toDescList = foldlWithKey (\xs k x -> (k,x):xs) []
3430
3431 -- List fusion for the list generating functions.
3432 #if __GLASGOW_HASKELL__
3433 -- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.
3434 -- They are important to convert unfused methods back, see mapFB in prelude.
3435 foldrFB :: (k -> a -> b -> b) -> b -> Map k a -> b
3436 foldrFB = foldrWithKey
3437 {-# INLINE[0] foldrFB #-}
3438 foldlFB :: (a -> k -> b -> a) -> a -> Map k b -> a
3439 foldlFB = foldlWithKey
3440 {-# INLINE[0] foldlFB #-}
3441
3442 -- Inline assocs and toList, so that we need to fuse only toAscList.
3443 {-# INLINE assocs #-}
3444 {-# INLINE toList #-}
3445
3446 -- The fusion is enabled up to phase 2 included. If it does not succeed,
3447 -- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to
3448 -- elems,keys,to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were
3449 -- used in a list fusion, otherwise it would go away in phase 1), and let compiler
3450 -- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to
3451 -- inline it before phase 0, otherwise the fusion rules would not fire at all.
3452 {-# NOINLINE[0] elems #-}
3453 {-# NOINLINE[0] keys #-}
3454 {-# NOINLINE[0] toAscList #-}
3455 {-# NOINLINE[0] toDescList #-}
3456 {-# RULES "Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}
3457 {-# RULES "Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}
3458 {-# RULES "Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}
3459 {-# RULES "Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}
3460 {-# RULES "Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}
3461 {-# RULES "Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}
3462 {-# RULES "Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}
3463 {-# RULES "Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}
3464 #endif
3465
3466 {--------------------------------------------------------------------
3467 Building trees from ascending/descending lists can be done in linear time.
3468
3469 Note that if [xs] is ascending that:
3470 fromAscList xs == fromList xs
3471 fromAscListWith f xs == fromListWith f xs
3472 --------------------------------------------------------------------}
3473 -- | /O(n)/. Build a map from an ascending list in linear time.
3474 -- /The precondition (input list is ascending) is not checked./
3475 --
3476 -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
3477 -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
3478 -- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True
3479 -- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False
3480
3481 fromAscList :: Eq k => [(k,a)] -> Map k a
3482 fromAscList xs
3483 = fromDistinctAscList (combineEq xs)
3484 where
3485 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
3486 combineEq xs'
3487 = case xs' of
3488 [] -> []
3489 [x] -> [x]
3490 (x:xx) -> combineEq' x xx
3491
3492 combineEq' z [] = [z]
3493 combineEq' z@(kz,_) (x@(kx,xx):xs')
3494 | kx==kz = combineEq' (kx,xx) xs'
3495 | otherwise = z:combineEq' x xs'
3496 #if __GLASGOW_HASKELL__
3497 {-# INLINABLE fromAscList #-}
3498 #endif
3499
3500 -- | /O(n)/. Build a map from a descending list in linear time.
3501 -- /The precondition (input list is descending) is not checked./
3502 --
3503 -- > fromDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]
3504 -- > fromDescList [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "b")]
3505 -- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True
3506 -- > valid (fromDescList [(5,"a"), (3,"b"), (5,"b")]) == False
3507 --
3508 -- @since 0.5.8
3509
3510 fromDescList :: Eq k => [(k,a)] -> Map k a
3511 fromDescList xs = fromDistinctDescList (combineEq xs)
3512 where
3513 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
3514 combineEq xs'
3515 = case xs' of
3516 [] -> []
3517 [x] -> [x]
3518 (x:xx) -> combineEq' x xx
3519
3520 combineEq' z [] = [z]
3521 combineEq' z@(kz,_) (x@(kx,xx):xs')
3522 | kx==kz = combineEq' (kx,xx) xs'
3523 | otherwise = z:combineEq' x xs'
3524 #if __GLASGOW_HASKELL__
3525 {-# INLINABLE fromDescList #-}
3526 #endif
3527
3528 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
3529 -- /The precondition (input list is ascending) is not checked./
3530 --
3531 -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
3532 -- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True
3533 -- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False
3534
3535 fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
3536 fromAscListWith f xs
3537 = fromAscListWithKey (\_ x y -> f x y) xs
3538 #if __GLASGOW_HASKELL__
3539 {-# INLINABLE fromAscListWith #-}
3540 #endif
3541
3542 -- | /O(n)/. Build a map from a descending list in linear time with a combining function for equal keys.
3543 -- /The precondition (input list is descending) is not checked./
3544 --
3545 -- > fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "ba")]
3546 -- > valid (fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")]) == True
3547 -- > valid (fromDescListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False
3548 --
3549 -- @since 0.5.8
3550
3551 fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a
3552 fromDescListWith f xs
3553 = fromDescListWithKey (\_ x y -> f x y) xs
3554 #if __GLASGOW_HASKELL__
3555 {-# INLINABLE fromDescListWith #-}
3556 #endif
3557
3558 -- | /O(n)/. Build a map from an ascending list in linear time with a
3559 -- combining function for equal keys.
3560 -- /The precondition (input list is ascending) is not checked./
3561 --
3562 -- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
3563 -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]
3564 -- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True
3565 -- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False
3566
3567 fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
3568 fromAscListWithKey f xs
3569 = fromDistinctAscList (combineEq f xs)
3570 where
3571 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
3572 combineEq _ xs'
3573 = case xs' of
3574 [] -> []
3575 [x] -> [x]
3576 (x:xx) -> combineEq' x xx
3577
3578 combineEq' z [] = [z]
3579 combineEq' z@(kz,zz) (x@(kx,xx):xs')
3580 | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs'
3581 | otherwise = z:combineEq' x xs'
3582 #if __GLASGOW_HASKELL__
3583 {-# INLINABLE fromAscListWithKey #-}
3584 #endif
3585
3586 -- | /O(n)/. Build a map from a descending list in linear time with a
3587 -- combining function for equal keys.
3588 -- /The precondition (input list is descending) is not checked./
3589 --
3590 -- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
3591 -- > fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]
3592 -- > valid (fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")]) == True
3593 -- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False
3594 fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a
3595 fromDescListWithKey f xs
3596 = fromDistinctDescList (combineEq f xs)
3597 where
3598 -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
3599 combineEq _ xs'
3600 = case xs' of
3601 [] -> []
3602 [x] -> [x]
3603 (x:xx) -> combineEq' x xx
3604
3605 combineEq' z [] = [z]
3606 combineEq' z@(kz,zz) (x@(kx,xx):xs')
3607 | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs'
3608 | otherwise = z:combineEq' x xs'
3609 #if __GLASGOW_HASKELL__
3610 {-# INLINABLE fromDescListWithKey #-}
3611 #endif
3612
3613
3614 -- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
3615 -- /The precondition is not checked./
3616 --
3617 -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
3618 -- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True
3619 -- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False
3620
3621 -- For some reason, when 'singleton' is used in fromDistinctAscList or in
3622 -- create, it is not inlined, so we inline it manually.
3623 fromDistinctAscList :: [(k,a)] -> Map k a
3624 fromDistinctAscList [] = Tip
3625 fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0
3626 where
3627 go !_ t [] = t
3628 go s l ((kx, x) : xs) = case create s xs of
3629 (r :*: ys) -> let !t' = link kx x l r
3630 in go (s `shiftL` 1) t' ys
3631
3632 create !_ [] = (Tip :*: [])
3633 create s xs@(x' : xs')
3634 | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip :*: xs')
3635 | otherwise = case create (s `shiftR` 1) xs of
3636 res@(_ :*: []) -> res
3637 (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of
3638 (r :*: zs) -> (link ky y l r :*: zs)
3639
3640 -- | /O(n)/. Build a map from a descending list of distinct elements in linear time.
3641 -- /The precondition is not checked./
3642 --
3643 -- > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]
3644 -- > valid (fromDistinctDescList [(5,"a"), (3,"b")]) == True
3645 -- > valid (fromDistinctDescList [(5,"a"), (5,"b"), (3,"b")]) == False
3646 --
3647 -- @since 0.5.8
3648
3649 -- For some reason, when 'singleton' is used in fromDistinctDescList or in
3650 -- create, it is not inlined, so we inline it manually.
3651 fromDistinctDescList :: [(k,a)] -> Map k a
3652 fromDistinctDescList [] = Tip
3653 fromDistinctDescList ((kx0, x0) : xs0) = go (1 :: Int) (Bin 1 kx0 x0 Tip Tip) xs0
3654 where
3655 go !_ t [] = t
3656 go s r ((kx, x) : xs) = case create s xs of
3657 (l :*: ys) -> let !t' = link kx x l r
3658 in go (s `shiftL` 1) t' ys
3659
3660 create !_ [] = (Tip :*: [])
3661 create s xs@(x' : xs')
3662 | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip :*: xs')
3663 | otherwise = case create (s `shiftR` 1) xs of
3664 res@(_ :*: []) -> res
3665 (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of
3666 (l :*: zs) -> (link ky y l r :*: zs)
3667
3668 {-
3669 -- Functions very similar to these were used to implement
3670 -- hedge union, intersection, and difference algorithms that we no
3671 -- longer use. These functions, however, seem likely to be useful
3672 -- in their own right, so I'm leaving them here in case we end up
3673 -- exporting them.
3674
3675 {--------------------------------------------------------------------
3676 [filterGt b t] filter all keys >[b] from tree [t]
3677 [filterLt b t] filter all keys <[b] from tree [t]
3678 --------------------------------------------------------------------}
3679 filterGt :: Ord k => k -> Map k v -> Map k v
3680 filterGt !_ Tip = Tip
3681 filterGt !b (Bin _ kx x l r) =
3682 case compare b kx of LT -> link kx x (filterGt b l) r
3683 EQ -> r
3684 GT -> filterGt b r
3685 #if __GLASGOW_HASKELL__
3686 {-# INLINABLE filterGt #-}
3687 #endif
3688
3689 filterLt :: Ord k => k -> Map k v -> Map k v
3690 filterLt !_ Tip = Tip
3691 filterLt !b (Bin _ kx x l r) =
3692 case compare kx b of LT -> link kx x l (filterLt b r)
3693 EQ -> l
3694 GT -> filterLt b l
3695 #if __GLASGOW_HASKELL__
3696 {-# INLINABLE filterLt #-}
3697 #endif
3698 -}
3699
3700 {--------------------------------------------------------------------
3701 Split
3702 --------------------------------------------------------------------}
3703 -- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where
3704 -- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.
3705 -- Any key equal to @k@ is found in neither @map1@ nor @map2@.
3706 --
3707 -- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])
3708 -- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")
3709 -- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
3710 -- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)
3711 -- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)
3712
3713 split :: Ord k => k -> Map k a -> (Map k a,Map k a)
3714 split !k0 t0 = toPair $ go k0 t0
3715 where
3716 go k t =
3717 case t of
3718 Tip -> Tip :*: Tip
3719 Bin _ kx x l r -> case compare k kx of
3720 LT -> let (lt :*: gt) = go k l in lt :*: link kx x gt r
3721 GT -> let (lt :*: gt) = go k r in link kx x l lt :*: gt
3722 EQ -> (l :*: r)
3723 #if __GLASGOW_HASKELL__
3724 {-# INLINABLE split #-}
3725 #endif
3726
3727 -- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just
3728 -- like 'split' but also returns @'lookup' k map@.
3729 --
3730 -- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])
3731 -- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")
3732 -- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")
3733 -- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)
3734 -- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)
3735 splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)
3736 splitLookup k0 m = case go k0 m of
3737 StrictTriple l mv r -> (l, mv, r)
3738 where
3739 go :: Ord k => k -> Map k a -> StrictTriple (Map k a) (Maybe a) (Map k a)
3740 go !k t =
3741 case t of
3742 Tip -> StrictTriple Tip Nothing Tip
3743 Bin _ kx x l r -> case compare k kx of
3744 LT -> let StrictTriple lt z gt = go k l
3745 !gt' = link kx x gt r
3746 in StrictTriple lt z gt'
3747 GT -> let StrictTriple lt z gt = go k r
3748 !lt' = link kx x l lt
3749 in StrictTriple lt' z gt
3750 EQ -> StrictTriple l (Just x) r
3751 #if __GLASGOW_HASKELL__
3752 {-# INLINABLE splitLookup #-}
3753 #endif
3754
3755 -- | A variant of 'splitLookup' that indicates only whether the
3756 -- key was present, rather than producing its value. This is used to
3757 -- implement 'intersection' to avoid allocating unnecessary 'Just'
3758 -- constructors.
3759 splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)
3760 splitMember k0 m = case go k0 m of
3761 StrictTriple l mv r -> (l, mv, r)
3762 where
3763 go :: Ord k => k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)
3764 go !k t =
3765 case t of
3766 Tip -> StrictTriple Tip False Tip
3767 Bin _ kx x l r -> case compare k kx of
3768 LT -> let StrictTriple lt z gt = go k l
3769 !gt' = link kx x gt r
3770 in StrictTriple lt z gt'
3771 GT -> let StrictTriple lt z gt = go k r
3772 !lt' = link kx x l lt
3773 in StrictTriple lt' z gt
3774 EQ -> StrictTriple l True r
3775 #if __GLASGOW_HASKELL__
3776 {-# INLINABLE splitMember #-}
3777 #endif
3778
3779 data StrictTriple a b c = StrictTriple !a !b !c
3780
3781 {--------------------------------------------------------------------
3782 Utility functions that maintain the balance properties of the tree.
3783 All constructors assume that all values in [l] < [k] and all values
3784 in [r] > [k], and that [l] and [r] are valid trees.
3785
3786 In order of sophistication:
3787 [Bin sz k x l r] The type constructor.
3788 [bin k x l r] Maintains the correct size, assumes that both [l]
3789 and [r] are balanced with respect to each other.
3790 [balance k x l r] Restores the balance and size.
3791 Assumes that the original tree was balanced and
3792 that [l] or [r] has changed by at most one element.
3793 [link k x l r] Restores balance and size.
3794
3795 Furthermore, we can construct a new tree from two trees. Both operations
3796 assume that all values in [l] < all values in [r] and that [l] and [r]
3797 are valid:
3798 [glue l r] Glues [l] and [r] together. Assumes that [l] and
3799 [r] are already balanced with respect to each other.
3800 [link2 l r] Merges two trees and restores balance.
3801 --------------------------------------------------------------------}
3802
3803 {--------------------------------------------------------------------
3804 Link
3805 --------------------------------------------------------------------}
3806 link :: k -> a -> Map k a -> Map k a -> Map k a
3807 link kx x Tip r = insertMin kx x r
3808 link kx x l Tip = insertMax kx x l
3809 link kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
3810 | delta*sizeL < sizeR = balanceL kz z (link kx x l lz) rz
3811 | delta*sizeR < sizeL = balanceR ky y ly (link kx x ry r)
3812 | otherwise = bin kx x l r
3813
3814
3815 -- insertMin and insertMax don't perform potentially expensive comparisons.
3816 insertMax,insertMin :: k -> a -> Map k a -> Map k a
3817 insertMax kx x t
3818 = case t of
3819 Tip -> singleton kx x
3820 Bin _ ky y l r
3821 -> balanceR ky y l (insertMax kx x r)
3822
3823 insertMin kx x t
3824 = case t of
3825 Tip -> singleton kx x
3826 Bin _ ky y l r
3827 -> balanceL ky y (insertMin kx x l) r
3828
3829 {--------------------------------------------------------------------
3830 [link2 l r]: merges two trees.
3831 --------------------------------------------------------------------}
3832 link2 :: Map k a -> Map k a -> Map k a
3833 link2 Tip r = r
3834 link2 l Tip = l
3835 link2 l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
3836 | delta*sizeL < sizeR = balanceL ky y (link2 l ly) ry
3837 | delta*sizeR < sizeL = balanceR kx x lx (link2 rx r)
3838 | otherwise = glue l r
3839
3840 {--------------------------------------------------------------------
3841 [glue l r]: glues two trees together.
3842 Assumes that [l] and [r] are already balanced with respect to each other.
3843 --------------------------------------------------------------------}
3844 glue :: Map k a -> Map k a -> Map k a
3845 glue Tip r = r
3846 glue l Tip = l
3847 glue l@(Bin sl kl xl ll lr) r@(Bin sr kr xr rl rr)
3848 | sl > sr = let !(MaxView km m l') = maxViewSure kl xl ll lr in balanceR km m l' r
3849 | otherwise = let !(MinView km m r') = minViewSure kr xr rl rr in balanceL km m l r'
3850
3851 data MinView k a = MinView !k a !(Map k a)
3852 data MaxView k a = MaxView !k a !(Map k a)
3853
3854 minViewSure :: k -> a -> Map k a -> Map k a -> MinView k a
3855 minViewSure = go
3856 where
3857 go k x Tip r = MinView k x r
3858 go k x (Bin _ kl xl ll lr) r =
3859 case go kl xl ll lr of
3860 MinView km xm l' -> MinView km xm (balanceR k x l' r)
3861 {-# NOINLINE minViewSure #-}
3862
3863 maxViewSure :: k -> a -> Map k a -> Map k a -> MaxView k a
3864 maxViewSure = go
3865 where
3866 go k x l Tip = MaxView k x l
3867 go k x l (Bin _ kr xr rl rr) =
3868 case go kr xr rl rr of
3869 MaxView km xm r' -> MaxView km xm (balanceL k x l r')
3870 {-# NOINLINE maxViewSure #-}
3871
3872 -- | /O(log n)/. Delete and find the minimal element.
3873 --
3874 -- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")])
3875 -- > deleteFindMin Error: can not return the minimal element of an empty map
3876
3877 deleteFindMin :: Map k a -> ((k,a),Map k a)
3878 deleteFindMin t = case minViewWithKey t of
3879 Nothing -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
3880 Just res -> res
3881
3882 -- | /O(log n)/. Delete and find the maximal element.
3883 --