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