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